这是一个完整的工作示例。如果您不需要“请稍候”对话框，只需使用第一个代码片段并将UploadThisFileMain其删除。还要注意最后的服务器 PHP 测试脚本。
Sub UploadThisFileMain()
If ActiveWorkbook.Saved = False Then
MsgBox "This workbook contains unsaved changes. Please save first."
Exit Sub
End If
Dim ret
ret = StartProcessing("File uploading, Please Wait...", "UploadThisFile")
If (ret = True) Then
MsgBox "Upload successful!"
Else
MsgBox "Upload failed: " & ret
End If
End Sub
Private Function UploadThisFile()
Dim bound As String
bound = "A0AD2346-9849-4EF0-9A93-ACFE17910734"
Dim url As String
url = "https://<YourServer>/index.php?id={" & bound & "}"
Dim path As String
path = ThisWorkbook.path & "\" & ThisWorkbook.Name
sMultipart = pvGetFileAsMultipart(path, bound)
On Error Resume Next
Dim r
r = pvPostMultipart(url, sMultipart, bound)
If Err.Number <> 0 Then
UploadThisFile = Err.Description
Err.Clear
Else
UploadThisFile = True
End If
End Function
'sends multipart/form-data To the URL using WinHttprequest/XMLHTTP
'FormData - binary (VT_UI1 | VT_ARRAY) multipart form data
Private Function pvPostMultipart(url, FormData, Boundary)
Dim http 'As New MSXML2.XMLHTTP
'Create XMLHTTP/ServerXMLHTTP/WinHttprequest object
'You can use any of these three objects.
'Set http = CreateObject("WinHttp.WinHttprequest.5")
'Set http = CreateObject("MSXML2.XMLHTTP")
Set http = CreateObject("MSXML2.ServerXMLHTTP")
'Open URL As POST request
http.Open "POST", url, False
'Set Content-Type header
http.setRequestHeader "Content-Type", "multipart/form-data; boundary=" + Boundary
'Send the form data To URL As POST binary request
http.send FormData
'Get a result of the script which has received upload
pvPostMultipart = http.responseText
End Function
Private Function pvGetFileAsMultipart(sFileName As String, Boundary As String) As Byte()
Dim nFile As Integer
Dim sPostData As String
'--- read file
nFile = FreeFile
Open sFileName For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbUnicode)
End If
Close nFile
'--- prepare body
sPostData = "--" & Boundary & vbCrLf & _
"Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
sPostData & vbCrLf & _
"--" & Boundary & "--"
'--- post
pvGetFileAsMultipart = pvToByteArray(sPostData)
End Function
Private Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbFromUnicode)
End Function
创建一个新模块Processing_Code：
Public Processing_Message As String
Public Macro_to_Process As String
Public Return_Value As String
Function StartProcessing(msg As String, code As String)
Processing_Message = msg 'Set the message that is displayed
'in the dialog box
Macro_to_Process = code 'Set the macro that is run after the
'dialog box is active
Processing_Dialog.Show 'Show the Dialog box
StartProcessing = Return_Value
End Function
创建一个表格Processing_Dialog。设置StartUpPosition为2 - CenterScreen。添加代码：
Private Sub UserForm_Initialize()
lblMessage.Caption = Processing_Message 'Change the Label
'Caption
End Sub
Private Sub UserForm_Activate()
Me.Repaint 'Refresh the UserForm
Return_Value = Application.Run(Macro_to_Process) 'Run the macro
Unload Me 'Unload the UserForm
End Sub
现在向您的工作表添加一个按钮（如果没有“开发人员”选项卡，请转到“选项”->“自定义功能区”-> 启用复选框“开发人员”）并分配宏UploadThisFileMain。
对于服务器部分，请使用此 PHP 测试脚本：
<?php
foreach (getallheaders() as $name => $value) {
echo "$name: $value\n";
}
echo "POST:";
print_r($_POST);
echo "GET:";
print_r($_GET);
echo "FILES:";
print_r($_FILES);
$entityBody = file_get_contents('php://input');
echo "Body:$entityBody";
exit;
$base_dir = dirname( __FILE__ ) . '/upload/';
if(!is_dir($base_dir))
mkdir($base_dir, 0777);
move_uploaded_file($_FILES["uploadfile"]["tmp_name"], $base_dir . '/' . $_FILES["uploadfile"]["name"]);
?>
资料来源：