EXCEL VBA HELP SENDMAIL

[becroft_g]

I have the Ron De Bruise Sendmail VBA script and I need to amend it slightly to be able to complete what I need. What I need is to be able to have a list of email addresses and a filed with Area and group The current script gives you the ability to email the list of people the excel file as PDF but I need it to change cell A1 and A2 to the Area and Group next to the email address and then send the email as I have a report template that vlookup off A1 and A2 so As I change these cells the report data changes Can you please help as currently I have to make the changes manually and send it out 80 times on a monday morning :banghead:
Here is the script I need amended


Private Sub RDB_Outlook_Click()
Dim StringTo As String, StringCC As String, StringBCC As String
Dim ShArr() As String, FArr() As String, strDate As String
Dim myCell As Range, cell As Range, rng As Range, Fname As String, Fname2 As String
Dim wb As Workbook, sh As Worksheet
Dim DefPath As String
Dim olApp As Object
Dim olMail As Object
Dim FileExtStr As String
Dim ToArray As Variant
Dim CCArray As Variant
Dim BCCArray As Variant
Dim StringFileNames As String
Dim StringSheetNames As String
Dim FileNamesArray As Variant
Dim SheetNamesArray As Variant
Dim I As Long, S As Long, F As Long
Dim WrongData As Boolean
If Len(ThisWorkbook.Path) = 0 Then
MsgBox "This macro will only work if the file is Saved once", 48, "RDBMailPDFOutlook"
Exit Sub
End If
If Me.ProtectContents = True Or ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "This macro will not work if the RDBMailOutlook worksheet is " & _
"protected or if you have more then sheet selected(grouped)", 48, "RDBMailPDFOutlook"
Exit Sub
End If
'Set folder where we save the temporary files
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Set reference to Outlook and turn of ScreenUpdating and Events
Set olApp = CreateObject("Outlook.Application")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Set cells with Red interior color to no fill(cells with wrong data)
Range("A6").ListObject.DataBodyRange.Interior.Pattern = xlNone
'Set rng to the first column of the table
Set rng = Me.Range("A6").ListObject.ListColumns(1).Range
For Each myCell In rng
'Create mail if "Yes " in column A
If LCase(myCell.Value) = "yes" Then
StringTo = "": StringCC = "": StringBCC = ""
S = 0: F = 0
Erase ShArr: Erase FArr




'Set Error Boolean to False
WrongData = False
'Check if there are Sheet names in column B
'If B is empty S = 0 so you not want to send a sheet or sheets as pdf
If Trim(Me.Cells(myCell.Row, "B").Value) = "" Then S = 0
'If there are sheet names in the B column S is the number of sheets it add to the Array
If LCase(Trim(Me.Cells(myCell.Row, "B").Value)) <> "workbook" Then
StringSheetNames = Me.Cells(myCell.Row, "B").Value
SheetNamesArray = Split(StringSheetNames, Chr(10), -1)
For I = LBound(SheetNamesArray) To UBound(SheetNamesArray)
On Error Resume Next
If SheetNamesArray(I) <> "" Then
If SheetExists(CStr(SheetNamesArray(I))) = False Then
Me.Cells(myCell.Row, "B").Interior.ColorIndex = 3
WrongData = True
Else
S = S + 1
ReDim Preserve ShArr(1 To S)
ShArr(S) = SheetNamesArray(I)
End If
End If
On Error GoTo 0
Next I
Else
'If you only enter "workbook" in colomn B to mail the whole workbook S = -1
S = -1
End If
'Check to Mail addresses in column D
If Trim(Me.Cells(myCell.Row, "D").Value) <> "" Then
StringTo = Me.Cells(myCell.Row, "D").Value
ToArray = Split(StringTo, Chr(10), -1)
StringTo = ""
For I = LBound(ToArray) To UBound(ToArray)
If ToArray(I) Like "?*@?*.?*" Then
StringTo = StringTo & ";" & ToArray(I)
End If
Next I
End If
'Check to Mail addresses in column E
If Trim(Me.Cells(myCell.Row, "E").Value) <> "" Then
StringCC = Me.Cells(myCell.Row, "E").Value
CCArray = Split(StringCC, Chr(10), -1)
StringCC = ""
For I = LBound(CCArray) To UBound(CCArray)
If CCArray(I) Like "?*@?*.?*" Then
StringCC = StringCC & ";" & CCArray(I)
End If
Next I
End If
'Check to Mail addresses in column F
If Trim(Me.Cells(myCell.Row, "F").Value) <> "" Then
StringBCC = Me.Cells(myCell.Row, "F").Value
BCCArray = Split(StringBCC, Chr(10), -1)
StringBCC = ""
For I = LBound(BCCArray) To UBound(BCCArray)
If BCCArray(I) Like "?*@?*.?*" Then
StringBCC = StringBCC & ";" & BCCArray(I)
End If
Next I
End If
If StringTo = "" And StringCC = "" And StringBCC = "" Then
Me.Cells(myCell.Row, "D").Resize(, 3).Interior.ColorIndex = 3
WrongData = True
End If
'Check the other files that you want to attach in column H
If Trim(Me.Cells(myCell.Row, "H").Value) <> "" Then
StringFileNames = Me.Cells(myCell.Row, "H").Value
FileNamesArray = Split(StringFileNames, Chr(10), -1)
For I = LBound(FileNamesArray) To UBound(FileNamesArray)
On Error Resume Next
If FileNamesArray(I) <> "" Then
If Dir(FileNamesArray(I)) <> "" Then
If Err.Number = 0 Then
F = F + 1
ReDim Preserve FArr(1 To F)
FArr(F) = FileNamesArray(I)
Else
Err.Clear
Me.Cells(myCell.Row, "H").Interior.ColorIndex = 3
WrongData = True
End If
Else
Me.Cells(myCell.Row, "H").Interior.ColorIndex = 3
WrongData = True
End If
End If
On Error GoTo 0
Next I
End If
'Not create the mail if there are Errors in the row (wrong sheet or file names or no mail addresses)
If WrongData = True Then GoTo MailNot

