Print to PDF not working - vba

My code is suppose to check cell j2 for an email address and if found, convert that specific tab to pdf and save it in a file path that the user chooses. It works fine on the original workbook I made the macro in. When I copy the code and try running it, it prints to pdf different sheets that don't even have anything in j2 with the incorrect tab name. I keep getting an Run time error 5 Invalid procedure call or argument when i run the code on the print pdf line.
Sub SaveSheetsAsPDF()
Dim DestFolder As String
Dim PDFFile As String
Dim wb As Worksheet
Dim AlwaysOverwritePDF As Boolean
'Speed up macro
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Prompt for file destination
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
DestFolder = .SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
End With
'Create new PDF file name including path and file extension
For Each wb In ThisWorkbook.Worksheets
'Test j2 for a mail address
If wb.Range("J2").Value Like "?*#?*.?*" Then
PDFFile = DestFolder & Application.PathSeparator & wb.Name & "-" & Format(Date, "mmyy") & ".pdf"
'If the PDF already exists
If Len(Dir(PDFFile)) > 0 Then
If AlwaysOverwritePDF = False Then
OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
'If you want to overwrite the file then delete the current one
If OverwritePDF = vbYes Then
Kill PDFFile
Else
MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
Else
On Error Resume Next
Kill PDFFile
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
End If
'Prints PDF
wb.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next wb
MsgBox "All Files Have Been Converted!"
ResetSettings:
'Resets optimization settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Edit: Also not all worksheets on the workbook will need to converted. So only the sheets that need to be converted will have the email address in J2.

Related

How can i use the 'environ' variable to save_as an excel invoice in another computer

If I want to save an invoice in the same folder in a different computer.
My path in my current system is C:\Users\bala\Google Drive\Invoice
I'll also be saving it C:\Users\sanford\Google Drive\Invoice
Heard that environment variables do this job, not sure how to do it.
Sub Save_As()
Dim filename As String
Dim msgResponse As VbMsgBoxResult
filename = "C:\Users\bala\Google Drive\Invoice\" & Range("F4") & Range("G4") & "_" & Range("M10")
If Len(Dir(filename)) = 0 Then
ActiveSheet.SaveAs filename, FileFormat:=52, CreateBackup:=False
Application.DisplayAlerts = True
MsgBox "Invoice saved successully", vbOKOnly, "INVOICE SAVED"
Else
msgResponse = MsgBox("Do you want to overwrite?", vbYesNoCancel)
If msgResponse = vbYes Then
ActiveSheet.SaveAs filename, FileFormat:=52, CreateBackup:=False
Application.DisplayAlerts = True
MsgBox "Invoice saved successully", vbOKOnly, "INVOICE SAVED"
Else
Exit Sub
End If
End If
End Sub
Can anyone help me out? Thanks!
You can use the Environ-function to get any system variable that is set, eg Environ("Username") to get the name of the current user.
However, be aware that the username is not always the name of the folder where all the user documents are stored. Therefore, it's better to use Environ("UserProfile"). So try:
filename = Environ("UserProfile") & "\" & Range("F4") & Range("G4") & "_" & Range("M10")

Convert excel tabs to PDF and send in separate emails

