Excel VBA使用.Display时无法发送邮件，但使用.Send时可以发送

前端开发 2026-07-12

当我运行这段代码时，邮件预览看起来完全正常，但是在我手动点击“发送”后，邮件既不会进入收件人的收件箱，也不会出现在我的已发送邮件中。

然而，如果我只使用.Send，邮件会立即发送，没有任何问题。

我的Outlook版本是1.2026.210.300

希望有人能找出造成这个问题的原因，因为我在另一个Excel文档中它是可以正常工作的。

代码如下：

Sub SendQuote()

    Dim ws As Worksheet
    Dim buttonRow As Long
    Dim shp As Shape

    Dim OutApp As Object
    Dim OutMail As Object

    Dim emailBody As String
    Dim customerName As String
    Dim customerEmail As String
    Dim reference As String
    Dim wbPath As String
    Dim filePath As String

    'Worksheet for Macro
    Set ws = ThisWorkbook.Worksheets("Jobs")

    'Detect Clicked Shape and Row
    Set shp = ws.Shapes(Application.Caller)
    buttonRow = shp.Top / ws.Rows(1).Height
    buttonRow = Int(buttonRow) + 1 'Round to nearest row

    'Fill Next Column Green to Mark as Sent
    ws.Cells(buttonRow, shp.TopLeftCell.Column + 1).Interior.Color = RGB(0, 176, 80)

    'Get Customer Details
    customerName = ws.Cells(buttonRow, "D").Value
    customerEmail = ws.Cells(buttonRow, "J").Value
    reference = ws.Cells(buttonRow, "B").Value

    'Debug
    'MsgBox "Name: " & customerName & vbCrLf & _
    '       "Email: " & customerEmail & vbCrLf & _
    '       "Reference: " & reference & vbCrLf & _
    '       "Button: L" & buttonRow & vbCrLf & _
    '       "Sheet: " & ws.Name

    'Start Outlook
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    'Editable Email Contents
    paymentTerms = "We take a small deposit prior to your move. During the unload at your destination, our team leader will request payment via BACS or credit/debit card."
    footer = "Yours Sincerely,<br><br>" & _
    "David Shepherd<br>" & _
    "<span style=""color:gray;"">Beemoved First Ltd<br>" & _
    "01582 851549<br>" & _
    "<a href=""beemovedfirst.co.uk"">beemovedfirst.co.uk</a>"

    'HTML Email Body
    emailBody = "<html><body style='font-family:Calibri;font-size:11pt;'>"

    emailBody = emailBody & "Dear " & customerName & ",<br><br>"
    emailBody = emailBody & "Thank you very much for your valued enquiry. It was a pleasure to meet you to discuss your moving requirements.<br><br>"

    emailBody = emailBody & "<table cellpadding=0 cellspacing=0 border=0>"
    emailBody = emailBody & "<tr>"
    emailBody = emailBody & "<td><b>[Online acceptance button]</b></td>"
    emailBody = emailBody & "<td width=10></td>"
    emailBody = emailBody & "<td valign=middle> to accept this quote online.</td>"
    emailBody = emailBody & "</tr></table><br>"

    emailBody = emailBody & paymentTerms & "<br><br>"
    emailBody = emailBody & "We have fully trained, uniformed staff, providing you with a friendly, stress free and professional removal.<br><br>"

    emailBody = emailBody & "<img src='https://beemovedfirst.co.uk/wp-content/uploads/2025/12/Packing-Materials.png' width='571'><br><br>"

    emailBody = emailBody & "Please find your quote attached and should you have any questions, please contact the main office where we will be happy to discuss your quotation further.<br><br>"

    emailBody = emailBody & footer
    emailBody = emailBody & "</body></html>"

    With OutMail
        'Main Email
        .To = customerEmail
        .Subject = "Your Quote from Beemoved First Ltd - Ref " & reference
        .HTMLBody = emailBody

        'Attachments Location
        wbPath = ThisWorkbook.Path
        filePath = wbPath & "\Attachments\Beemoved First Insurance Terms & Conditions.pdf"
        'Attachments
        .Attachments.Add filePath, 1, , "Terms & Conditions"

        .Display
    End With

Set OutApp = Nothing
Set OutMail = Nothing

End Sub