multi attachements

Trevor3007

Well-known Member
Joined
Jan 26, 2017
Messages
667
Office Version
  1. 365
Platform
  1. Windows
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
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Comma separate the pathway to each attachment then loop through the cell as an array and attach each?






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

Code:
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
 
Upvote 0
Good morning Roderick_E

Thank you for your help.

This is the code I currently use:-

Code:
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
 
Last edited by a moderator:
Upvote 0
Hi there,
Do these cells all contain fullpath with extensions, reference to the files you want to attach?
Code:
  .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
 
Upvote 0
Hi there,
Do these cells all contain fullpath with extensions, reference to the files you want to attach?
Code:
  .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
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,144
Members
448,552
Latest member
WORKINGWITHNOLEADER

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top