Solved

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

Posted on 2011-02-24
8
419 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
Comment Utility
How are you connecting to outlook?

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
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
Comment Utility
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
 
LVL 59

Expert Comment

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

Chris
0
Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

 

Author Comment

by:kosenrufu
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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

Complete VMware vSphere® ESX(i) & Hyper-V Backup

Capture your entire system, including the host, with patented disk imaging integrated with VMware VADP / Microsoft VSS and RCT. RTOs is as low as 15 seconds with Acronis Active Restore™. You can enjoy unlimited P2V/V2V migrations from any source (even from a different hypervisor)

Join & Write a Comment

This article is a continuation or rather an extension from Cascading Combos (http://www.experts-exchange.com/A_5949.html) and builds on examples developed in detail there. It should be understandable alone, but I recommend reading the previous artic…
Introduction The Visual Basic for Applications (VBA) language is at the heart of every application that you write. It is your key to taking Access beyond the world of wizards into a world where anything is possible. This article introduces you to…
Learn how to number pages in an Access report over each group. Activate two pass printing by referencing the pages property: Add code to the Page Footers OnFormat event to capture the pages as there occur for each group. Use the pages property to …
Basics of query design. Shows you how to construct a simple query by adding tables, perform joins, defining output columns, perform sorting, and apply criteria.

728 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

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now