Sending two PDFs by email - vba

I made the code (as shown below) which send one PDF by email correctly, but I need to send one more PDF.
Dim varFindThis As Variant
Dim rngLookIn As Range
varFindThis = Worksheets("Suivi").Range("B1")
Set rngLookIn = Worksheets("Suivi").Range("A:A")
If Not rngLookIn.Find(varFindThis, LookIn:=xlValues) Is Nothing Then
Dim f As String
f = Worksheets("Suivi").Range("B1").Value
'Since i didn't got that clear, here above you must create a code to declare "f" as whatever you want
Set c = Worksheets("Suivi").Range("A:A").Find(f)
Worksheets("Suivi").Range(c.Address).EntireRow.Delete
End If
'Do not forget to change the email ID
'before running this code
Dim OlApp As Object
Dim NewMail As Object
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
' With Application
' .ScreenUpdating = False
' .EnableEvents = False
' End With
Application.DisplayFullScreen = False
ThisWorkbook.Worksheets("PDF").Activate
Range("B1:BG46").Select
ActiveSheet.PageSetup.PrintArea = "$B$1:$BG$46"
' Temporary file path where pdf
' file will be saved before
' sending it in email by attaching it.
TempFilePath = Environ$("temp") & "\"
' Now append a date and time stamp
' in your pdf file name. Naming convention
' can be changed based on your requirement.
TempFileName = ActiveSheet.Name & "-" & Format(Now, "dd-mmm-20yy") & ".pdf"
'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName
'Now Export the Activesshet as PDF with the given File Name and path
On Error GoTo err
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
'Now open a new mail
Set OlApp = CreateObject("Outlook.Application")
'Loop through the rows
For Each cell In ThisWorkbook.Sheets("Envoie").Columns("C").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*#*" Then
EmailAddr1 = EmailAddr1 & ";" & cell.Value
End If
Next
For Each cell In ThisWorkbook.Sheets("Envoie").Columns("G").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*#*" Then
EmailAddr2 = EmailAddr2 & ";" & cell.Value
End If
Next
Subj = "N°Article" & ThisWorkbook.Sheets("CalculInfo").Range("A10")
Set NewMail = OlApp.CreateItem(0)
On Error Resume Next
With NewMail
.To = EmailAddr1
.CC = EmailAddr2
.BCC = "gaetan.affolter#he-arc.ch"
.Subject = Subj
.Body = "Bonjour, il vous reste 24 heures pour vérifier les données du PDF et de confirmer dans Octopus. Merci"
.Attachments.Add FileFullPath '--- full path of the pdf where it is saved
.Send 'or use .Display to show you the email before sending it.
End With
On Error GoTo 0
'Since mail has been sent with the attachment
'Now delete the pdf file from the temp folder
Kill FileFullPath
'set nothing to the objects created
Set NewMail = Nothing
Set OlApp = Nothing
'Now set the application properties back to true
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox ("Email a été envoyé")
Exit Sub
err:
MsgBox err.Description
Unload Me
The PrintArea I situated in the Worksheets("CalcGammeControle") and more precisely in "$G$2:$G$35"
How can I add it?

Related

email excel active sheet as a pdf with other attachments

I using a macro VBA script in excel that allows me to email the active range to a recipient as a pdf.
here's the code
Sub AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
' Not sure for what the Title is
Title = Range("A1")
' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"
' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = Title
.To = "email#email.com" ' <-- Put email of the recipient here
.CC = "" ' <-- Put email of 'copy to' recipient here
.Body = "ùìåí øá," & vbLf & vbLf _
& "øö''á ãå''ç òìåéåú îùìçú (îùåòø) ìàéùåø éåúí." & vbLf & vbLf _
& "ááøëä," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
' Try to send
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0
End With
' Delete PDF file
Kill PdfFile
' Quit Outlook if it was created by this code
If IsCreated Then OutlApp.Quit
' Release the memory of object variable
Set OutlApp = Nothing
End Sub
now I need this code to do the same and convert the active range to PDf but I also need to allow me to select and add other file as attachments to the email as well, my VBA and excel macro skills are not that great and I have no idea how to do that. could you please help me and rewrite the the code to do want I need.
Thanks,
Dan.
You should change this section:
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
To:
.Save
.Close olPromptForSave
Application.Visible = True
This will save the email in your drafts folder so you can add more attachments

my routine wont attach the file to email that i have specified

