Solved

What is the Access VBA to copy .gif file and paste image to body of an email.

Posted on 2011-02-24
8
447 Views
Last Modified: 2013-11-27
I have a .gif file in a folder on the C: drive I want to copy and paste the image to the body of an email.

How can  this be done using VBA from Access?

Thanks

Rick
0
Comment
Question by:kosenrufu
  • 5
  • 3
8 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34969802
How are you connecting to outlook?

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34970012
Whilst you think ... one method is simply to set the image in the html body of the email ... assuming you have a reference to outlook as olkApp and are referring to teh current mail open in outlook then:

olkapp.ActiveInspector.CurrentItem.htmlbody = "<body><img src='C:\Users\<username>\Pictures\image0001.bmp'></body>"

Similarly if you have created / connected to a specific mailitem then assuming it is named mai  then:

mai.htmlbody = "<body><img src='C:\Users\<username>\Pictures\image0001.bmp'></body>"

There are various alternative methods depending on your starting condition so when you respond this may need to change.

Chris

Chris
0
 

Author Comment

by:kosenrufu
ID: 34970357
I have this but not working
Public Sub Email_Scorecard_by_Region(Region)

'On Error Resume Next

Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Dim rsf As DAO.Recordset
Dim strSQL As String

Dim strTo As String
Dim strText As String
Dim strSubject As String

Dim arrSCVersion(2) As Variant

arrSCVersion(0) = "Scorecard_EN"
arrSCVersion(1) = "Scorecard_FR"


Dim PathIs As String

'**Detect path
PathIs = Application.CurrentProject.Path

Set db = CurrentDb()

CurrentDay = WeekdayName(Weekday(Date), 1)

strSQL = "SELECT Scorecard_Emailing_Notes.Notes"
strSQL = strSQL & " FROM Scorecard_Emailing_Notes;"
Set rs = db.OpenRecordset(strSQL)

If Not rs.EOF Then
    strEmailNote = rs!Notes
End If

'**Query if today is emailing day for reporting region
strSQL = "SELECT Scorecard_Emailing_Day.EmailingRegion, Scorecard_Emailing_Day.EmailingDay"
strSQL = strSQL & " FROM Scorecard_Emailing_Day"
strSQL = strSQL & " WHERE (((Scorecard_Emailing_Day.EmailingRegion)='" & Region & "') AND ((Scorecard_Emailing_Day.EmailingDay)='" & CurrentDay & "'));"
Set rs = db.OpenRecordset(strSQL)

