Adding Attachments ie Cad drawings

[APElliott]

Hi,

I've just started using some code from the Ron DeBruin website to send workbooks to various people. See the code below.

However, what extra bit of code would I need to add other files that would be listed in column J.

Also what adjustments need to be made to send the emails one at a time.

Thankyou in advance.

Andrew

Private Sub RDB3_Click()
Dim strto1 As String, strto2 As String, strto3 As String, strbody As String
Dim ShArr() As String, XArr() As String, strDate As String
Dim myCell As Range, cell As Range, rng As Range, Fname As String
Dim Mail As Long, N As Long, S As Long
Dim wb As Workbook, sh As Worksheet
Dim DefPath As String
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant

If Application.WorksheetFunction.CountA(Me.Range("c1:c3")) < 3 Then
MsgBox "You must fill in the cells c1:c3", , "Emails"
Exit Sub
End If

Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("

http://schemas.microsoft.com/cdo/configuration/sendusing")

= 2
.Item("

http://schemas.microsoft.com/cdo/configuration/smtpserver")

= Trim(Me.Range("c3").value)
.Item("

http://schemas.microsoft.com/cdo/configuration/smtpserverport")

= 25
.Update
End With

If Len(ThisWorkbook.Path) = 0 Then
MsgBox "This macro will only work if the file is Saved ones", , "Emails"
Exit Sub
End If

'Fill the XArr with the row numbers of each cell with a "x" in column A
'Check all sheet names in the B column if they are valid

Set rng = Me.Range("A6:A" & Me.Cells(Me.Rows.Count, "A").End(xlUp).Row)

Erase XArr
N = 0
For Each myCell In rng.Cells
With myCell
If .value = "x" Then
N = N + 1
ReDim Preserve XArr(1 To N)
XArr(N) = myCell.Row
End If
End With

With myCell.Offset(0, 1)
If .value <> "" And .value <> "Whole workbook" Then
On Error Resume Next
If SheetExists(.value) = False Then
On Error GoTo 0
MsgBox "Worksheet: " & .value & " does not exist!" & vbLf _
& "Please correct and try again.", , "Emails"
Exit Sub
End If
End If
End With
Next myCell

Application.ScreenUpdating = False
Application.EnableEvents = False

'Start loop to create all E-Mail's
For Mail = 1 To N - 1

strto1 = ";": strto2 = ";": strto3 = ";": strbody = ""
With Me
On Error Resume Next

'Fill the Array with E-Mail addresses
For Each cell In .Range(.Cells(XArr(Mail), 3), .Cells(XArr(Mail + 1) - 1, 3))
If cell.value Like "*@*" Then strto1 = strto1 & ";" & cell.value
If cell.Offset(0, 1).value Like "*@*" Then strto2 = strto2 & ";" & cell.Offset(0, 1).value
If cell.Offset(0, 2).value Like "*@*" Then strto3 = strto3 & ";" & cell.Offset(0, 2).value
Next
strto1 = Mid(strto1, 2)
strto2 = Mid(strto2, 2)
strto3 = Mid(strto3, 2)

'Check if there is a E-mail address
If Application.WorksheetFunction.CountIf _
(.Range(.Cells(XArr(Mail), 3), .Cells(XArr(Mail), 5)), "*@*") = 0 Then GoTo MailNot

'Make the body string
For Each cell In .Range(.Cells(XArr(Mail), 6), .Cells(XArr(Mail + 1) - 1, 6))
strbody = strbody & cell.value & vbNewLine
Next

'Fill the Array with Sheets names or Send the whole workbook
S = 0
If Application.WorksheetFunction.CountIf _
(.Range(.Cells(XArr(Mail), 2), .Cells(XArr(Mail + 1) - 1, 2)), "Whole workbook") > 0 Then
S = -1
Else
For Each cell In .Range(.Cells(XArr(Mail), 2), .Cells(XArr(Mail + 1) - 1, 2))
If Trim(Len(cell.value)) > 0 Then
S = S + 1
ReDim Preserve ShArr(1 To S)
ShArr(S) = cell.value
End If
Next cell
On Error GoTo 0
End If
End With

' The file will be saved with a Date/time stamp
' You can change the format if you like
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

strDate = Format(Now, "dd-mmm-yyyy h-mm-ss")
Fname = DefPath & Trim(Me.Cells(XArr(Mail), "H").value) & _
" " & strDate & ".xls"

'Copy the sheet(s)to a new workbook and save/Mail/Delete the file
If S > 0 Then
ThisWorkbook.Sheets(ShArr).Copy
Set wb = ActiveWorkbook
End If

If S = -1 Then
ThisWorkbook.Worksheets(Me.Range("I2").Text).Select
ThisWorkbook.SaveCopyAs Fname
Me.Activate
Set wb = Workbooks.Open(Fname)
Application.DisplayAlerts = False
wb.Sheets(Me.Name).Delete
Application.DisplayAlerts = True
End If

If S <> 0 Then
If Me.Cells(XArr(Mail), "I").value = "yes" Then
For Each sh In wb.Worksheets
If sh.ProtectContents = False Then
With sh.UsedRange
.value = .value
End With
ElseIf sh.ProtectContents = True Then
On Error Resume Next
sh.Unprotect Trim(Me.Range("c4").value)
On Error GoTo 0
If sh.ProtectContents = False Then
With sh.UsedRange
.value = .value
End With
sh.Protect Trim(Me.Range("c4").value)
Else
'Can't make values of the formulas because the
'sheet have a other password
End If
End If
Next sh
End If
Application.DisplayAlerts = False
wb.SaveAs Fname
Application.DisplayAlerts = True
wb.Close False
Set wb = Nothing
End If



Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = strto1
.CC = strto2
.BCC = strto3
.Subject = Me.Cells(XArr(Mail), "G").value
.From = "" & Me.Range("c1").value & "<" & Me.Range("c2").value & ">"
.TextBody = strbody
If S > 0 Or S = -1 Then
.AddAttachment Fname
End If
.Send
End With
Set iMsg = Nothing
If S > 0 Or S = -1 Then Kill Fname

MailNot:
Next Mail
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "All Emails have now been sent!", , "Emails"
Set iConf = Nothing
End Sub