Как вы в конце концов реализовали это? Я искал похожее решение, но не смог найти ничего, так что я использовал макрос VBA в Outlook, который они нажимают, когда выбирается сообщение. Затем сообщение копируется в виде MSG во временную папку, а затем отправляется в HTML-форму.
Я добавил код, который я исправил, из различных веб-источников (в том числе здесь - извините, я не помню, чтобы сохранить ссылки) ниже на случай, если кто-нибудь захочет сделать то же самое.
Я уверен, что его можно оптимизировать и т. Д., Так как я очень плохо знаком с VBA (вчера!), Но сейчас он выполняет свою работу, хотя я думаю, что мне хотелось бы сделать это проверить, существует ли окно IE, и добавить новую вкладку чем открывать новый браузер при каждом нажатии.
' Function to maximize IE window
Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Global Const SW_MAXIMIZE = 3
Global Const SW_SHOWNORMAL = 1
Global Const SW_SHOWMINIMIZED = 2
Sub test()
'the mail we want to process
Dim objItem As Outlook.MailItem
'question for saving, use subject to save
Dim strPrompt As String, strname As String
'variables for the replacement of illegal characters
Dim sreplace As String, mychar As Variant, strdate As String
'put active mail in this object holder
Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
'check if it's an email ... need to take a closer look cause
'gives an error when something else (contact, task) is selected
'because objItem is defined as a mailitem and code errors out
'saving does work, if you take care that a mailitem is selected
'before executing this code
If objItem.Class = olMail Then
'check on subject
If objItem.Subject <> vbNullString Then
strname = objItem.Subject
Else
strname = "No_Subject"
End If
strdate = objItem.ReceivedTime
'define the character that will replace illegal characters
sreplace = "_"
'create an array to loop through illegal characters (saves lines)
For Each mychar In Array(" ", "/", "\", ":", "?", Chr(34), "<", ">", "¦")
'do the replacement for each character that's illegal
strname = Replace(strname, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
Next mychar
'Prompt the user for confirmation
strPrompt = "Upload the email to CRM?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
Dim location As String
Dim tempPath As String
tempPath = IIf(Environ$("tmp") <> "", Environ$("tmp"), Environ$("temp"))
location = tempPath & "\" & strname & "-" & strdate & ".msg"
objItem.SaveAs location, olMSG
'upload to IE
UploadFile "http://intranet/test.php", location, "msgupload"
End If
End If
End Sub
'******************* upload - begin
'Upload file using input type=file
Sub UploadFile(DestURL As String, FileName As String, _
Optional ByVal FieldName As String = "File")
Dim sFormData As String, d As String
'Boundary of fields.
'Be sure this string is Not In the source file
Const Boundary As String = "---------------------------0123456789012"
'Get source file As a string.
sFormData = GetFile(FileName)
'Build source form with file contents
d = "--" + Boundary + vbCrLf
d = d + "Content-Disposition: form-data; name=""" + FieldName + """;"
d = d + " filename=""" + FileName + """" + vbCrLf
d = d + "Content-Type: application/upload" + vbCrLf + vbCrLf
d = d + sFormData
d = d + vbCrLf + "--" + Boundary + "--" + vbCrLf
'Post the data To the destination URL
IEPostStringRequest DestURL, d, Boundary
End Sub
'sends URL encoded form data To the URL using IE
Sub IEPostStringRequest(URL As String, FormData As String, Boundary As String)
'Create InternetExplorer
Dim WebBrowser: Set WebBrowser = CreateObject("InternetExplorer.Application")
'You can uncoment Next line To see form results
WebBrowser.Visible = True
'Send the form data To URL As POST request
Dim bFormData() As Byte
ReDim bFormData(Len(FormData) - 1)
bFormData = StrConv(FormData, vbFromUnicode)
' Submit message to intranet
WebBrowser.Navigate2 URL, , , bFormData, "Content-Type: multipart/form-data; boundary=" + Boundary + vbCrLf
' Maximize window
apiShowWindow WebBrowser.hwnd, SW_MAXIMIZE
End Sub
'read binary file As a string value
Function GetFile(FileName As String) As String
Dim FileContents() As Byte, FileNumber As Integer
ReDim FileContents(FileLen(FileName) - 1)
FileNumber = FreeFile
Open FileName For Binary As FileNumber
Get FileNumber, , FileContents
Close FileNumber
GetFile = StrConv(FileContents, vbUnicode)
End Function
'******************* upload - end
Простой PHP-скрипт для захвата файла:
<?php
if($_FILES['msgupload']){
move_uploaded_file($_FILES['msgupload']['tmp_name'], "./crm_uploads/".substr($_FILES['msgupload']['name'], 0 ,-24).".msg");
print("You are adding the email '".substr($_FILES['msgupload']['name'], 0, -24)."'");
print("<br />dated ".substr($_FILES['msgupload']['name'], -23, -4));
}
?>