How JustAnswer Works:

  • Ask an Expert
    Experts are full of valuable knowledge and are ready to help with any question. Credentials confirmed by a Fortune 500 verification firm.
  • Get a Professional Answer
    Via email, text message, or notification as you wait on our site.
    Ask follow up questions if you need to.
  • 100% Satisfaction Guarantee
    Rate the answer you receive.

Ask Christopher Love Your Own Question

Christopher Love
Christopher Love, Computer Hardware Engineer
Category: Programming
Satisfied Customers: 119
Experience:  Owner at CJL & Associates
70121091
Type Your Programming Question Here...
Christopher Love is online now
A new question is answered every 9 seconds

Trying to run a macro from excel to save as a PDF then email

Customer Question

Trying to run a macro from excel to save as a PDF then email in Outlook, but the email is not going.
Submitted: 1 year ago.
Category: Programming
Customer: replied 1 year ago.
This is my current code:Sub Mail_ActiveSheet()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
Dim OutApp As Object
Dim OutMail As Object
Dim myAttachments As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End WithSet Sourcewb = ActiveWorkbook'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False'Save the new workbook/Mail it/Delete it
Set ws = ActiveSheet'enter name and select folder for file
' start in current workbook folder
strFile = Replace(Replace(ws.Name, " ", ""), ".", "_") _
& "_" _
& Format(Now(), "yyyymmdd\_hhmm") _
& ".pdf"
strFile = ThisWorkbook.Path & "\" & strFilemyFile = Application.GetSaveAsFilename _
(InitialFileName:=strFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")If myFile <> "False" Then
ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=FalseMsgBox "PDF file has been created."
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set myAttachments = OutMail.AttachmentsOn Error Resume Next
With OutMail
.to = StrTo
.CC = ""
.BCC = ""
.Subject = "TEST"
.Body = "Test"
.Attachments.Add myFile, OpenAfterPublish = True
If Send = True Then
.Send
Else
.Display
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = NothingWith Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox ("Email has been Sent Successfully")
Exit Sub
err:
MsgBox err.Descrition
End Sub
Customer: replied 1 year ago.
Also wanted to insert a function BUTTON so users can just click.
Expert:  Christopher Love replied 1 year ago.
I found some issues with your code. Search for CJL for the modifications I made. Seems to work here.Sub Mail_ActiveSheet() 'Working in Excel 2000-2013'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm Dim FileExtStr As String Dim FileFormatNum As Long Dim Sourcewb As Workbook Dim Destwb As Workbook Dim TempFilePath As String Dim TempFileName As String Dim FileFullPath As String Dim OutApp As Object Dim OutMail As Object Dim myAttachments As Object With Application .ScreenUpdating = False .EnableEvents = False End With Set Sourcewb = ActiveWorkbook 'Copy the ActiveSheet to a new workbook ActiveSheet.Copy Set Destwb = ActiveWorkbook 'Determine the Excel version and file extension/format With Destwb If Val(Application.Version) < 12 Then 'You use Excel 97-2003 FileExtStr = ".xls": FileFormatNum = -4143 Else 'You use Excel 2007-2013 Select Case Sourcewb.FileFormat Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 Case 52: 'This is a reference to the workbook. As is there is no reference to ".HasVbProject CJL If Sourcewb.HasVBProject Then FileExtStr = ".xlsm": FileFormatNum = 52 'Else: FileExtStr = ".xlsx": 'CJL Else: FileExtStr = ".xlsx": ' CJL FileFormatNum = 51 End If Case 56: FileExtStr = ".xls": FileFormatNum = 56 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 End Select End If 'End With CJL - No beginning With statement 'Change all cells in the worksheet to values if you want 'With Destwb.Sheets(1).UsedRange ' .Cells.Copy ' .Cells.PasteSpecial xlPasteValues ' .Cells(1).Select ' End With ' Application.CutCopyMode = False 'Save the new workbook/Mail it/Delete it Set ws = ActiveSheet 'enter name and select folder for file ' start in current workbook folder strFile = Replace(Replace(ws.Name, " ", ""), ".", "_") _ & "_" & Format(Now(), "yyyymmdd\_hhmm") & ".pdf" strFile = ThisWorkbook.Path & "\" & strFile myFile = Application.GetSaveAsFilename _ (InitialFileName:=strFile, _ FileFilter:="PDF Files (*.pdf), *.pdf", _ Title:="Select Folder and FileName to save") 'If myFile "False" Then ' Original code CJL If myFile = "False" Then 'Modified Code CJL ws.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=myFile, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False MsgBox "PDF file has been created." End If Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) Set myAttachments = OutMail.Attachments On Error Resume Next With OutMail .to = StrTo .CC = "" .BCC = "" .Subject = "TEST" .Body = "Test" .Attachments.Add myFile, OpenAfterPublish = True If Send = True Then .Send Else: .Display End If End With On Error GoTo 0 Set OutMail = Nothing Set OutApp = Nothing With Application .ScreenUpdating = True .EnableEvents = True End With MsgBox ("Email has been Sent Successfully")Exit Suberr: MsgBox err.DescritionEnd Sub Also. The "StrTo" variable is never assigned. Maybe you can reference a cell for that?To add a button, just add a button using the designer anywhere on the form and right click and right click and assign your macro.
Expert:  Christopher Love replied 1 year ago.
Also, the link http://www.rondebruin.nl/win/winmail/Outlook/tips.htm is a dead link..
Expert:  Christopher Love replied 1 year ago.
Okay on the Not sending the file automatically and the not saving the PDF file automatically. Working on it. Thank you for your patience
Expert:  Christopher Love replied 1 year ago.
Try this. You may want to tweak it for your purpose but this code will create a .pdf file from an Excell file, save it to the path the user chooses and then emails it to a recipient of their choosing. Look for CJL in the code for my comments.
Sub Mail_ActiveSheet() 'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
Dim OutApp As Object
Dim OutMail As Object
Dim myAttachments As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook 'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook 'Determine the Excel version and file extension/format With Destwb
If Val(Application.Version) < 12 Then 'You use Excel 97-2003
FileExtStr = ".xls":
FileFormatNum = -4143
Else 'You use Excel 2007-2013
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx":
FileFormatNum = 51
Case 52:
'This is a reference to the workbook. As is there is no reference to ".HasVbProject CJL
'If HasVBProject Then ' Original code
If Sourcewb.HasVBProject Then
FileExtStr = ".xlsm":
FileFormatNum = 52
Else: FileExtStr = ".xlsx":
FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls":
FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb":
FileFormatNum = 50
End Select
End If
'End With ' 'Change all cells in the worksheet to values if you want 'CJL
'With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
Set ws = ActiveSheet
'enter name and select folder for file
' start in current workbook folder
strFile = Replace(Replace(ws.Name, " ", ""), ".", "_") _
& "_" & Format(Now(), "yyyymmdd\_hhmm") & ".pdf"
strFile = ThisWorkbook.Path & "\" & strFile
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'If myFile "False" Then ' Original code CJL
If myFile "" Then 'Modified Code CJL
ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox "PDF file has been created."
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set myAttachments = OutMail.Attachments
On Error Resume Next
With OutMail
.to = StrTo 'Always empty CJL. I manually added an email address in the StrTo var and it worked fine
'.to =***@******.***" CJL. I manually added an email address in the StrTo var to test and it worked fine
.CC = ""
.BCC = ""
.Subject = "TEST"
.Body = "Test"
.Attachments.Add myFile, OpenAfterPublish = True
'If Send = True Then 'Original code
If Sent = True Then 'CJL = Do not know what Send is referring to. It will always be empty or False
'.Send Commented CJL
Else: .Display
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox ("Email has been Sent Successfully")
Exit Sub
err: MsgBox err.Descrition
End Sub