i have a routine that saves a file as values into excel and pdf then emails the file to a distlist but for some reason it wont attach my file i specify..any help much appreciated....I put the VBA code below
#
Sub SaveFile()
'Recalc Sheets prior to saving down
a = MsgBox("Do you want to Save the Performance Reports?", vbOKCancel)
If a = 2 Then Exit Sub
Dim SaveSheets As Variant
Dim strFilename As String
Dim sheetListRange As Range
Dim sheetName As Variant
Dim wksheet As Variant
Dim wkbSrc As Workbook
Dim wkbNew As Workbook
Dim wksNew As Worksheet
Dim wksSrc As Worksheet
Dim i As Integer
Dim OutApp As Object
Dim OutMail As Object
'Dim v As Variant
'On Error GoTo ErrorHandler
strFilename = Worksheets("Control").Range("SavePath").Value & "Ergonomie_Consultants_Performance_" & Format$(Now(), "YYYYMMDD") & ""
v = strFilename
Set sheetListRange = Worksheets("Control").Range("SaveList")
Set wkbSrc = ActiveWorkbook
Set wkbNew = Workbooks.Add
i = 0
For Each sheetName In sheetListRange
If sheetName = "" Then GoTo NEXT_SHEET
For Each wksheet In wkbSrc.Sheets
If wksheet.Name = sheetName Then
i = i + 1
wksheet.Copy Before:=wkbNew.Sheets(i)
Set wksNew = ActiveSheet
With wksNew
.Cells.Select
.Cells.Copy
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
End With
ActiveWindow.Zoom = 75
GoTo NEXT_SHEET
End If
Next wksheet
NEXT_SHEET:
Next sheetName
Application.DisplayAlerts = False
'dont need the default new sheets created by created a new workbook
wkbNew.Worksheets("Sheet1").Delete
'ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlsm
ActiveWorkbook.SaveAs FileName:=v, FileFormat:=xlNormal
' ActiveWorkbook.SaveAs FileName:=v, FileFormat:=xlNormal
' ActiveWorkbook.SaveAs FileName:=strFilename, FileFormat:=xlTypePDF
' If VarType(v) <> vbString Then Exit Sub
'
' If Dir(v) <> "" Then
' If MsgBox("File already exists - do you wish to overwrite it?", vbYesNo, "File Exists") = vbNo Then Exit Sub
' End If
With ActiveWorkbook
.ExportAsFixedFormat Type:=xlTypePDF, FileName:=v, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, From:=1, To:=3, OpenAfterPublish:=False
End With
ActiveWorkbook.Close
' EMAIL Excel Attachment File
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "waverley.inc#gmail.com"
.CC = ""
.BCC = ""
.Subject = "Ergonomie Australia Pty Ltd Consultant Report" & Format$(Now(), "_YYYYMMDD")
.Body = "Ergonomie Australia Pty Ltd Consultant Report" & Format$(Now(), "_YYYYMMDD")
'
.Attachments.Add v
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True
Exit Sub
ErrorHandler:
'If there is an unknown runtime error give the user the error number and associated description
'(Description is already set if the erorr is G_LNG_CRITICAL_ERROR)
If Err.Number <> CRITICAL_ERROR Then Err.Description = "Run-time error " & Err.Number & ": " & Err.Description
Err.Description = "Error saving worksheet as file: " & Err.Description
Err.Source = "Error saving worksheet as file: " & Err.Source
'Raise the error up to the error handler above
Err.Raise Number:=CRITICAL_ERROR
End Sub
The files are not attached becase the file extension is missing in variable v, therefore the system cannot find the file.
Just add the file extension:
.Attachments.Add v & ".pdf"

Create loop to go down cell then repeat macro code

