Email from Excel

[samitnair]

Hello,

I reviewed suggestions provided in Ron de Bruin page. I need help in streamlining the below code. I need to Send email to a list of users. I did changes which I guess is not working.

• The code does not pull the signature even after me changing the sign file name
• I need the VBA to pull the company name and contact person from the excel sheet and insert in the email body (Highlighted in the code). Sample of the excel sheet is shown below

	A	B	C	D
1	Company Name	Client Name	Email	Yes/No
2	Software INC	George	xyz@gmail.com	Yes
3	Dell INC	Michael	abc@dell.com	No

<tbody>
</tbody>

[FONT=Verdana]Sub Test1()[/FONT]
[FONT=Verdana]   Dim OutApp As Object[/FONT]
[FONT=Verdana]   Dim OutMail As Object[/FONT]
[FONT=Verdana]   Dim cell As Range[/FONT]
[FONT=Verdana]   Dim strbody As String[/FONT]
[FONT=Verdana]   Dim Signature As String[/FONT]
[FONT=Verdana]  Application.ScreenUpdating = False[/FONT]
[FONT=Verdana]   Set OutApp = CreateObject("Outlook.Application")[/FONT]
[FONT=Verdana]   On Error GoTo cleanup[/FONT]
[FONT=Verdana]   For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)[/FONT]
[FONT=Verdana]       If cell.Value Like "?*@?*.?*" And _[/FONT]
[FONT=Verdana]          LCase(Cells(cell.Row, "D").Value) = "yes" Then[/FONT]
[FONT=Verdana]          Set OutMail = OutApp.CreateItem(0)[/FONT]
[FONT=Verdana]           On Error Resume Next[/FONT]
[FONT=Verdana]           With OutMail[/FONT]
[FONT=Verdana]               .To = cell.Value[/FONT]
[FONT=Verdana]               .Subject = "Meeting Invite to [[B]Company Name] [/B]" & cell.Offset(0, -1).Value 'Refer value from column A (company name)[/FONT]
[FONT=Verdana]               .HTMLBody = "<style> body{color:black;font-family:Calibri (Body);font-size: 12pt;} </style>" & _[/FONT]
[FONT=Verdana]                           "******>Hello [[B][COLOR=#ff0000]contact person[/COLOR][/B]],

 " & _[/FONT]
