multi attachements

[Trevor3007]

hi

is there some code that will all to attach multi attachments in one go (normally would select items & copy ) for outlook.

At the moment the VB I have/use only allows 1 at a time to be attached!

MTIA & KR
Trevor3007

 

[Roderick_E]

Comma separate the pathway to each attachment then loop through the cell as an array and attach each?

sub doemail
Call SendMessage(ToRecipients, CCRecipients, BCCRecipients, stSubject, vaMsg, imAttachment, senderstr)
endif

Sub SendMessage(myRecipient As String, mycc As String, mybcc As String, mySubject As String, Optional myBody As String, Optional myFileName As String, Optional mySender As String)


On Error Resume Next


Dim myObject As Object
Dim myItem As Object
Dim strarray As String
Dim strunbound() As String
Dim Z As Long


Set myObject = CreateObject("Outlook.Application")
Set myItem = myObject.CreateItem(0)


With myItem
.Subject = mySubject
.To = myRecipient
.cc = mycc
.bcc = mybcc
If Trim(mySender) <> "" Then
.SentOnBehalfOfName = mySender
End If
If xlst.cbOptionButton1A.Value = True Or xlst.cbframe1.Caption = "Data Divider" Then
.display
End If
If Trim(myBody) <> "" Then
'.Body = myBody


'sPath = Dir(Environ("appdata") & "\Microsoft\Signatures\*.htm", vbNormal)
        'sPath = Environ("appdata") & "\Microsoft\Signatures\" & sPath
        'sSignat = GetSignature(sPath)
        'MsgBox sSignat
      '.HTMLBody = strbody & String(4, vbCrLf) & sSignat




.HTMLBody = myBody & "<br>" & .HTMLBody
End If


'attach one file
If Trim(myFileName) <> "" Then
If InStr(myFileName, ",") = 0 Then
If Dir(myFileName) <> "" Then
.Attachments.Add (myFileName)
End If
Else 'multiple files
strarray = myFileName
 strunbound = Split(myFileName, ",")
 For Z = LBound(strunbound) To UBound(strunbound)
 .Attachments.Add (strunbound(Z))
Next Z
End If
End If




.Send
End With


Set myItem = Nothing
Set myObject = Nothing
End Sub

 

[Trevor3007]

Good morning Roderick_E

Thank you for your help.

This is the code I currently use:-

Option Explicit
 
Sub PC_Email()
   
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim MailAttachments As String
    Dim cell As Variant '                             Not previously DIM'd
   
    Sheets("Sheet1").Select '                         Edit as required
    Range("A1").Select
   
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
   
 
   On Error GoTo cleanup
    If WorksheetFunction.CountA(Range("K2:K100")) = 0 Then
        MsgBox "To send email, please enter an X in Column K.", vbCritical, "Missing Entry"
        Exit Sub
    End If
    For Each cell In Columns("C").Cells
        If cell.Value Like "?*@?*.?*" And _
        LCase(Cells(cell.Row, "K").Value) <> "" Then
   
    Set OutMail = OutApp.CreateItem(0)
       
            On Error Resume Next
                             
            With OutMail
           
              strbody = "Please Delete Any Previous Emails Related To This Period" & vbNewLine & vbNewLine & _
                         "Good Morning, " & vbNewLine & vbNewLine & _
                        "Please find attached applicable for WC: " & Cells(cell.Row, "A") & vbNewLine & vbNewLine & _
                        " " & Cells(cell.Row, "F") & " " & Cells(cell.Row, "G") & vbNewLine & vbNewLine & _
                        "KR" & vbNewLine & vbNewLine & _
                        "Trevor M" & vbNewLine & vbNewLine & _
                        "Ext" & vbNewLine & vbNewLine & _
                        "2663"
             
                .To = Cells(cell.Row, "C").Value
                .cc = Cells(cell.Row, "D").Value
                .bcc = Cells(cell.Row, "E").Value
                .Subject = "Trevor McLaughlin - Timesheet & Expenses Claim For WC " & Cells(cell.Row, "A").Value
                .Body = strbody
              
                '.Attachments.Add Application.ActiveWorkbook.FullName
                .Attachments.Add ActiveSheet.Cells(cell.Row, "H").Value
                .Attachments.Add ActiveSheet.Cells(cell.Row, "I").Value
                .Attachments.Add ActiveSheet.Cells(cell.Row, "J").Value
               
                .display  'Or use .Send
                 
               
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell
 
 
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
   
End Sub
 
Sub ClrMailToSend()
    Sheets("Sheet1").Range("K2:K100").Value = ""
End Sub
 
Sub GetFilePath()
Dim dialogBox As FileDialog
Set dialogBox = Application.FileDialog(msoFileDialogOpen)
 
 
'Set the display properties - these are optional
'All the settings must be applied before the .Show command
 
 
'Do not allow multiple files to be selected
dialogBox.AllowMultiSelect = False
 
 
'Set the title of of the DialogBox
dialogBox.Title = "Select a file"
 
 
'Set the initial path to :
 dialogBox.InitialFileName = "C:\data"
 
 
'Show the dialog box and output full file path and file name
If dialogBox.Show = -1 Then
   ActiveCell.Value = dialogBox.SelectedItems(1)
End If
End Sub

How do I incorporate your code to work with the above ?

MTIA & hope your day goes well.
KR
Trevor3007

 

[Roderick_E]

Hi there,
Do these cells all contain fullpath with extensions, reference to the files you want to attach?

  .Attachments.Add ActiveSheet.Cells(cell.Row, "H").Value
  .Attachments.Add ActiveSheet.Cells(cell.Row, "I").Value
  .Attachments.Add ActiveSheet.Cells(cell.Row, "J").Value

If so, from what I see, it should work

 

[Trevor3007]

Hi there,
Do these cells all contain fullpath with extensions, reference to the files you want to attach?

  .Attachments.Add ActiveSheet.Cells(cell.Row, "H").Value
  .Attachments.Add ActiveSheet.Cells(cell.Row, "I").Value
  .Attachments.Add ActiveSheet.Cells(cell.Row, "J").Value

If so, from what I see, it should work

hi there

Thanks for your reply. Yes the do have the full path etc (well the macro button on the worksheet has the applicable , I just put the cursor on the cell (IE H2/I2/J2) and it does work . However I wanted to just click/select the various attachments and run the VBA to open Outlook etc.

hope this makes sense,

MTIA & KR
Trevor3007