excel - 使用 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)