I have a working function to create an email through Outlook 2010. It also grabs an established Outlook signature and places it into the email. My problem is that the signature contains the company logo as an embedded .png file. This works fine within Outlook, but when I create the email from Access 2010 the images do not display. You simply get a blank box where the image appears with the words "This image cannot currently be displayed". All the other text and web links within the signature all display fine.
I see a lot of different posts regarding this issue. Has anyone been able to solve this problem?
Thanks for the help.
Ed T.
Here is a copy of the function that I am using to create the email:
Code:
Public Function SentMailStatus(strMailTo As String, CCmail As String, strSub As String, sender As String, StrMsg As String, strDisplayName As String) As Boolean On Error GoTo Err_SentMailStatus
Dim Started As Boolean
Dim oApp As OutLook.Application
Dim oAccount As OutLook.Account
Dim oItem As OutLook.MailItem
Dim intItemHold As Integer
Dim varGotIt As Variant
Dim SigString As String
Dim Signature As String
varGotIt = vbNo
'GET OUTLOOK IF IT IS RUNNING
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'OUTLOOK WAS NOT RUNNING - START IT FROM CODE.
Set oApp = CreateObject("Outlook.Application")
Started = True
End If
On Error GoTo Err_SentMailStatus 'RESUME ERROR CHECKING
'********GET SPECIFIC SIGNATURE FILE FROM OUTLOOK**************************************
SigString = Environ("appdata") & _
"\Microsoft\Signatures\LighthouseTest.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
'**************************************************************************************
intItemHold = 0
For Each oAccount In oApp.Session.Accounts
intItemHold = intItemHold + 1
If oAccount.DisplayName = strDisplayName Then
varGotIt = vbYes
Set oItem = oApp.CreateItem(olMailItem)
With oItem
.TO = strMailTo
.CC = CCmail
.Subject = strSub
.SendUsingAccount = oApp.Session.Accounts.Item(intItemHold)
.SentOnBehalfOfName = strDisplayName
.BodyFormat = olFormatHTML
.htmlBody = Signature
.Display
End With
Set oItem = Nothing
If Started Then
oApp.Quit
End If
End If
Next
If varGotIt = vbNo Then
MsgBox "Email account '" & strDisplayName & "' can not be found. Please correct the email account name before continuing.", vbCritical, "Incorrect Email Account Name"
End If
SentMailStatus = True
Exit_SentMailStatus:
Exit Function
Err_SentMailStatus:
MsgBox ErrorMessage("modOutlookMailApp", "SentMailStatus") & Err.Number & Err.description, vbInformation, "System Code Error"
SentMailStatus = False
Resume Exit_SentMailStatus
End Function
Function GetBoiler(ByVal sFile As String) As String
On Error GoTo Err_GetBoiler
'Credit to Dick Kusleika for this code
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
Exit_GetBoiler:
Exit Function
Err_GetBoiler:
MsgBox ErrorMessage("modOutlookMailApp", "GetBoiler") & Err.Number & Err.description, vbInformation, "System Code Error"
Resume Exit_GetBoiler
End Function