使用 Gmail 发送包含电子表格内容的电子邮件的宏

Question

我的代理需要填写销售表格，然后再将其发送给另一个进行注册的代理。因此，当代理单击按钮时，我为按钮设置了脚本，它会向其他代理发送电子邮件，但 我不确定如何包含电子表格数据。

我该怎么做？

这是我一直在使用的代码：

Sub sendemail()

    On Error GoTo Err

    Dim NewMail As Object
    Dim mailConfig As Object
    Dim fields As Variant
    Dim msConfigURL As String

    Set NewMail = CreateObject("CDO.Message")
    Set mailConfig = CreateObject("CDO.Configuration")

    ' load all default configurations
    mailConfig.Load -1
    Set fields = mailConfig.fields

    'Set All Email Properties
    With NewMail
        .Subject = "Sales Follow up"
        .From = ""
        .To = ""
        .CC = ""
        .BCC = ""
    End With

    msConfigURL = "http://schemas.microsoft.com/cdo/configuration"

    With fields
        'Enable SSL Authentication
        .Item(msConfigURL & "/smtpusessl") = True

        'Make SMTP authentication Enabled=true (1)
        .Item(msConfigURL & "/smtpauthenticate") = 1

        'Set the SMTP server and port Details
        'To get these details you can get on Settings Page of your Gmail Account
        .Item(msConfigURL & "/smtpserver") = "smtp.gmail.com"
        .Item(msConfigURL & "/smtpserverport") = 465
        .Item(msConfigURL & "/sendusing") = 2

        'Set your credentials of your Gmail Account
        .Item(msConfigURL & "/sendusername") = "********"
        .Item(msConfigURL & "/sendpassword") = "********"

        'Update the configuration fields
        .Update
    End With

    NewMail.Configuration = mailConfig
    NewMail.send
    MsgBox ("Mail has been Sent")

Exit_Err:

    Set NewMail = Nothing
    Set mailConfig = Nothing
    End

Err:


    Select Case Err.Number
        Case -2147220973  'Could be because of Internet Connection
            MsgBox " Could be no Internet Connection !!  -- " & Err.Description
        Case -2147220975  'Incorrect credentials User ID or password
            MsgBox "Incorrect Credentials !!  -- " & Err.Description
        Case Else   'Rest other errors
            MsgBox "Error occured while sending the email !!  -- " & Err.Description
    End Select

    Resume Exit_Err

End Sub

Answer 1

如果您不想附加工作表而只是显示数据（并假设以 HTML 格式发送邮件是可以的）：

以下函数从 Excel 范围创建一个 html 表

Function RangeToHtmlTable(r As Range)

    Dim data, row As Long, col As Long, html As String
    data = r.Value2
    html = "<table>"
    For row = 1 To UBound(data, 1)
        html = html & "<tr>"
        For col = 1 To UBound(data, 2)
            html = html & "<td>" & data(row, col) & "</td>"
        Next col
        html = html & "</tr>" & vbCrLf
    Next row
    html = html & "</table>"
    RangeToHtmlTable = html
End Function

函数调用 - 只需将 activesheet.usedRange 替换为您要发送的任何数据范围：

 With NewMail
    ...
    .HTMLBody = "<h1>Here is your data</h1>" & RangeToHtmlTable(activesheet.usedRange)
end with

更新：发送不带html格式的数据：

Function RangeToTable(r As Range, Optional separator As String = vbTab)

    Dim data, row As Long, col As Long, table As String
    data = r.Value2
    table = ""
    For row = 1 To UBound(data, 1)
        For col = 1 To UBound(data, 2)
            table = table & data(row, col) & separator
        Next col
        table = table & vbCrLf
    Next row
    RangeToTable = table
End Function

不发送 html 时，应将文本分配给 .TextBody 而不是 .HTMLBody。使用可选参数separator，您可以定义要在单元格之间显示的内容（例如"; "）

.TextBody = "Here is your data:" & vbrLf & vbCrLf & RangeToTable(activesheet.usedRange)