'Create PDF and Mail
'Create Date/time string for the file name
strDate = Format(Now, "dd-mmm-yyyy hh-mm-ss")
'Copy the sheet(s)to a new workbook
If S > 0 Then
ThisWorkbook.Sheets(ShArr).Copy
Set wb = ActiveWorkbook
End If
'You enter only "workbook" in colomn B to mail the whole workbook
'Use SaveCopyAs to make a copy of the workbook
If S = -1 Then
FileExtStr = "." & LCase(Right(ThisWorkbook.Name, _
Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, ".", , 1)))
Fname2 = DefPath & "TempFile " & strDate & FileExtStr
ThisWorkbook.SaveCopyAs Fname2
Me.Activate
Set wb = Workbooks.Open(Fname2)
Application.DisplayAlerts = False
wb.Sheets(Me.Name).Delete
Application.DisplayAlerts = True
If wb.Sheets(1).Visible = xlSheetVisible Then wb.Sheets(1).Select
End If

'Now we Publish to PDF
If S <> 0 Then
Fname = DefPath & Trim(Me.Cells(myCell.Row, "C").Value) & _
" " & strDate & ".pdf"
On Error Resume Next
wb.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
On Error GoTo 0
wb.Close False
Set wb = Nothing
End If
On Error Resume Next
Set olMail = olApp.CreateItem(0)
With olMail
.To = StringTo
.CC = StringCC
.BCC = StringBCC
.Subject = Me.Cells(myCell.Row, "G").Value
.Body = Me.Cells(myCell.Row, "I").Value
If S <> 0 Then .Attachments.Add Fname
If F > 0 Then
For I = LBound(FArr) To UBound(FArr)
.Attachments.Add FArr(I)
Next I
End If
'Set Importance 0 = Low, 2 = High, 1 = Normal
If LCase(Me.Cells(myCell.Row, "J").Value) = "yes" Then
.Importance = 2
End If
'Display the mail or send it directly, see cell C3
If LCase(Me.Range("C3").Value) = "yes" Then
.Display
Else
.Send
End If

End With
If S = -1 Then Kill Fname2
Kill Fname
On Error GoTo 0
Set olMail = Nothing
End If
MailNot:
Next myCell
If LCase(Me.Range("C3").Value) = "no" Then
MsgBox "The macro is ready and if correct the mail or mails are created." & vbNewLine & _
"If you see Red cells in the table then the information in the cells is " & vbNewLine & _
"not correct. For example there is a sheet or filename that not exist." & vbNewLine & _
"Note: It will not create a Mail of the information in a row with a " & vbNewLine & _
"Red cell or cells.", 48, "RDBMailPDFOutlook"
End If

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set olApp = Nothing
End Sub