I am trying to convert excel tabs to PDF and send each tab as a single attachment on different emails in outlook with different email recipients.
For example, Tab A would correspond to a "Vendor Emails" Tab with a To, Cc, and Bcc for each tab. Same would go for Tab B but a different set of recipients.
My Code:
Option Explicit
Sub create_and_email_pdf()
Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object
CurrentMonth = ""
EmailSubject = "Invoice Attached for "
OpenPDFAfterCreating = True
AlwaysOverwritePDF = False
DisplayEmail = True
Email_To = ThisWorkbook.Sheets("Vendor Emails").Range("B2").Value
Email_CC = ""
Email_BCC = ""
'Prompt for file destination
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
DestFolder = .SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
End With
'Current month/year
CurrentMonth = Mid(ThisWorkbook.Sheets("Vendor Emails").Range("E1").Value, InStr(1, ThisWorkbook.Sheets("Vendor Emails").Range("E1").Value, " ") + 1)
'Create new PDF file name including path and file extension
PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
& "-" & CurrentMonth & ".pdf"
'If the PDF already exists
If Len(Dir(PDFFile)) > 0 Then
If AlwaysOverwritePDF = False Then
OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
'If you want to overwrite the file then delete the current one
If OverwritePDF = vbYes Then
Kill PDFFile
Else
MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
Else
On Error Resume Next
Kill PDFFile
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
'Create the PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating
'Create an Outlook object and new mail message
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
'Display email and specify To, Subject, etc
With OutlookMail
.Display
.To = Email_To
.CC = Email_CC
.BCC = Email_BCC
.Subject = EmailSubject & CurrentMonth
.Attachments.Add PDFFile
If DisplayEmail = False Then
.Send
End If
End With
End Sub
I keep having an issue with this line, I keep getting a run-time 1004 and that the file may be open/error while saving:
'Create the PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating
If I don't use the reference ThisWookbook.Sheets(), I dont get an issue, but it only sends out the tab that I'm currently active on, not sure how to specify which tabs to convert.
For more context these tabs I'm converting would be part of a bigger worksheet with additional backup tabs that would not get sent as they are for internal purposes.
Thanks.

VBA Before Save event - file restriction based on user entry

