hello everyone,
i'm having a litte troube with my worksheet and i'm hoping for some help please. the worksheet titled ISSUE RECEIPT contains three command button, Send As Email, Save As PDF, and Clear Invoice. everything works the way it's supposed to except the
i'm having a litte troube with my worksheet and i'm hoping for some help please. the worksheet titled ISSUE RECEIPT contains three command button, Send As Email, Save As PDF, and Clear Invoice. everything works the way it's supposed to except the
Save As PDF button. when it saves, it does so the as the workbook name, but I want it to save as the worksheet name (ISSUE RECEIPT). the other problem I have is that if I try to save it a second time my override code to change the file name doesn't work. I get an error code. "compile error: expected function or variable" if anyone can assist with this, I'd be most grateful, below is the code.
Code:
Private Sub cmdClear_Click()
Range("H9").Value = Range("H9").Value + 1
Range("D23:H54").ClearContents
End Sub
Private Sub cmdSaveAsPDF_Click()
'PURPOSE: Generate A PDF Document With Selected Worksheet(s)
'NOTES: PDF Will Be Saved To Same Folder As Excel File
Dim CurrentFolder As String
Dim FileName As String
Dim myPath As String
Dim UniqueName As Boolean
UniqueName = False
'Store Information About Excel File
myPath = ActiveWorkbook.FullName
CurrentFolder = ActiveWorkbook.Path & "\"
FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
'Does File Already Exist?
Do While UniqueName = False
DirFile = CurrentFolder & FileName & ".pdf"
If Len(Dir(DirFile)) <> 0 Then
UserAnswer = MsgBox("File Already Exists! Click " & _
"[Yes] to override. Click [No] to Rename.", vbYesNoCancel)
If UserAnswer = vbYes Then
UniqueName = True
ElseIf UserAnswer = vbNo Then
Do
'Retrieve New File Name
FileName = Application.InputBox("Provide New File Name " & _
"(will ask again if you provide an invalid file name)", , _
FileName, Type:=2)
'Exit if User Wants To
If FileName = "False" Or FileName = "" Then Exit Sub
Loop While ValidFileName(FileName) = False
Else
Exit Sub 'Cancel
End If
Else
UniqueName = True
End If
Loop
'Save As PDF Document
On Error GoTo ProblemSaving
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=CurrentFolder & FileName & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
On Error GoTo 0
'Disable Page Breaks
ActiveSheet.DisplayPageBreaks = False
ActiveSheet.Select
'Confirm Save To User
With ActiveWorkbook
FolderName = Mid(.Path, InStrRev(.Path, "\") + 1, Len(.Path) - InStrRev(.Path, "\"))
End With
MsgBox "A PDF of this Worksheet is Saved in the Folder: " & FolderName
Exit Sub
'Error Handlers
ProblemSaving:
MsgBox "There was a problem saving your PDF. This is most commonly" & _
" caused by the original PDF file already being open."
Exit Sub
End Sub
Function ValidFileName(FileName As String) As Boolean
'PURPOSE: Determine If A Given Excel File Name Is Valid
Dim TempPath As String
Dim wb As Workbook
'Determine Folder Where Temporary Files Are Stored
TempPath = Environ("TEMP")
'Create a Temporary XLS file (XLS in case there are macros)
On Error GoTo InvalidFileName
Set wb = ActiveWorkbook.SaveAs(Activebook.TempPath & _
"\" & FileName & ".xls", xlExcel8)
On Error Resume Next
'Delete Temp File
Kill wb.FullName
'File Name is Valid
ValidFileName = True
Exit Function
'ERROR HANDLERS
InvalidFileName:
'File Name is Invalid
ValidFileName = False
End Function
Private Sub cmdSendEmail_Click()
'PURPOSE: Generate A PDF Document With Selected Worksheet(s) and attached to email
Dim SourceWB As Workbook
Dim DestinWB As Workbook
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim ExternalLinks As Variant
Dim TempFilePath As String
Dim FileExtStr As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim x As Long
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'Copy only selected sheets into new workbook
Set SourceWB = ActiveWorkbook
SourceWB.Windows(1).SelectedSheets.Copy
Set DestinWB = ActiveWorkbook
'Check for macro code residing in
If Val(Application.Version) >= 12 Then
If SourceWB.FileFormat = 51 And SourceWB.HasVBProject = True Then
UserAnswer = MsgBox("There was VBA code found in this xlsx file. " & _
"If you proceed the VBA code will not be included in your email attachment. " & _
"Do you wish to proceed?", vbYesNo, "VBA Code Found!")
'Handle if user cancels
If UserAnswer = vbNo Then
DestinWB.Close SaveChanges:=False
GoTo ExitSub
End If
End If
End If
'Determine Temporary File Path
TempFilePath = Environ$("temp") & "\"
'Determine Default File Name for InputBox
If SourceWB.Saved Then
DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
Else
DefaultName = SourceWB.Name
End If
'Ask user for a file name
TempFileName = Application.InputBox("What would you like to name your attachment? (No Special Characters!)", _
"File Name", Type:=2, Default:=DefaultName)
If TempFileName = False Then GoTo ExitSub 'Handle if user cancels
'Determine File Extension
If SourceWB.Saved = True Then
FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
Else
FileExtStr = ".xlsx"
End If
'Break External Links
ExternalLinks = DestinWB.LinkSources(Type:=xlLinkTypeExcelLinks)
'Loop Through each External Link in ActiveWorkbook and Break it
On Error Resume Next
For x = 1 To UBound(ExternalLinks)
DestinWB.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
Next x
On Error GoTo 0
'Save Temporary Workbook
DestinWB.SaveCopyAs TempFilePath & TempFileName & FileExtStr
'Create Instance of Outlook
On Error Resume Next
Set OutlookApp = GetObject(Class:="Outlook.Application") 'Handles if Outlook is already open
Err.Clear
If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(Class:="Outlook.Application") 'If not, open Outlook
If Err.Number = 429 Then
MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
GoTo ExitSub
End If
On Error GoTo 0
'Create a new email message
Set OutlookMessage = OutlookApp.CreateItem(0)
'Create Outlook email with attachment
On Error Resume Next
With OutlookMessage
.To = ""
.CC = ""
.BCC = ""
.Subject = TempFileName
.Body = "Please see attached." & vbNewLine & vbNewLine & "Very Respectfully/"
.Attachments.Add TempFilePath & TempFileName & FileExtStr
.Display
End With
On Error GoTo 0
'Close & Delete the temporary file
DestinWB.Close SaveChanges:=False
Kill TempFilePath & TempFileName & FileExtStr
'Clear Memory
Set OutlookMessage = Nothing
Set OutlookApp = Nothing
'Optimize Code
ExitSub:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
[/FONT][/COLOR][COLOR=#222222][FONT=Verdana]