Function SheetExists(wksName As String) As Boolean
On Error Resume Next
SheetExists = CBool(Len(ThisWorkbook.Sheets(wksName).Name) > 0)
On Error GoTo 0
End Function
Private Sub BrowseAddFiles_Click()
Dim Fname As Variant
Dim fnum As Long
If ActiveCell.Column = 8 And ActiveCell.Row > 6 Then
Fname = Application.GetOpenFilename(filefilter:="All Files (*.*), *.*", _
MultiSelect:=True)
If IsArray(Fname) Then
For fnum = LBound(Fname) To UBound(Fname)
If fnum = 1 And ActiveCell.Value = "" Then
ActiveCell.Value = ActiveCell.Value & Fname(fnum)
Else
If Right(ActiveCell, 1) = Chr(10) Then
ActiveCell.Value = ActiveCell.Value & Fname(fnum)
Else
ActiveCell.Value = ActiveCell.Value & Chr(10) & Fname(fnum)
End If
End If
Next fnum
With Me.Range("J1").EntireColumn
.ColumnWidth = 255
.AutoFit
End With
With Me.Rows
.AutoFit
End With
End If
Else
MsgBox "Select a cell in the ""Attach other files"" column", 48, "RDBMailPDFOutlook"
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 3 And Target.Column < 7 And Target.Row > 6 Then
With Range(Target.Address)
.Hyperlinks.Delete
End With
End If
End Sub

[SamT]

becroft,

I'm using xl2003, so I can't help you directly. But I did analyse your logic.

I noticed that you have many "On Error GoTo 0"s, each of which turns off error checking; You use a String value in the Cells(Row, Column) Methods when xl2003 requires that these both be Longs; You attempt to ReDim a String Variable to an Array Variable. I don't know if this is possible; You need to move everything after "'Create PDF and Mail" to the end after you loop back to "For Each myCell In rng."

SamT

Analysis Follows:

Step 1: Prompt User to save file
Step 2: Prompt User to unprotect file
Step 3: Set Variable DefPath to temp path
Step 4: Set Variable olApp to Outlook Application
Step 5: Clear Interior Color of Cell A6
Step 6: Set Variable rng to first column of ListObject? I think...I don't use 2007

Step through rng, (first Column in ListObject.)

Step 7: If yes in rng, clear addresses TO, CC, and BCC
Step 8: Set Variables S and F to zero
Step 9: Erase Variables ShArr and FArr
Step 10: Set Error variable, WrongData, to False

Step 11: If Column B is empty, set S to zero
Can one use strings in Cells(Row, Column) in 2007?
If not, This is an ERROR

Step 12: If the Value in Column B is not exactly "workbook"
Step 12.1: Fill SheetNamesArray with the Split value in column B
The Split occurs on Carriage Returns
Step 12.2: Skip double Chr(10)'s
If the Named Sheets in 12.1 Don't exist, Color Cell in Column B Red
Step 12.2.1: Else Increment Variable S
Step 12.2.2: Redim String Variable ShArr to an Array Variable
and fill it with the good names
Step 12.3: Else Column B is "workbook"
Step 12.3.1: Set S = -1

Step 13: Get the To Addresses from Column D
Step 13.1: Replace Chr(10) in addresses with ";"
Set Variable StringTo to only good addresses
On Error Goto 0
Step 14: Repeat Step 13 with StringCC from Column F
Step 15: Repeat Step 13 with StringBCC From Column E
Step 16: If all three Address Variables empty, Color Column D cell Red
Step 16.1: Set Variable WrongData = True

Step 17: Column H holds the Files to send
Follow Step 12 using Column H, Except:
If Error, Color Column H
Set WrongData True
Redim String Variable FArr
On Error Goto 0
If WrongData = True Loop back to Step 7

Step 18: Set Variable strDate = NOW

Step 19: If S > 0, Send Sheets, Then
Set Variable wb to a workbook that contains selected Worksheets, (ShArr)

Step 20: If s = -1, Send Workbook, Then
Thisworkbook SaveAs FName2
Set Variable wb to FName2
Me.Activate? Which workbook is Me?
wb.Sheets(Me.Name).Delete
If wb.Sheets(1).Visible = xlSheetVisible Then wb.Sheets(1).Select

Step 21: If S <> 0, Convert wb to Fname.pdf
Fname includes value of Current Row, Column C
On Error Goto 0
Set wb = Nothing
On Error Resume Next
Step 22: Send Email
Set Subject, Body Text, Importance, and Display/Send according _
to (Current Row, Various Columns) values in ME? Which Workbook is Me?
Attach FName.pdf

Loop Back to Step 7 (Do Next Row)

Step 23: If Me.Range(C3) = No, Then MsgBox