Question

我一直很喜欢使用VBA，但写作并不是很好。我通常会根据需要编写源代码并进行编辑，但我无法让它工作！

我正在尝试从Excel发送电子邮件，我在其中选择一组电子邮件地址，并根据从不同单元格中获取的数据发送个性化电子邮件。这一切都很好，但我的签名没有出现。我已经尝试阅读不同的论坛以使其工作，但我无法使用我的代码。

你能帮我把我的签名（有图片）放进去吗？

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                         ByVal hwnd As LongPtr, ByVal lpOperation As String, _
                         ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                         ByVal nShowCmd As Long) As LongPtr
#Else
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                         ByVal hwnd As Long, ByVal lpOperation As String, _
                         ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                         ByVal nShowCmd As Long) As Long
#End If
    Sub Insurance_Email()
    'update by Extendoffice 20160506
      Dim xEmail As String
    Dim xSubj As String
    Dim xMsg As String
    Dim xURL As String
    Dim i As Integer
    Dim k As Double
    Dim xCell As Range
    Dim xRg As Range
    Dim xTxt As String
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please select the data range:", "Kutools     for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    If xRg.Columns.Count < 3 Then
        MsgBox " Regional format error, please check", , "Kutools for Excel"
        Exit Sub
    End If
    For i = 1 To xRg.Rows.Count
    '       Get the email address
        xEmail = xRg.Cells(i, 8)
    '       Message subject
        xSubj = "Insurance Expiry"
    '       Compose the message
        xMsg = ""
        xMsg = xMsg & "Dear " & xRg.Cells(i, 4) & "," & vbCrLf & vbCrLf
        xMsg = xMsg & " Our records indicate your insurance is due to expire on "
        xMsg = xMsg & xRg.Cells(i, 15).Text & "." & vbCrLf & vbCrLf
        xMsg = xMsg & " Can you please send through a confirmation of your updated insurance as soon as possible. " & vbCrLf & vbCrLf
    '       Replace spaces with %20 (hex)
        xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
        xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
    '       Replace carriage returns with %0D%0A (hex)
        xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
    '       Create the URL
        xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
    '       Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
    '       Wait two seconds before sending keystrokes
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"
    Next
End Sub

使用Excel VBA电子邮件创建显示签名

0 个答案: