Макрос для отправки электронной почты с помощью 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 - это нормально):

Следующая функция создает html-таблицу из диапазона Excel

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)