If Not rs.EOF Then
    LastWeekEndingDt = Replace(LastWkEndngDt(Date), "/", "-")
    
    '**Query week ending date
    strSQL = "SELECT NG_DATE.NG_WK_OF_YR_NUM, NG_PERD_OF_YR_NUM, NG_DATE.NG_YR_NUM"
    strSQL = strSQL & " FROM NG_DATE"
    strSQL = strSQL & " WHERE (((NG_DATE.WK_END_DT)=#" & LastWeekEndingDt & "#));"
    Set rs = db.OpenRecordset(strSQL)
    
    If Not rs.EOF Then
        WeekNo = rs!NG_WK_OF_YR_NUM
        ExecSumPeriodNo = rs!NG_PERD_OF_YR_NUM
        YearNo = rs!NG_YR_NUM
    End If
    
    If WeekNo < 10 Then
        strWeekNo = "0" & WeekNo
    Else
        strWeekNo = WeekNo
    End If
    
    If ExecSumPeriodNo < 10 Then
        ExecSumPeriodNo = "0" & ExecSumPeriodNo
    Else
        ExecSumPeriodNo = ExecSumPeriodNo
    End If
    
    
    '**Query email signature
    strSQL = "SELECT Controls.AdminContactInfo"
    strSQL = strSQL & " FROM Controls;"
    Set rs = db.OpenRecordset(strSQL)
    
    If Not rs.EOF Then
        EmailSignature = rs!AdminContactInfo
    End If
    
    '**Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
        
    '**Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    
    With objOutlookMsg
        '---------------------------------Start of code to attach Scorecard----------------------------------------
        strFolderName = "FE_Easy_Store_Performance_Scorecard_WK_" & strWeekNo & "_" & LastWeekEndingDt
        
        For i = 0 To UBound(arrSCVersion) - 1
            If arrSCVersion(i) = "Scorecard_FR" Then
                '**Translate to french
                strSQL = "SELECT English_Translation.French"
                strSQL = strSQL & " From English_Translation"
                strSQL = strSQL & " WHERE (((English_Translation.English)='" & Region & "'));"
                Set rsf = db.OpenRecordset(strSQL)
                
                If Not rsf.EOF Then
                    strRegion = rsf!French
                End If
            Else
                strRegion = Region
            End If
        
            strFileName1 = "FE_Easy_Store_Performance_Scorecard_WK_" & strWeekNo & "_" & LastWeekEndingDt & "_" & strRegion & ".pdf"

            AttachmentPath = PathIs & "\Reports\Scorecard\" & YearNo & "\" & strFolderName & "\" & strFileName1
               
            If Not IsMissing(AttachmentPath) Then
                Set objOutlookAttach = .Attachments.Add(AttachmentPath)
            End If

            '---------------------------------End of code to attach Scorecard----------------------------------------
            
            
            '---------------------------------Start of code to attach Executive Summary----------------------------------------
            If arrSCVersion(i) = "Scorecard_FR" Then
                strFileName2 = "FE_Easy_Store_Performance_Executive_Summary_FR_P" & ExecSumPeriodNo & "-" & YearNo & ".pdf"
            Else
                strFileName2 = "FE_Easy_Store_Performance_Executive_Summary_EN_P" & ExecSumPeriodNo & "-" & YearNo & ".pdf"
            End If
            
            AttachmentPath = PathIs & "\Reports\Executive_Summary\" & YearNo & "\" & strFileName2
            
            Debug.Print AttachmentPath
            
            If Not IsMissing(AttachmentPath) Then
                Debug.Print AttachmentPath
                'C:\Scorecard_Creator_Front_End\Reports\Executive_Summary\2011
                Set objOutlookAttach = .Attachments.Add(AttachmentPath)
            End If
            '---------------------------------End of code to attach Executive Summary----------------------------------------
        
        
            strFile = PathIs & "\Images\How to read the FE Easy Stores Performance Scorecard.gif"
            Set objInsp = objOutlookMsg.GetInspector
            Set objDoc = objInsp.WordEditor
            Set objSel = objDoc.Windows(1).Selection
            If objMsg.BodyFormat <> olFormatPlain Then
                Set objShape = objSel.InlineShapes.AddPicture _
                (strFile, False, True)
                objDoc.Hyperlinks.Add objShape.Range, strURL
            End If
                
        Next i
        
        strSubject = "Front End Easy Store Scorecard for WK_" & WeekNo & "-" & YearNo & "_" & strRegion
        
        '**MsgBox (strSubject)
        .Subject = strSubject
    
        strText = "<TABLE border='0' width='100%'>"
        strText = strText & "<tr><td>This is an auto-generated email.</td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td><font color ='red'>" & strEmailNote & "</font><td></td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>The FE Scorecard will be emailed on Monday and Tuesday every week considering the data updating by the West occuring on Tuesday.<td></td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>The following files are attached:<td></td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>" & strFileName1 & "<td></td></tr>"
        strText = strText & "<tr><td>" & strFileName2 & "<td></td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>Please let me know if you have any questions.</td></tr>"
        strText = strText & "<tr><td>Thank you</td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>" & EmailSignature & "</td></tr>"
        strText = strText & "</TABLE>"

        '**HTML TEXT
        .HTMLBody = strText & vbCrLf
                
        .Importance = olImportanceHigh  'High importance
            
        '**Send to "To"
        strSQL = "SELECT Scorecard_Emailing_List.EmailAddress"
        strSQL = strSQL & " FROM Scorecard_Emailing_List"
        strSQL = strSQL & " WHERE (((Scorecard_Emailing_List.Region)='" & Region & "') AND ((Scorecard_Emailing_List.Activate)=-1));"
        Set rs = db.OpenRecordset(strSQL)
        
        If Not rs.EOF Then
            While Not rs.EOF
                strTo = rs!EmailAddress
                             
                '**Add the To recipient(s) to the message.
                Set objOutlookRecip = .Recipients.Add(strTo)
                objOutlookRecip.Type = olTo
                    
                rs.MoveNext
            Wend
            
            '**Resolve each Recipient's name.
            For Each objOutlookRecip In .Recipients
                objOutlookRecip.Resolve
            Next
            
            .Send
        Else
        End If
    End With
    
    Set objOutlook = Nothing

End If

End Sub

Open in new window