[FONT=Verdana]                           "I am the delivery manager associated to" [[COLOR=#ff0000][B]Company Name] [/B][/COLOR]and I would like to conduct a meeting with you and discuss the below points." & [/FONT]
[FONT=Verdana]       SigString = Environ("appdata") & _[/FONT]
[FONT=Verdana]               "\Microsoft\Signatures\Sign.txt"[/FONT]
[FONT=Verdana]       If Dir(SigString) <> "" Then[/FONT]
[FONT=Verdana]           Signature = GetBoiler(SigString)[/FONT]
[FONT=Verdana]       Else[/FONT]
[FONT=Verdana]       Signature = ""[/FONT]
[FONT=Verdana]       End If[/FONT]
[FONT=Verdana]               'You can add files also like this[/FONT]
[FONT=Verdana]               '.Attachments.Add ("C:\test.txt")[/FONT]
[FONT=Verdana]               .send[/FONT]
[FONT=Verdana]           End With[/FONT]
[FONT=Verdana]           On Error GoTo 0[/FONT]
[FONT=Verdana]           Set OutMail = Nothing[/FONT]
[FONT=Verdana]       End If[/FONT]
[FONT=Verdana]   Next cell[/FONT]
[FONT=Verdana]
[/FONT]
[FONT=Verdana]cleanup:[/FONT]
[FONT=Verdana]   Set OutApp = Nothing[/FONT]
[FONT=Verdana]   Application.ScreenUpdating = True[/FONT]
[FONT=Verdana]End Sub[/FONT]
[FONT=Verdana]Function GetBoiler(ByVal sFile As String) As String[/FONT]
[FONT=Verdana]'**** Kusleika[/FONT]
[FONT=Verdana]   Dim fso As Object[/FONT]
[FONT=Verdana]   Dim ts As Object[/FONT]
[FONT=Verdana]   Set fso = CreateObject("Scripting.FileSystemObject")[/FONT]
[FONT=Verdana]   Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)[/FONT]
[FONT=Verdana]   GetBoiler = ts.readall[/FONT]
[FONT=Verdana]   ts.Close[/FONT]
[FONT=Verdana]End Function[/FONT]

I would appreciate your help and thank you in advance .

Regards
Samit Nair

 

[Logit]

.

Option Explicit


Sub PC_Email()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody, SigString, Signature As String
    Dim MailAttachments As String
    Dim cell As Variant '                             Not previously DIM'd
    Dim GetBoiler As Object
    
    Sheets("Sheet1").Select '                         Edit as required
    Range("A1").Select
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    
  
   'On Error GoTo cleanup
    For Each cell In Columns("C").Cells
        If cell.Value Like "?*@?*.?*" And _
            LCase(Cells(cell.Row, "D").Value) = "yes" Then
              
            With Application.ActiveSheet
                MailAttachments = Cells(cell.Row, "E").Value
            End With
            
        
            Set OutMail = OutApp.CreateItem(0)
            
                On Error Resume Next
                                  
                With OutMail
                
                    .To = cell.Value
                    .Subject = "Meeting Invite to " & Cells(cell.Row, "A").Value  'Refer value from column A (company name)
                    .HTMLBody = "" & _
                               "******> Hello ," & Cells(cell.Row, "B") & ", " & _
                               "I am the delivery manager associated to " & Cells(cell.Row, "A") & " and I would like to conduct a meeting with you and discuss the below points."
                    '.Attachments.Add MailAttachments
                    .Display
                    'Or use .Send
                    
                End With
                         SigString = Environ("appdata") & " Microsoft\Signatures\Sign.txt"
                    If Dir(SigString) <> "" Then
                        Signature = GetBoiler(SigString)
                    Else
                        Signature = ""
                    End If
                    
                
                On Error GoTo 0
        End If
    Next




cleanup:
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
End Sub

I'm not certain about the Signature lines of code ....

 

[samitnair]

Hello Logit,

Thank you for the update and I really appreciate your time but a signature feature is a mandate and would be a added value to the script and let me know if you have any suggestions

Regards

 

[Logit]

.
Rather than use another file to create your email signature, you could just include it within the body of the email several rows lower than the body text. Try this :

Option Explicit


Sub PC_Email()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody, SigString, Signature As String
    Dim MailAttachments As String
    Dim cell As Variant '                             Not previously DIM'd
    Dim GetBoiler As Object
    
    Sheets("Sheet1").Select '                         Edit as required
    Range("A1").Select
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
 
   'On Error GoTo cleanup
    For Each cell In Columns("C").Cells
        If cell.Value Like "?*@?*.?*" And _
            LCase(Cells(cell.Row, "D").Value) = "yes" Then
              
            With Application.ActiveSheet
                MailAttachments = Cells(cell.Row, "E").Value
            End With
            
        
            Set OutMail = OutApp.CreateItem(0)
            
                On Error Resume Next
                                  
                With OutMail
                
                    .To = cell.Value
                    .Subject = "Meeting Invite to " & Cells(cell.Row, "A").Value  'Refer value from column A (company name)
                    .HTMLBody = "" & _
                                "Hello ," & Cells(cell.Row, "B") & ", " & "

" & _
                                "I am the delivery manager associated to " & Cells(cell.Row, "A") & " and I would like to conduct a meeting with you and discuss the below points." & "

" & _
                                "

" & _
                                "

" & _
                                "

" & _
                                "**************************************************************************************************************" & "

" & _
                                "This is your signature file. It will always be 7 rows below whatever text you add in the macro code."
                                'To add another line in your message or signature without skipping a row, end the line of text with
                                'a  quotation symbol and then an ampersand and an underscore. Ex:   end of text." & _
                    '.Attachments.Add MailAttachments
                    .Display
                    'Or use .Send
                    
                End With
                
                On Error GoTo 0
        End If
    Next

cleanup:
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
End Sub

 

[samitnair]

Hello Logit,

I am figuring out a solution for the signature to call an email before so that the default signature is loaded or add a picture (signature) at the bottom. I also wanted to go one step further and understand

1. how can we utilize the .senton syntax and capture at what time was the email sent like a logging feature
2. Can we tag the email so that next time when I run the code it replies to same conversation
3. Can we save a copy of the sent emails in a particular folder.