Public Sub subProcessForm()
Dim strPDFFileName As String
ActiveWorkbook.Save
strPDFFileName = "C:\Testpfad\" & Range("A15").Value & ".pdf"
If fncCheckFormData() Then
' This range needs to be changed as appropriate.
If fncSaveRangeAsPDF(Range("A1:K30"), strPDFFileName) Then
If fncSendEmail(strPDFFileName) Then
' Change this message.
MsgBox "Email sent.", vbOKOnly, "Confirmation"
Else
' Change this message.
MsgBox "Email not sent.", vbOKOnly, "Warning!"
End If
Else
' Change this message.
MsgBox "PDF file not created.", vbOKOnly, "Warning!"
End If
Else
' Change this message or not have one here at all.
MsgBox "Checks not passed.", vbOKOnly, "Warning!"
End If
End Sub
Public Function fncCheckFormData() As Boolean
' Function returns FALSE unless all checks are passed.
On Error GoTo Err_Handler
If IsEmpty(Range("A7")) Or Not IsDate(Range("A7")) Then
MsgBox "Enter date.", vbOKOnly, "Warning!"
Range("A7").Select
Exit Function
End If
If IsEmpty(Range("D7")) Then
MsgBox "Enter Vizrt sales peson.", vbOKOnly, "Warning!"
Range("D7").Select
Exit Function
End If
If IsEmpty(Range("C9")) Or Not IsDate(Range("C9")) Then
MsgBox "Enter the start date of your rental.", vbOKOnly, "Warning!"
Range("C9").Select
Exit Function
End If
If IsEmpty(Range("C11")) Or Not IsDate(Range("C11")) Then
MsgBox "Enter the end date of your rental.", vbOKOnly, "Warning!"
Range("C11").Select
Exit Function
End If
If IsEmpty(Range("A15")) Then
MsgBox "Please enter a subject line / quote number in cell A15!.", vbOKOnly, "Warning!"
Range("A15").Select
Exit Function
End If
fncCheckFormData = True
Exit_Handler:
Exit Function
Err_Handler:
Resume Exit_Handler
End Function
Public Function fncSaveRangeAsPDF(rngRange As Range, strFileName As String) As Boolean
On Error GoTo Err_Handler
If Dir(strFileName) <> "" Then
Kill (strFileName)
End If
With Sheets(rngRange.Parent.Name).PageSetup
.PrintArea = rngRange.Address
.Zoom = False
.Orientation = xlPortrait
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
rngRange.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName
fncSaveRangeAsPDF = Dir(strFileName) <> ""
Exit_Handler:
Exit Function
Err_Handler:
Resume Exit_Handler
End Function
Public Function fncSendEmail(strFileName As String) As Boolean
Dim xOutlookObj As Object
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Dim rng As Range
Dim strmsg As String
Dim arrymsg()
Dim i As Long
Dim strDesktopPath As String
On Error GoTo Err_Handler
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.createitem(0)
' Doc.SaveAs2 Filename:=Environ("temp") & "\" & Environ("username"), FileFormat:=wdFormatPDF, AddToRecentFiles:=False
xMailBody = "Please add any special requirements hereFor FOC rentals - please attach Vanessa's approval to your email." & vbNewLine & _
vbNewLine & _
"" & vbNewLine & _
""
On Error Resume Next
With xOutMail
.To = "logisticaustria@vizrt.com"
.CC = ""
.BCC = ""
.Subject = "Demopool Request Form_"
.Body = xMailBody
.Attachments.Add strFileName
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
fncSendEmail = True
Exit_Handler:
Exit Function
Err_Handler:
Resume Exit_Handler
End Function