0
Enterprise Mobility and BYOD For Dummies

Like “For Dummies” books, you can read this in whatever order you choose and learn about mobility and BYOD; and how to put a competitive mobile infrastructure in place. Developed for SMBs and large enterprises alike, you will find helpful use cases, planning, and implementation.

 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34971259
Wherabouts in teh body text do you want the picture ... and what is it's path?

Chris
0
 

Author Comment

by:kosenrufu
ID: 34971674
I want to paste it after the lines "The following files are attached:"

The path of the pic is from C:\Scorecard_Creator_Front_End\Images

Thanks
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34971800
You still need to indicte the filename ... replace in the code:

filename.bmp
with the correct filename and extension

Chris
Public Sub Email_Scorecard_by_Region(Region)

'On Error Resume Next

Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Dim rsf As DAO.Recordset
Dim strSQL As String

Dim strTo As String
Dim strText As String
Dim strSubject As String

Dim arrSCVersion(2) As Variant

arrSCVersion(0) = "Scorecard_EN"
arrSCVersion(1) = "Scorecard_FR"


Dim PathIs As String

'**Detect path
PathIs = Application.CurrentProject.Path

Set db = CurrentDb()

CurrentDay = WeekdayName(Weekday(Date), 1)

strSQL = "SELECT Scorecard_Emailing_Notes.Notes"
strSQL = strSQL & " FROM Scorecard_Emailing_Notes;"
Set rs = db.OpenRecordset(strSQL)

If Not rs.EOF Then
    strEmailNote = rs!Notes
End If

'**Query if today is emailing day for reporting region
strSQL = "SELECT Scorecard_Emailing_Day.EmailingRegion, Scorecard_Emailing_Day.EmailingDay"
strSQL = strSQL & " FROM Scorecard_Emailing_Day"
strSQL = strSQL & " WHERE (((Scorecard_Emailing_Day.EmailingRegion)='" & Region & "') AND ((Scorecard_Emailing_Day.EmailingDay)='" & CurrentDay & "'));"
Set rs = db.OpenRecordset(strSQL)