I currently have a code that Saves the excel sheet in a PDF based on infomation specific to the text in cell B2, and then attach the PDF into an email and email out to the specific user.
I am unsure how to add a macro to the current code to have the cell in B2 go down the data validation list inbetted and then repeat the macro to send the next person the email specific to them.
This is the current code that I have to save pdf and then email:
Sub AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Title = Range("A1")
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = Range("G5") & "_" & ActiveSheet.Name & ".pdf"
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
With OutlApp.CreateItem(0)
.Subject = Title
.To = Range("B4")
.CC = Range("G3")
.Body = "Hello " & Range("G5") & "," & vbLf & vbLf _
& "Your Summary is attached. If you have any further questions about your selections, please call 1-800-XXX-XXXX." & vbLf & vbLf _
& "Best Regards," & vbLf _
& Application.UserName & vbLf _
& "Implementation Specialist" & vbLf & vbLf
.Attachments.Add PdfFile
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0
End With
' Delete PDF file
Kill PdfFile
' Quit Outlook if it was created by this code
If IsCreated Then OutlApp.Quit
' Release the memory of object variable
Set OutlApp = Nothing
End Sub
I quickly wrote an example to show how to loop through the Data Validation List.
Sub Sample()
Dim ws As Worksheet
Dim acell As Range, DataValCell As Range, tmpRng As Range
Dim s As String
Dim MyAr As Variant
Dim i As Long
Set ws = Sheet1 '<~~> Change this to the relevant sheet
With ws
Set DataValCell = .Range("B2")
'~~> Handles =NamedRange or =$O$17:$O$18
If Left(DataValCell.Validation.Formula1, 1) = "=" Then
s = Mid(DataValCell.Validation.Formula1, 2)
Set tmpRng = .Range(s)
Else '~~> Handles aaa,bbb,ccc,ddd
s = DataValCell.Validation.Formula1
End If
If Not tmpRng Is Nothing Then '~~> Handles =NamedRange or =$O$17:$O$18
For Each acell In tmpRng.Cells
Debug.Print acell.Value
'~~> this is where you loop through the DV List
Next
Else '~~> Handles aaa,bbb,ccc,ddd
MyAr = Split(s, ",")
For i = LBound(MyAr) To UBound(MyAr)
Debug.Print MyAr(i)
'~~> this is where you loop through the DV List
Next i
End If
End With
End Sub

defined macro locations in excel

