Excel VBA生成Gmail草稿时保留Word文档格式的问题

安全阿岳

2026-7-16

问题

使用Excel VBA通过Gmail API创建草稿时，读取Word文档内容作为邮件正文出现格式丢失：段落、字号等格式消失，文本合并为纯文本单段落。尝试将Word转HTML后插入邮件，结果收件箱显示带大量HTML标签的文本而非格式化内容。

当前读取Word和构建邮件的代码片段：

Dim emailBody As String
               
' Read the email body from the Word document
emailBody = ReadWordDocument(wb.Path & "\" & folderNum & "\email.docx")
' Construct the email message
Dim message As String
message = "To: " & recipient & vbCrLf
message = message & "Subject: " & subject & vbCrLf
message = message & "Content-Type: multipart/mixed; boundary=foo_bar_baz" & vbCrLf & vbCrLf
message = message & "--foo_bar_baz" & vbCrLf
message = message & "Content-Type: text/html; charset=utf-8" & vbCrLf & vbCrLf
message = message & "Dear " & position & " " & firstName & " " & lastName & "," & vbCrLf & vbCrLf
message = message & emailBody & vbCrLf & vbCrLf

Function ReadWordDocument(ByVal filePath As String) As String
    Dim objWord As Object
    Set objWord = CreateObject("Word.Application")
    
    Dim objDoc As Object
    Set objDoc = objWord.Documents.Open(filePath)
    
    ' Save the document as HTML
    Dim htmlFilePath As String
    htmlFilePath = Left(filePath, Len(filePath) - 4) & ".html"
    
    objDoc.SaveAs2 htmlFilePath, 10 ' wdFormatHTML = 10
    
    ' Read the HTML content
    Dim fileContent As String
    Dim fileNumber As Integer
    
    fileNumber = FreeFile
    Open htmlFilePath For Input As fileNumber
    fileContent = Input$(LOF(fileNumber), fileNumber)
    Close fileNumber
    
    ' Delete the temporary HTML file
    Kill htmlFilePath
    
    ReadWordDocument = fileContent
    
    objDoc.Close
    objWord.Quit
End Function

创建/更新草稿及Base64编码函数：

' Function to create a draft email
Function CreateDraftEmail(ByVal accessToken As String, ByVal recipient As String, ByVal subject As String, ByVal message As String)
    Dim url As String
    url = "https://www.googleapis.com/gmail/v1/users/me/drafts"
    
    Dim headers As Object
    Set headers = CreateObject("Scripting.Dictionary")
    headers("Authorization") = "Bearer " & accessToken
    headers("Content-Type") = "application/json"
    
    Dim payload As String
    payload = "{""message"": {""raw"": """ & EncodeBase64(message) & """}}"
    
    Dim response As String
    SendRequestWithHeaders "POST", url, headers, payload, response
    
    Dim draftID As String
    draftID = GetJsonValue(response, "id")
    
    ' Update the draft ID in the Excel worksheet
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Supervisors")
    
    Dim rowNum As Integer
    rowNum = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Dim recipientColumn As Range
    Set recipientColumn = ws.Range("E2:E" & rowNum)
    
    Dim draftIDColumn As Range
    Set draftIDColumn = ws.Range("O2:O" & rowNum)
    
    Dim recipientCell As Range
    Set recipientCell = recipientColumn.Find(recipient, LookIn:=xlValues, LookAt:=xlWhole)
    
    Dim draftIDCell As Range
    If Not recipientCell Is Nothing Then
        Set draftIDCell = draftIDColumn.Cells(recipientCell.Row - recipientColumn.Cells(1).Row + 1)
        draftIDCell.Value = draftID
    End If
    
     ' Return the draft status
    If draftID <> "" Then
        CreateDraftEmail = "Success"
    Else
        CreateDraftEmail = "DraftError"
    End If
    
End Function

' Function to update a draft email
Function UpdateDraftEmail(ByVal accessToken As String, ByVal draftID As String, ByVal recipient As String, ByVal subject As String, ByVal message As String)
    Dim url As String
    url = "https://www.googleapis.com/gmail/v1/users/me/drafts/" & draftID
    
    Dim headers As Object
    Set headers = CreateObject("Scripting.Dictionary")
    headers("Authorization") = "Bearer " & accessToken
    headers("Content-Type") = "application/json"
    
    Dim payload As String
    payload = "{""message"": {""raw"": """ & EncodeBase64(message) & """}}"
    
    Dim response As String
    SendRequestWithHeaders "PUT", url, headers, payload, response
    
   ' Return the draft status
    If InStr(response, """id"":") > 0 Then
        UpdateDraftEmail = "Success"
    Else
        UpdateDraftEmail = "DraftError"
    End If
    
End Function

' Function to send an HTTP request with headers
Sub SendRequestWithHeaders(ByVal method As String, ByVal url As String, ByRef headers As Object, ByVal payload As String, ByRef response As String)
    Dim objHTTP As Object
    Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    objHTTP.Open method, url, False
    
    Dim header As Variant
    For Each header In headers.Keys
        objHTTP.setRequestHeader header, headers(header)
    Next header
    
    objHTTP.send payload
    
    response = objHTTP.responseText
End Sub

' Function to encode text as base64
Function EncodeBase64(ByVal inputText As String) As String
    Dim arrData() As Byte
    arrData = StrConv(inputText, vbFromUnicode)
    
    Dim objXML As Object
    Set objXML = CreateObject("Msxml2.DOMDocument.6.0")
    
    Dim objNode As Object
    Set objNode = objXML.createElement("base64")
    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    
    EncodeBase64 = Replace(objNode.Text, vbLf, "")
End Function

需求：修改代码或采用其他方法，读取Word内容作为邮件正文时保留字号、段落结构，在Gmail界面及收件方系统维持原始格式。

解决方案

问题根源

Word转HTML时生成完整的HTML文档（包含<html>、<head>、<body>标签），直接插入邮件会导致Gmail解析异常，显示原始标签而非格式化内容。
邮件MIME格式边界处理不规范，缺少必要的编码头信息。
原Base64编码未适配Gmail要求的URL安全格式。

修改步骤及代码

1. 优化Word转HTML逻辑，提取有效内容

直接从Word复制HTML格式内容，并只保留<body>内部的有效内容：

Function ReadWordDocument(ByVal filePath As String) As String
    Dim objWord As Object
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = False ' 后台运行，不显示Word窗口
    
    Dim objDoc As Object
    Set objDoc = objWord.Documents.Open(filePath, ReadOnly:=True)
    
    ' 直接复制内容为HTML格式，无需临时文件
    objDoc.Content.Copy
    Dim htmlContent As String
    htmlContent = objWord.ClipboardGetData(13) ' wdFormatHTML = 13
    
    ' 提取<body>标签内的核心内容
    Dim startPos As Integer, endPos As Integer
    startPos = InStr(htmlContent, "<body")
    If startPos > 0 Then
        startPos = InStr(startPos, htmlContent, ">") + 1
        endPos = InStr(htmlContent, "</body>")
        If endPos > startPos Then
            htmlContent = Mid(htmlContent, startPos, endPos - startPos)
        End If
    End If
    
    ReadWordDocument = htmlContent
    
    objDoc.Close SaveChanges:=False
    objWord.Quit
    Set objDoc = Nothing
    Set objWord = Nothing
End Function

2. 修正邮件MIME格式构建

使用multipart/alternative类型，同时提供纯文本和HTML版本，确保兼容所有邮箱客户端：

' 重构邮件消息构建代码
Dim emailBody As String
emailBody = ReadWordDocument(wb.Path & "\" & folderNum & "\email.docx")

' 构建完整HTML正文，包含问候语
Dim htmlBody As String
htmlBody = "<p>Dear " & position & " " & firstName & " " & lastName & ",</p>" & vbCrLf
htmlBody = htmlBody & emailBody

' 生成唯一边界值，避免冲突
Dim boundary As String
boundary = "----GMAIL_BOUNDARY_" & Format(Now, "YYYYMMDDHHMMSS")

' 构建符合标准的MIME消息
Dim message As String
message = "To: " & recipient & vbCrLf
message = message & "Subject: " & subject & vbCrLf
message = message & "MIME-Version: 1.0" & vbCrLf
message = message & "Content-Type: multipart/alternative; boundary=""" & boundary & """" & vbCrLf & vbCrLf

' 纯文本备用部分（兼容不支持HTML的邮箱）
message = message & "--" & boundary & vbCrLf
message = message & "Content-Type: text/plain; charset=utf-8" & vbCrLf
message = message & "Content-Transfer-Encoding: quoted-printable" & vbCrLf & vbCrLf
message = message & "Dear " & position & " " & firstName & " " & lastName & "," & vbCrLf & vbCrLf
message = message & Replace(Replace(htmlBody, "<p>", vbCrLf), "</p>", vbCrLf) & vbCrLf & vbCrLf

' HTML正文部分
message = message & "--" & boundary & vbCrLf
message = message & "Content-Type: text/html; charset=utf-8" & vbCrLf
message = message & "Content-Transfer-Encoding: quoted-printable" & vbCrLf & vbCrLf
message = message & htmlBody & vbCrLf & vbCrLf

' 结束边界
message = message & "--" & boundary & "--"

3. 适配Gmail的URL安全Base64编码

Gmail要求raw字段使用URL安全的Base64格式，需替换特殊字符：

Function EncodeBase64UrlSafe(ByVal inputText As String) As String
    Dim arrData() As Byte
    arrData = StrConv(inputText, vbFromUnicode)
    
    Dim objXML As Object
    Set objXML = CreateObject("Msxml2.DOMDocument.6.0")
    
    Dim objNode As Object
    Set objNode = objXML.createElement("base64")
    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    
    Dim base64Text As String
    base64Text = Replace(objNode.Text, vbLf, "")
    ' 转换为URL安全格式
    base64Text = Replace(base64Text, "+", "-")
    base64Text = Replace(base64Text, "/", "_")
    base64Text = Replace(base64Text, "=", "")
    
    EncodeBase64UrlSafe = base64Text
End Function

4. 更新草稿创建/更新函数

替换原编码函数为URL安全版本：

' 在CreateDraftEmail中修改payload行
payload = "{""message"": {""raw"": """ & EncodeBase64UrlSafe(message) & """}}"

' 在UpdateDraftEmail中同样修改payload行
payload = "{""message"": {""raw"": """ & EncodeBase64UrlSafe(message) & """}}"

关键说明

使用Word剪贴板直接获取HTML内容，比保存文件更高效，格式保留更准确。
multipart/alternative类型同时提供纯文本和HTML版本，确保所有邮箱都能正常显示。
URL安全的Base64编码是Gmail API的强制要求，否则会导致消息解析失败。

内容的提问来源于stack exchange，提问作者Hamed

Excel VBA生成Gmail草稿时保留Word文档格式的问题

问题根源 #

修改步骤及代码 #

1. 优化Word转HTML逻辑，提取有效内容 #

2. 修正邮件MIME格式构建 #

3. 适配Gmail的URL安全Base64编码 #

4. 更新草稿创建/更新函数 #

关键说明 #