Code:
Public Sub ExportTARRpt_Click()Dim TODA As String, FName As String, Rev As String, FT As String, GT As String, InputPDF As String
On Error GoTo Error1
TODA = DLookup("[TODA]", "[QryTAR]")
FName = DLookup("[FNames]", "[QryTAR]")
FT = DLookup("[FTCode]", "[QryTAR]")
GT = DLookup("[GNDTVL]", "[QryTAR]")
DoCmd.OutputTo 3, "RptTAR", acFormatPDF, "C:\TEMP\" & "QF XXX(" & FName & ")" & TODA & "(" & [FT] & ")-" & TOD & ".pdf", , 0
If GT = True Then
Call Form_FrmCostComp.CostComp_Click
End If
InputPDF = "C:\TEMP\" & "QF XXX(" & FName & ")" & TODA & "(" & [FT] & ")-" & TOD & ".pdf"
Call AddSigBoxes
Exit Sub
Error1:
MsgBox "Please select records first."
End Sub
Public Sub AddSigBoxes()
Dim App As Object, AVdoc As Object, AForm As Object, PDSaveFull As Object
Dim TODA As String, FName As String, FT As String, Path As String, js As String, Cord As String
'On Error GoTo Err_Handler
TODA = DLookup("[TODA]", "[QryTAR]")
FT = DLookup("[FTCode]", "[QryTAR]")
FName = DLookup("[FNames]", "[QryTAR]")
Cord = "[218," & 281 & ",394," & 226 & "]"
' LFT BTM RT Top
Path = "C:\TEMP\" & "QF XXX(" & FName & ")" & TODA & "(" & [FT] & ")-" & TOD & ".pdf"
Set App = CreateObject("Acroexch.app")
App.Hide
Set AVdoc = CreateObject("AcroExch.AVDoc")
Set AForm = CreateObject("AFormAut.App")
If AVdoc.Open(Path, "") Then
js = "f = this.addField(""SignatureField2"", ""signature"", 0, " & Cord & ");" & "f.value = ""Approval""; " & "f.flatten"
AForm.Fields.ExecuteThisJavaScript js
Set AForm = AVdoc.GetPDDoc
AForm.Save PDSaveFull, Path
AVdoc.Close False
End If
App.Exit
Set App = Nothing
Set AVdoc = Nothing
Set AForm = Nothing
Path = ""
Exit_Proc:
Exit Sub
Err_Handler:
MsgBox "Error: " & Err.Number & " - " & Err.Description & " You need Adobe Pro."
Resume Exit_Proc
End Sub
Public Sub SendTAR_Click()
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookAttach As Outlook.Attachment
Dim objOutlookRecip As Outlook.Recipient
Dim GrpEMails As Variant
Dim TODA As String, FNames As String, FName As String, PName As String, FT As String, GT As String, EmailSub As String
TODA = DLookup("[TODA]", "[QryTAR]")
FT = DLookup("[FTCode]", "[QryTAR]")
GT = DLookup("[GNDTVL]", "[QryTAR]")
EmailSub = DLookup("[EmailSub]", "[QryTAR]")
FName = DLookup("[FNames]", "[QryTAR]")
If PAXCheck = True Then
FNames = DLookup("[FNames]", "[QryTAR]") & "-" & DLookup("[PName]", "[QryCostComp]")
Else
FNames = DLookup("[FNames]", "[QryTAR]")
End If
Call ExportTARRpt_Click
Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
.Subject = "QF XXX (" & [FNames] & ") " & EmailSub
.Body = "Please verify the attached is correct." & vbCrLf & vbCrLf & vbCrLf & SigBlock
If GT = True Then
.Attachments.Add ("C:\TEMP\" & "CostComp(" & [FNames] & ")" & [TODA] & "(" & [FT] & ")-" & TOD & ".xlsx") ', AccessMode:=xlExclusive, ConflictResolution:=xlLocalSessionChanges
End If
.Attachments.Add ("C:\TEMP\" & "QF XXX(" & FName & ")" & TODA & "(" & [FT] & ")-" & TOD & ".pdf")
.To = "Alfredo.Ramirez@serco-na.com"
.Display
End With
' Kill ("C:\TEMP\" & "QF XXX(" & FName & ")" & TODA & "(" & [FT] & ")-" & TOD & ".pdf")
On Error Resume Next
Kill ("C:\TEMP\" & "CostComp(" & [FNames] & ")" & [TODA] & "(" & [FT] & ")-" & TOD & ".xlsx")
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
Set objOutlookAttach = Nothing
Call CloseRpt_Click
End Sub