If Not rs.EOF Then
    LastWeekEndingDt = Replace(LastWkEndngDt(Date), "/", "-")
    
    '**Query week ending date
    strSQL = "SELECT NG_DATE.NG_WK_OF_YR_NUM, NG_PERD_OF_YR_NUM, NG_DATE.NG_YR_NUM"
    strSQL = strSQL & " FROM NG_DATE"
    strSQL = strSQL & " WHERE (((NG_DATE.WK_END_DT)=#" & LastWeekEndingDt & "#));"
    Set rs = db.OpenRecordset(strSQL)
    
    If Not rs.EOF Then
        WeekNo = rs!NG_WK_OF_YR_NUM
        ExecSumPeriodNo = rs!NG_PERD_OF_YR_NUM
        YearNo = rs!NG_YR_NUM
    End If
    
    If WeekNo < 10 Then
        strWeekNo = "0" & WeekNo
    Else
        strWeekNo = WeekNo
    End If
    
    If ExecSumPeriodNo < 10 Then
        ExecSumPeriodNo = "0" & ExecSumPeriodNo
    Else
        ExecSumPeriodNo = ExecSumPeriodNo
    End If
    
    
    '**Query email signature
    strSQL = "SELECT Controls.AdminContactInfo"
    strSQL = strSQL & " FROM Controls;"
    Set rs = db.OpenRecordset(strSQL)
    
    If Not rs.EOF Then
        EmailSignature = rs!AdminContactInfo
    End If
    
    '**Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
        
    '**Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    
    With objOutlookMsg
        '---------------------------------Start of code to attach Scorecard----------------------------------------
        strFolderName = "FE_Easy_Store_Performance_Scorecard_WK_" & strWeekNo & "_" & LastWeekEndingDt
        
        For i = 0 To UBound(arrSCVersion) - 1
            If arrSCVersion(i) = "Scorecard_FR" Then
                '**Translate to french
                strSQL = "SELECT English_Translation.French"
                strSQL = strSQL & " From English_Translation"
                strSQL = strSQL & " WHERE (((English_Translation.English)='" & Region & "'));"
                Set rsf = db.OpenRecordset(strSQL)
                
                If Not rsf.EOF Then
                    strRegion = rsf!French
                End If
            Else
                strRegion = Region
            End If
        
            strFileName1 = "FE_Easy_Store_Performance_Scorecard_WK_" & strWeekNo & "_" & LastWeekEndingDt & "_" & strRegion & ".pdf"

            AttachmentPath = PathIs & "\Reports\Scorecard\" & YearNo & "\" & strFolderName & "\" & strFileName1
               
            If Not IsMissing(AttachmentPath) Then
                Set objOutlookAttach = .Attachments.Add(AttachmentPath)
            End If

            '---------------------------------End of code to attach Scorecard----------------------------------------
            
            
            '---------------------------------Start of code to attach Executive Summary----------------------------------------
            If arrSCVersion(i) = "Scorecard_FR" Then
                strFileName2 = "FE_Easy_Store_Performance_Executive_Summary_FR_P" & ExecSumPeriodNo & "-" & YearNo & ".pdf"
            Else
                strFileName2 = "FE_Easy_Store_Performance_Executive_Summary_EN_P" & ExecSumPeriodNo & "-" & YearNo & ".pdf"
            End If
            
            AttachmentPath = PathIs & "\Reports\Executive_Summary\" & YearNo & "\" & strFileName2
            
            Debug.Print AttachmentPath
            
            If Not IsMissing(AttachmentPath) Then
                Debug.Print AttachmentPath
                'C:\Scorecard_Creator_Front_End\Reports\Executive_Summary\2011
                Set objOutlookAttach = .Attachments.Add(AttachmentPath)
            End If
            '---------------------------------End of code to attach Executive Summary----------------------------------------
        
        
            strFile = PathIs & "\Images\How to read the FE Easy Stores Performance Scorecard.gif"
            Set objInsp = objOutlookMsg.GetInspector
            Set objDoc = objInsp.WordEditor
            Set objSel = objDoc.Windows(1).Selection
            If objMsg.BodyFormat <> olFormatPlain Then
                Set objShape = objSel.InlineShapes.AddPicture _
                (strFile, False, True)
                objDoc.Hyperlinks.Add objShape.Range, strURL
            End If
                
        Next i
        
        strSubject = "Front End Easy Store Scorecard for WK_" & WeekNo & "-" & YearNo & "_" & strRegion
        
        '**MsgBox (strSubject)
        .Subject = strSubject
    
        strText = "<TABLE border='0' width='100%'>"
        strText = strText & "<tr><td>This is an auto-generated email.</td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td><font color ='red'>" & strEmailNote & "</font><td></td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>The FE Scorecard will be emailed on Monday and Tuesday every week considering the data updating by the West occuring on Tuesday.<td></td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>The following files are attached:<td></td></tr>"
        strtext = strtext & "<tr><td><img src='C:\Scorecard_Creator_Front_End\Images\filename.bmp'></td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>" & strFileName1 & "<td></td></tr>"
        strText = strText & "<tr><td>" & strFileName2 & "<td></td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>Please let me know if you have any questions.</td></tr>"
        strText = strText & "<tr><td>Thank you</td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>" & EmailSignature & "</td></tr>"
        strText = strText & "</TABLE>"

        '**HTML TEXT
        .HTMLBody = strText & vbCrLf
                
        .Importance = olImportanceHigh  'High importance
            
        '**Send to "To"
        strSQL = "SELECT Scorecard_Emailing_List.EmailAddress"
        strSQL = strSQL & " FROM Scorecard_Emailing_List"
        strSQL = strSQL & " WHERE (((Scorecard_Emailing_List.Region)='" & Region & "') AND ((Scorecard_Emailing_List.Activate)=-1));"
        Set rs = db.OpenRecordset(strSQL)
        
        If Not rs.EOF Then
            While Not rs.EOF
                strTo = rs!EmailAddress
                             
                '**Add the To recipient(s) to the message.
                Set objOutlookRecip = .Recipients.Add(strTo)
                objOutlookRecip.Type = olTo
                    
                rs.MoveNext
            Wend
            
            '**Resolve each Recipient's name.
            For Each objOutlookRecip In .Recipients
                objOutlookRecip.Resolve
            Next
            
            .Send
        Else
        End If
    End With
    
    Set objOutlook = Nothing

End If

End Sub

Open in new window

0
 

Author Comment

by:kosenrufu
ID: 34983666
It's working now but I want to have the image to come after the html table.

Thanks
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
ID: 34985960
How about?

Chris
Public Sub Email_Scorecard_by_Region(Region)

'On Error Resume Next

Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Dim rsf As DAO.Recordset
Dim strSQL As String

