Can anyone help i have peaced together the below code through using Google and a bit of trial and error, I have created a macro to send an email based on data in a spread sheet. My problem is the email signature does not display the pictures can anyone help? see below code
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Dim Signature As String
Dim xAccount As Object
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
Signature = Environ("appdata") & "\Microsoft\Signatures"
If Dir(Signature, vbDirectory) <> vbNullString Then
Signature = Signature & Dir$(Signature & "*.htm")
Else:
Signature = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
xMailBody = "Dear " & Range("L2") & "," & "
" & "
" & _
Range("C2") & " " & Range("B2") & " - " & Range("A2") & "Text" & "
" & "
" & _
"text" & Range("C2") & "text" & "
" & "
" & _
"Text" & Range("C2") & "text" & "
" & "
" & _
"Text" & "
" & "
" & _
"Kind Regards," & "
" & "
" & _
"name" & "
" & _
"Job title" & "
" & "
"
On Error Resume Next
With xOutMail
.To = Range("N2")
.CC = ""
.BCC = ""
.Subject = "Subject"
.HTMLBody = xMailBody & Signature
Set .SendUsingAccount = xOutApp.Session.Accounts.Item(2)
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
Rows("2:2").Delete
End Sub
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Dim Signature As String
Dim xAccount As Object
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
Signature = Environ("appdata") & "\Microsoft\Signatures"
If Dir(Signature, vbDirectory) <> vbNullString Then
Signature = Signature & Dir$(Signature & "*.htm")
Else:
Signature = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
xMailBody = "Dear " & Range("L2") & "," & "
" & "
" & _
Range("C2") & " " & Range("B2") & " - " & Range("A2") & "Text" & "
" & "
" & _
"text" & Range("C2") & "text" & "
" & "
" & _
"Text" & Range("C2") & "text" & "
" & "
" & _
"Text" & "
" & "
" & _
"Kind Regards," & "
" & "
" & _
"name" & "
" & _
"Job title" & "
" & "
"
On Error Resume Next
With xOutMail
.To = Range("N2")
.CC = ""
.BCC = ""
.Subject = "Subject"
.HTMLBody = xMailBody & Signature
Set .SendUsingAccount = xOutApp.Session.Accounts.Item(2)
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
Rows("2:2").Delete
End Sub