Hi All. I am currently trying to use a macro to pdf each individual sheet to email addresses in B2 of each sheet. This works perfectly. However I want to email using a different email account to my default one. This doesn't work perfectly! I have two seperate VBA scripts, one for PDF and send that works, one to email from a different email account, and that works. However I cannot combine them. Can anybody help? Here is my code for the PDF and email each seperate sheet:
Sub Mail_Every_Worksheet_With_Address_In_B2_PDF()
'Working only in 2007 and up
Dim sh As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim FileName As String
'Temporary path to save the PDF files
'You can also use another folder like
'TempFilePath = "C:\Users\Ron\MyFolder"
TempFilePath = Environ$("temp") & ""
'Loop through every worksheet
For Each sh In ThisWorkbook.Worksheets
FileName = ""
'Test B2 for a mail address
If sh.Range("B2").Value Like "?*@?*.?*" Then
'If there is a mail address in B2 create the file name and the PDF
TempFileName = TempFilePath & sh.Name & " " _
& Format(Now, "dd-mmm-yy") & ".pdf"
FileName = RDB_Create_PDF(Source:=sh, _
FixedFilePathName:=TempFileName, _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=False)
'If publishing is OK create the mail
If FileName <> "" Then
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
StrTo:=sh.Range("B2").Value, _
StrCC:="", _
StrBCC:="", _
StrSubject:="Weekly Certificate - Millisun", _
Signature:=True, _
Send:=False, _
strbody:="Good morning<br><br>" & _
"******>Please find your weekly certificate." & _
"<br><br>" & "Regards Millisun Accounts</body>"
Else
MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
"Microsoft Add-in is not installed" & vbNewLine & _
"You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
"The path to Save the file in arg 2 is not correct" & vbNewLine & _
"You didn't want to overwrite the existing PDF if it exist"
End If
End If
Next sh
End Sub
Sub Mail_Every_Worksheet_With_Address_In_B2_PDF()
'Working only in 2007 and up
Dim sh As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim FileName As String
'Temporary path to save the PDF files
'You can also use another folder like
'TempFilePath = "C:\Users\Ron\MyFolder"
TempFilePath = Environ$("temp") & ""
'Loop through every worksheet
For Each sh In ThisWorkbook.Worksheets
FileName = ""
'Test B2 for a mail address
If sh.Range("B2").Value Like "?*@?*.?*" Then
'If there is a mail address in B2 create the file name and the PDF
TempFileName = TempFilePath & sh.Name & " " _
& Format(Now, "dd-mmm-yy") & ".pdf"
FileName = RDB_Create_PDF(Source:=sh, _
FixedFilePathName:=TempFileName, _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=False)
'If publishing is OK create the mail
If FileName <> "" Then
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
StrTo:=sh.Range("B2").Value, _
StrCC:="", _
StrBCC:="", _
StrSubject:="Weekly Certificate - Millisun", _
Signature:=True, _
Send:=False, _
strbody:="Good morning<br><br>" & _
"******>Please find your weekly certificate." & _
"<br><br>" & "Regards Millisun Accounts</body>"
Else
MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
"Microsoft Add-in is not installed" & vbNewLine & _
"You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
"The path to Save the file in arg 2 is not correct" & vbNewLine & _
"You didn't want to overwrite the existing PDF if it exist"
End If
End If
Next sh
End Sub