Dim strTo As String
Dim strText As String
Dim strSubject As String

Dim arrSCVersion(2) As Variant

arrSCVersion(0) = "Scorecard_EN"
arrSCVersion(1) = "Scorecard_FR"


Dim PathIs As String

'**Detect path
PathIs = Application.CurrentProject.Path

Set db = CurrentDb()

CurrentDay = WeekdayName(Weekday(Date), 1)

strSQL = "SELECT Scorecard_Emailing_Notes.Notes"
strSQL = strSQL & " FROM Scorecard_Emailing_Notes;"
Set rs = db.OpenRecordset(strSQL)

If Not rs.EOF Then
    strEmailNote = rs!Notes
End If

'**Query if today is emailing day for reporting region
strSQL = "SELECT Scorecard_Emailing_Day.EmailingRegion, Scorecard_Emailing_Day.EmailingDay"
strSQL = strSQL & " FROM Scorecard_Emailing_Day"
strSQL = strSQL & " WHERE (((Scorecard_Emailing_Day.EmailingRegion)='" & Region & "') AND ((Scorecard_Emailing_Day.EmailingDay)='" & CurrentDay & "'));"
Set rs = db.OpenRecordset(strSQL)

If Not rs.EOF Then
    LastWeekEndingDt = Replace(LastWkEndngDt(Date), "/", "-")
    
    '**Query week ending date
    strSQL = "SELECT NG_DATE.NG_WK_OF_YR_NUM, NG_PERD_OF_YR_NUM, NG_DATE.NG_YR_NUM"
    strSQL = strSQL & " FROM NG_DATE"
    strSQL = strSQL & " WHERE (((NG_DATE.WK_END_DT)=#" & LastWeekEndingDt & "#));"
    Set rs = db.OpenRecordset(strSQL)
    
    If Not rs.EOF Then
        WeekNo = rs!NG_WK_OF_YR_NUM
        ExecSumPeriodNo = rs!NG_PERD_OF_YR_NUM
        YearNo = rs!NG_YR_NUM
    End If
    
    If WeekNo < 10 Then
        strWeekNo = "0" & WeekNo
    Else
        strWeekNo = WeekNo
    End If
    
    If ExecSumPeriodNo < 10 Then
        ExecSumPeriodNo = "0" & ExecSumPeriodNo
    Else
        ExecSumPeriodNo = ExecSumPeriodNo
    End If
    
    
    '**Query email signature
    strSQL = "SELECT Controls.AdminContactInfo"
    strSQL = strSQL & " FROM Controls;"
    Set rs = db.OpenRecordset(strSQL)
    
    If Not rs.EOF Then
        EmailSignature = rs!AdminContactInfo
    End If
    
    '**Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
        
    '**Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    
    With objOutlookMsg
        '---------------------------------Start of code to attach Scorecard----------------------------------------
        strFolderName = "FE_Easy_Store_Performance_Scorecard_WK_" & strWeekNo & "_" & LastWeekEndingDt
        
        For i = 0 To UBound(arrSCVersion) - 1
            If arrSCVersion(i) = "Scorecard_FR" Then
                '**Translate to french
                strSQL = "SELECT English_Translation.French"
                strSQL = strSQL & " From English_Translation"
                strSQL = strSQL & " WHERE (((English_Translation.English)='" & Region & "'));"
                Set rsf = db.OpenRecordset(strSQL)
                
                If Not rsf.EOF Then
                    strRegion = rsf!French
                End If
            Else
                strRegion = Region
            End If
        
            strFileName1 = "FE_Easy_Store_Performance_Scorecard_WK_" & strWeekNo & "_" & LastWeekEndingDt & "_" & strRegion & ".pdf"

            AttachmentPath = PathIs & "\Reports\Scorecard\" & YearNo & "\" & strFolderName & "\" & strFileName1
               
            If Not IsMissing(AttachmentPath) Then
                Set objOutlookAttach = .Attachments.Add(AttachmentPath)
            End If

            '---------------------------------End of code to attach Scorecard----------------------------------------
            
            
            '---------------------------------Start of code to attach Executive Summary----------------------------------------
            If arrSCVersion(i) = "Scorecard_FR" Then
                strFileName2 = "FE_Easy_Store_Performance_Executive_Summary_FR_P" & ExecSumPeriodNo & "-" & YearNo & ".pdf"
            Else
                strFileName2 = "FE_Easy_Store_Performance_Executive_Summary_EN_P" & ExecSumPeriodNo & "-" & YearNo & ".pdf"
            End If
            
            AttachmentPath = PathIs & "\Reports\Executive_Summary\" & YearNo & "\" & strFileName2
            
            Debug.Print AttachmentPath
            
            If Not IsMissing(AttachmentPath) Then
                Debug.Print AttachmentPath
                'C:\Scorecard_Creator_Front_End\Reports\Executive_Summary\2011
                Set objOutlookAttach = .Attachments.Add(AttachmentPath)
            End If
            '---------------------------------End of code to attach Executive Summary----------------------------------------
        
        
            strFile = PathIs & "\Images\How to read the FE Easy Stores Performance Scorecard.gif"
            Set objInsp = objOutlookMsg.GetInspector
            Set objDoc = objInsp.WordEditor
            Set objSel = objDoc.Windows(1).Selection
            If objMsg.BodyFormat <> olFormatPlain Then
                Set objShape = objSel.InlineShapes.AddPicture _
                (strFile, False, True)
                objDoc.Hyperlinks.Add objShape.Range, strURL
            End If
                
        Next i
        
        strSubject = "Front End Easy Store Scorecard for WK_" & WeekNo & "-" & YearNo & "_" & strRegion
        
        '**MsgBox (strSubject)
        .Subject = strSubject
    
        strText = "<TABLE border='0' width='100%'>"
        strText = strText & "<tr><td>This is an auto-generated email.</td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td><font color ='red'>" & strEmailNote & "</font><td></td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>The FE Scorecard will be emailed on Monday and Tuesday every week considering the data updating by the West occuring on Tuesday.<td></td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>The following files are attached:<td></td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>" & strFileName1 & "<td></td></tr>"
        strText = strText & "<tr><td>" & strFileName2 & "<td></td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>Please let me know if you have any questions.</td></tr>"
        strText = strText & "<tr><td>Thank you</td></tr>"
        strText = strText & "<tr><td>&nbsp<td></td></tr>"
        strText = strText & "<tr><td>" & EmailSignature & "</td></tr>"
        strText = strText & "</TABLE>"
        strText = strText & "<br><img src='C:\Scorecard_Creator_Front_End\Images\filename.bmp'>"
        '**HTML TEXT
        .HTMLBody = strText & vbcrlf

                
        .Importance = olImportanceHigh  'High importance
            
        '**Send to "To"
        strSQL = "SELECT Scorecard_Emailing_List.EmailAddress"
        strSQL = strSQL & " FROM Scorecard_Emailing_List"
        strSQL = strSQL & " WHERE (((Scorecard_Emailing_List.Region)='" & Region & "') AND ((Scorecard_Emailing_List.Activate)=-1));"
        Set rs = db.OpenRecordset(strSQL)
        
        If Not rs.EOF Then
            While Not rs.EOF
                strTo = rs!EmailAddress
                             
                '**Add the To recipient(s) to the message.
                Set objOutlookRecip = .Recipients.Add(strTo)
                objOutlookRecip.Type = olTo
                    
                rs.MoveNext
            Wend
            
            '**Resolve each Recipient's name.
            For Each objOutlookRecip In .Recipients
                objOutlookRecip.Resolve
            Next
            
            .Send
        Else
        End If
    End With
    
    Set objOutlook = Nothing

End If

End Sub

Open in new window

0

Featured Post

Simplifying Server Workload Migrations

This use case outlines the migration challenges that organizations face and how the Acronis AnyData Engine supports physical-to-physical (P2P), physical-to-virtual (P2V), virtual to physical (V2P), and cross-virtual (V2V) migration scenarios to address these challenges.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Regardless of which version on MS Access you are using, one of the harder data-entry forms to create is one where most data from previous entries needs to be appended to new records, especially when there are numerous fields and records involved.  W…
Experts-Exchange is a great place to come for help with solutions for your database issues, and many problems are resolved within minutes of being posted.  Others take a little more time and effort and often providing a sample database is very helpf…
In Microsoft Access, learn how to “cascade” or have the displayed data of one combo control depend upon what’s entered in another. Base the dependent combo on a query for its row source: Add a reference to the first combo on the form as criteria i…
With Microsoft Access, learn how to specify relationships between tables and set various options on the relationship. Add the tables: Create the relationship: Decide if you’re going to set referential integrity: Decide if you want cascade upda…

828 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question