Excel VB to send Email to multiple Recipeints

[farhad]

Good Day

I have this code that sends a email to recipients.

I have created a Sheet called Emails with a few a few email addresses.

The code works however it does not send to all email addresses, only the first address is selected.

Thanks

Private Sub Image12_Click()                          'Asset Purchase Form

 'With Sheets("Checklist")
 'Sheet2.Visible = -xlSheetVisible
  Sheet2.Unprotect password:="Secret"
If ListBox1.Text = "" Then
        MsgBox "Select a Record to Print...", vbCritical
            Exit Sub
                End If
Worksheets("Sheet2").Range("B11").Value = Me.TextBox25    'User
Worksheets("Sheet2").Range("E11").Value = Me.TextBox26    'Division
Worksheets("Sheet2").Range("B13").Value = Me.TextBox6     'Asset Barcode - ALB Tag
Worksheets("Sheet2").Range("B15").Value = Me.TextBox2     'Asset Description
Worksheets("Sheet2").Range("B18").Value = Me.TextBox1     'Asset Make
Worksheets("Sheet2").Range("E18").Value = Me.TextBox4     'Asset Model
Worksheets("Sheet2").Range("B20").Value = Me.TextBox5       'Asset Serial #
Worksheets("Sheet2").Range("G22").Value = Me.TextBox58      'Zone
Worksheets("Sheet2").Range("E22").Value = Me.TextBox26      'Location
Worksheets("Sheet2").Range("B22").Value = Me.TextBox19      'User
Worksheets("Sheet2").Range("B24").Value = Me.TextBox3      'Asset Type
Worksheets("Sheet2").Range("B26").Value = Me.TextBox13      'Supplier
Worksheets("Sheet2").Range("B28").Value = Me.TextBox8       'Order Note No
Worksheets("Sheet2").Range("B30").Value = Me.TextBox11      'Inv Date
Worksheets("Sheet2").Range("B32").Value = Me.TextBox12      'Inv Number
Worksheets("Sheet2").Range("B34").Value = Me.TextBox17      'Cost
Worksheets("Sheet2").Range("B36").Value = Me.TextBox27    'Date brought into use
'Worksheets("Sheet2").Range("H27").Value = Me.TextBox12
'Worksheets("Sheet2").Range("H29").Value = Me.TextBox11
'Worksheets("Sheet2").Range("H31").Value = Me.TextBox17
'Worksheets("Sheet2").Range("X21").Value = Me.TextBox14
    Call Main   'Progress Bar
  MsgBox "Please ensure Outlook Application is open ..... Generating / Emailing Asset Purchase Form...."
  
  
  Unload Me
    Application.ScreenUpdating = False 'Idon't think this is really necessaty
    
     Dim IsCreated As Boolean
     Dim i As Long
     Dim PdfFile As String, Title As String
     Dim OutlApp As Object
     
      ' Not sure for what the Title is
  Sheets("Sheet2").Select
  Title = Range("A7")
          
   'Generate PDF File
          Sheets("Sheet2").Select
    Range("A1").Select
     PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
    'Create path to save PDF files created
    
    PdfFile = "c:\temp\  " & "Supplier" & "_" & Range("B26").Value & " " & "Inv #" & "_" & Range("B32").Value & " " & "PO #" & "_" & Range("B28").Value & " " & "ALB TAG" & "_" & Range("B13").Value & ActiveSheet.Name & ".pdf"
       
        ' Export activesheet as PDF
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With
  
  ' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0
 
  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)
   
   
   
   
    ' Prepare e-mail
    .Subject = Title
    
   Dim SendTo As String
     Dim BuildAddy As Integer
    ' Sheets("Emails").Select
     
   'For BuildAddy = 1 To Range("A1048000").End(xlUp).Row ' ie the last value in the column
   
   For BuildAddy = 1 To Range("A1:A").End(xlUp).Row   ' ie the last value in the column
    SendTo = SendTo & Range("A1:A" & BuildAddy).Value & ";" ' at least I think it's a ;.  It might be a ,
    Next BuildAddy
.To = SendTo
    
      
     .To = Sheets("Emails").Range("A1:A").Value ' <-- Put email of the recipient here
    ' .CC = "[EMAIL="mfjanoo@ymail.com"]mfjanoo@ymail.com[/EMAIL]" ' <-- Put email of 'copy to' recipient here
         .Body = "Salaams," & vbLf & vbLf _
          & "Please find attached Asset Purchase Form ...the report is attached in PDF format." & vbLf & vbLf _
          & "Regards," & vbLf _
          & Application.UserName & vbLf & vbLf
    .Attachments.Add PdfFile
   
   
   
   
    ' Try to send
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail was not sent", vbExclamation
    Else
      MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0
   
  End With
 
  ' Delete PDF file
 ' Kill PdfFile
 
  ' Quit Outlook if it was created by this code
  If IsCreated Then OutlApp.Quit
 
  ' Release the memory of object variable
  Set OutlApp = Nothing
 
    Application.ScreenUpdating = False
          Worksheets("Sheet2").PrintPreview
    
    
    Sheet4.Protect password:="Secret"
    'Sheet2.Visible = -xlSheetHidden
    
 UserForm1.Show
'End With
End Sub

 

[Computerman]

Farhad,
Below is the codeI use to send emails to selected field techs (varies every time). The techemail addresses are in Sheet 3 column 13. The tech first and last name,separated by a space are in sheet 3 column 11.
[code|
For E = 2 To 500
IfSheet3.Cells(E, 1).Value = strDir Then
IfTechEmail = "" Then
TechEmail = Sheet3.Cells(E, 13).Value
Else
TechEmail = TechEmail & "; " & Sheet3.Cells(E,13).Value
End If


WholeName =Sheet3.Cells(E, 11).Value 'tech first and last names

LPosition =InStr(WholeName, " ")
LPosition =LPosition - 1
FirstName =Left(WholeName, LPosition)
IfFirstNames = "" Then
FirstNames = FirstName
strLeadTech = WholeName
Else
FirstNames = FirstNames & ", " & FirstName
End If
End If
Next E
[/code]
Then I use this line to add the tech email addresses to theemail

EMail_Send_to = TechEmail

And I use this line to begin the body of the email.

Email_Body = "<HTML>******><p><fontSize=4>" & FirstNames & ", " & "<br/>" & "  The attachedand following

Note that the spaces in the body section are deliberate andnecessary.
Computerman