I have the following WB code which tries to force the user to save the file as a particular file type (.xlsm) and name (the default path & "username-gaplist" --> can be followed by ANY type after this). So far I'm almost got it working down pat, except for 1 issue with the comparison operator in the IF statement.
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim txtFileName As String
Dim yn As Boolean
Dim a As String
a = Application.DefaultFilePath & "\" & Environ("UserName") & "-Gaplist.xlsm"
'1. Check of Save As was used.
If SaveAsUI = True Then
Cancel = True
'2. Call up your own dialog box. Cancel out if user Cancels in the dialog box.
txtFileName = Application.GetSaveAsFilename(Environ("UserName") & "-Gaplist", "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm", , "Save As XLSM file")
'this compares the named file by user to the restriction which is username and gap list, and cancels if non-confmring
If Left(txtFileName, Len(txtFileName)) >= Left(a, Len(txtFileName)) Then
MsgBox Left(txtFileName, Len(txtFileName)) & vbLf & Left(a, Len(txtFileName))
'if user hits cancel (returns value of "False")
If txtFileName = "False" Then
MsgBox "Action Cancelled", vbOKOnly
Cancel = True
Exit Sub
End If
'if an invalid string is entered
Else
MsgBox "Must be saved in following format:" & vbLf & Application.UserName & "-Gaplist" & " " & "(you can add whatever after this)", vbOKOnly, "Retry.."
Cancel = True
Exit Sub
End If
'3. Save the file based on string entered
Application.EnableEvents = False
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=txtFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox "Saved to: " & txtFileName, vbExclamation, Now
End If
End Sub
Like I said, I know that the issue lies in the
Left(txtFileName, Len(txtFileName)) >= Left(a, Len(txtFileName))
and the Cancel function works correctly in this setup, but I tested and this is what happens:
Entered: username-gaplist.xlsm String(fixed): username-gaplist.xlsm
result: GOOD (will overwrite if already saved as display events gets
turned off) Entered: usernam.xlsm String(fixed):
username-gaplist.xlsm result: Good (will give the user's the msgbox
telling them to retry as it doesn't conform)
Entered: username-gaplist323423.xlsm String(fixed):
username-gaplist.xlsm result: Good (will save accordingly to the
specified file path)
Entered: userzzz.xlsm String(fixed): username-gaplist.xlsm result:
BAD - this is allowing the user to save because adding the "z" means that the entered string is > than the fixed string (based on
same length), and it saves this . I would like to fix this
Entered: (user hits cancel) String(fixed): username-gaplist.xlsm
result: Msgbox action cancelled - exits sub
The other thing I could try is to use a "LIKE" operator , but have little experience using this.
Anyone provide any thoughts/suggestions would be great!
THanks
Figured it out.
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim txtFileName As String
Dim yn As Boolean
Dim a As String
a = Application.DefaultFilePath & "\" & Environ("UserName") & "-Gaplist"
'1. Check of Save As was used.
If SaveAsUI = True Then
Cancel = True
'2. Call up your own dialog box. Cancel out if user Cancels in the dialog box.
txtFileName = Application.GetSaveAsFilename(Environ("UserName") & "-Gaplist", "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm", , "Save As XLSM file")
'this compares the named file by user to the restriction which is username and gap list, and cancels if non-confmring
If txtFileName = "False" Then
MsgBox "Action Cancelled", vbExclamation, "Cancelled.."
Cancel = True
Exit Sub
ElseIf Left(WorksheetFunction.Substitute(txtFileName, ".xlsm", ""), Len(a)) = a Then
GoTo ResumeSub
ElseIf Left(WorksheetFunction.Substitute(txtFileName, ".xlsm", ""), Len(a)) <> a Then
MsgBox "Must be saved in the following format: " & Chr(10) & Chr(10) & _
Environ("username") & "-Gaplist" & "(you can enter whatever text after this)" & vbLf & vbLf & _
"Note: Not case sensitive!", vbCritical, "Retry.."
Cancel = True
Exit Sub
End If
'3. Save the file.
ResumeSub:
Application.EnableEvents = False
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=txtFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox "Saved to: " & txtFileName & vbLf & vbLf & Space(15) & Date & " " & Time, vbInformation, "Saved!"
End If
End Sub

Excel Macro to 'Save As' in a set drive location as a .xlsm

I am trying to write a macro to save an excel file in a defined location, using a value in a cell as the title in the format .xlsm, it appears to work but does not actually save the file? i am not sure what i have done wrong? here is the macro:
Sub Savefileas()
ThisFile = Range("B4").Value
Dim varResult As Variant
varResult = Application.GetSaveAsFilename(FileFilter:= _
"Macro Enabled Workbook" & "(*.xlsm), *xlsm", Title:=Range("B4").Value &".xlsm", _
InitialFileName:="C:\Work\" & ThisFile & ".xlsm")
End Sub
Thanks in adavce
Give this a try. Error catching has also been added.
Sub Savefileas()
Dim ThisFile As String
Dim varResult As Variant
ThisFile = Range("B4").Value
varResult = Application.GetSaveAsFilename(FileFilter:= _
"Macro Enabled Workbook" & "(*.xlsm), *xlsm", Title:=ThisFile & ".xlsm", InitialFileName:="C:\My Documents\" & ThisFile & ".xlsm")
With ActiveWorkbook
On Error GoTo message
.SaveAs varResult & ".xlsm", FileFormat:=52
Exit Sub
message:
MsgBox "There is an error"
End With
End Sub

Optimize msoFileDialogOpen

I am trying to make this msoFileDialogOpen allow the user to select multiple files. Is there a better way to do this:
Public Sub Function3_FileExplorer()
' Start File Explorer to select file containing data (simple GUI, much
' easier than coding vFileName)
vuserChoiceDataFileNumber = InputBox("Enter the number of files you want to select.")
With Application.FileDialog(msoFileDialogOpen)
Select Case IsNumeric(vuserChoiceDataFileNumber)
Case True
If VarType(vuserChoiceDataFileNumber) = 2 Or 3 Then
iuserChoiceDataFileNumber = CInt(vuserChoiceDataFileNumber)
End If
Case False
MsgBox (vuserChoiceDataFileNumber & " is not an integer.")
.AllowMultiSelect = False
End Select
.Show
End With
Exit Sub
On Error GoTo ErrorHandler
.AllowMultiSelect = True
ErrorHandler:
MsgBox "Error detected" & vbNewLine & "Error" & Err.Number & ": " & _
Err.Description, vbCritical, "Error Handler: Error " & Err.Number
MsgBox "If you want to force the program to run, go to the line below and " & _
"insert a ' mark to comment the line out." & vbNewLine & _
"On Error GoTo ErrorHandler", vbCritical, "Error Handler: Error " & Err.Number
End Sub
Yes, you can make this much simpler by not asking the user how many files they want to open--just let them select as many as they want.
Public Sub Function3_FileExplorer()
' Start File Explorer to select file containing data (simple GUI, much easier than coding vFileName)
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.FilterIndex = 2
If .Show Then
Dim file As Variant
For Each file In .SelectedItems
' do something with the file, for example, open it:
Application.Workbooks.Open (file)
Next file
End If
End With
End Sub