I have a 120+ sheet workbook, the front page of which has a nice function to extract a specified sheet, saving it as a new book with a bunch of details. Which all works fine. Trying to add a new function though. On the extracted sheet, I've added a button and created a macro that will e-mail the finished article. The problem is, the location reference for the macro keeps defaulting back to the original book source, rather than the sheet itself (its all .XLSM files). The macro itself is on each sheet, but I can't find a way of fixing the reference for the macro to the sheet proper. And my google-fu has failed me. Any input or words of wisdom would be greatly appreciated!
OK, here's the mailer macro:
Sub Mail_FinishedSheet_Array()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object
Dim SigString As String
Dim Signature As String
Dim StrBody As String
Set wb1 = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file. There will" & vbNewLine & _
"be no VBA code in the file you send. Save the" & vbNewLine & _
"file as a macro-enabled (. Xlsm) and then retry the macro.", vbInformation
Exit Sub
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Signature details with path
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Zonal2014HO.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
' Make a copy of the file.
' If you want to change the file name then change only TempFileName variable.
TempFilePath = Environ$("temp") & "\"
TempFileName = wb1.Name & " " & Format(Now, "dd-mmm-yy hh-mm")
FileExtStr = "." & LCase(Right(wb1.Name, _
Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
'Body contents for HTML format e-mail
StrBody = "<BODY style=font-size:11pt;font-family:Calibri>Hi," _
& "<p>Please find a completed checksheet attached for a PC Rebuild." _
& "<p>Regards, " _
& "<p></BODY>"
' Change the mail address and subject in the macro before you run this procedure.
With OutMail
.To = "Eng_Tech_support#zonal.co.uk"
.CC = "rob.brown#zonal.co.uk"
.BCC = ""
.Subject = "Completed PC Rebuild Checksheet " & Format(Now, "dd-mmm-yy")
.HTMLbody = StrBody & Signature
.Attachments.Add wb2.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Display
End With
On Error GoTo 0
wb2.Close SaveChanges:=False
' Delete the file.
' Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
And here's the extraction macro from the main page that seperates the desires sheet from the book and saves it as a new file:
Sub Full_Extract()
Dim wbkOriginal As Workbook
Set wbkOriginal = ActiveWorkbook
'sets site and engineer details into the estate page that is being extracted
Worksheets(Sheet1.CmbSheet.Value).Range("B3").Value = Worksheets("front page").Range("E6")
Worksheets(Sheet1.CmbSheet.Value).Range("D3").Value = Worksheets("front page").Range("N6")
Worksheets(Sheet1.CmbSheet.Value).Range("F3").Value = Worksheets("front page").Range("K6")
Worksheets(Sheet1.CmbSheet.Value).Range("B4").Value = Worksheets("front page").Range("F8")
Worksheets(Sheet1.CmbSheet.Value).Range("D4").Value = Worksheets("front page").Range("K8")
' copies sheet name from combo box into new document, saves it with site name and current date
' into C:\Temp\ folder for ease of access
With ActiveWorkbook.Sheets(Array((Sheet1.CmbSheet.Value), "Z-MISC"))
.Copy
ActiveWorkbook.SaveAs _
"C:\temp\" _
& ActiveWorkbook.Sheets(Sheet1.CmbSheet.Value).Cells(3, 2).Text _
& " " _
& Format(Now(), "DD-MM-YY") _
& ".xlsm", _
xlOpenXMLWorkbookMacroEnabled, , , , False
End With
'code to close the original workbook to prevent accidental changes etc
Application.DisplayAlerts = False
wbkOriginal.Close
Application.DisplayAlerts = True
End Sub
use an ActiveX button
which requires its associated code to be in the worksheet it resides in and that after that .Copy and ActiveWorkbook.SaveAs ... statements will point to the worksheet in newly created workbook
Mail_FinishedSheet_Array() Sub must also be in the new workbook if you want to make it independent from "Checkbook.xlsm". In this case that Sub must reside in one of the two worksheets (Sheet1.CmbSheet.Value or "Z-MISC") being copied in the new workbook
user3598756 nailed it. Using an ActiveX button and then assigning the macro to it directly (right click, view code) has worked perfectly.

Export from Excel to Outlook

My workbook has 5 different sheets and I need to copy the five sheets and paste it into 5 different mails. Preferably as HTML.
The below written code only attaches the different sheets to outlook. I need the HTML below the body of the email. Please note that my range in the sheets varies from workbook to workbook but the sheet names remain the same.
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
'BrowseForFolder was a code originally written by Ron De Bruin, I love this function!
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Sub SaveWorksheets()
'saves each worksheet as a separate file in a specific folder.
Dim ThisFolder As String
Dim NameOfFile As String
Dim Period As String
Dim RecipName As String
ThisFolder = BrowseForFolder()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim wsName As String
For Each ws In ActiveWorkbook.Worksheets
wsName = ws.Name
If wsName <> "Data" Then
Period = ws.Cells(4, 1).Value 'put the row and column numbers of the report date here.
RecipName = ws.Cells(1, 29).Value 'put the row and column numbers of the email address here
NameOfFile = ThisFolder & "\" & "Termination Report " & wsName & " " & Period & ".xlsx"
ws.Select
ws.Copy
ActiveWorkbook.SaveAs Filename:= _
NameOfFile, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Call EmailWorkbooks(RecipName, NameOfFile)
End If
Next ws
End Sub
Sub EmailWorkbooks(RecipName, NameOfFile)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createItem(0)
Msg = "Attached is the xyz report for your review. Please let me know if you have any questions" & vbCrLf & vbCrLf _
& "Thanks," & vbCrLf & vbCrLf _
& "Your Name Here" & vbCrLf _
& "Your Title" & vbCrLf _
& "Your contact info"
Subj = "XYZ Report" & " " & Period
On Error Resume Next
With OutMail
.To = RecipName
'.CC =
.Subject = Subj
.Body = Msg
.Attachments.Add (NameOfFile)
.Save
End With
On Error GoTo 0
End Sub
U can use Add method of PublishObjects collection, short example:
Sub InsertSheetContent()
Dim onePublishObject As PublishObject
Dim oneSheet As Worksheet
Dim scriptingObject As Object
Dim outlookApplication As Object
Dim outlookMail As Object
Dim htmlBody As String
Dim htmlFile As String
Dim textStream
Set scriptingObject = CreateObject("Scripting.FileSystemObject")
Set outlookApplication = CreateObject("Outlook.Application")
For Each oneSheet In ThisWorkbook.Worksheets
htmlFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name & "_" & oneSheet.Name & ".html"
Set onePublishObject = ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
Filename:=htmlFile, _
Sheet:=oneSheet.Name, _
Source:=oneSheet.UsedRange.Address, _
HtmlType:=xlHtmlStatic, _
DivID:=oneSheet.Name)
onePublishObject.Publish Create:=True
Set textStream = scriptingObject.OpenTextFile(htmlFile)
htmlBody = textStream.ReadAll
Set outlookMail = outlookApplication.CreateItem(0)
With outlookMail
.htmlBody = htmlBody
.Display
End With
Next oneSheet
End Sub