Hi
I am trying to make something that I have cobbled together run a little more efficiently.
I have coded a deferred send time - what I would like to do is pass this from the form.
So I would like 2 boxes date/time to start delivering and a seconds delay box.
I have tried a couple of guesses but got nowhere near.
A few pointers would be very help please and thank you.
Rob
I am trying to make something that I have cobbled together run a little more efficiently.
I have coded a deferred send time - what I would like to do is pass this from the form.
So I would like 2 boxes date/time to start delivering and a seconds delay box.
I have tried a couple of guesses but got nowhere near.
A few pointers would be very help please and thank you.
Rob
Code:
Private Sub Command1_Click()
' Define Variables
Dim strPath As String
Dim strPathEmail As String
Dim Year As String
Dim Month As String
Dim Day As String
Dim FileName As String
Dim rs As DAO.Recordset
Dim sql As String
Dim strDirectoryPath1 As String
Dim strDirectoryPath2 As String
Dim strDirectoryPath3 As String
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
x = Now()
strPathEmail = "C:\Temp\Email Receipts\"
Year = Format(Now(), "yy")
Month = Format(Now(), "mm")
Day = Format(Now(), "dd")
strDirectoryPath1 = "Q:\Receipts Archive\"
strDirectoryPath2 = strDirectoryPath1 + "\" + Format(Now(), "yyyy")
strDirectoryPath3 = strDirectoryPath2 + "\" + Format(Now(), "mm")
If Dir(strDirectoryPath1, vbDirectory) = "" Then
MkDir (strDirectoryPath1)
End If
If Dir(strDirectoryPath2, vbDirectory) = "" Then
MkDir (strDirectoryPath2)
End If
If Dir(strDirectoryPath3, vbDirectory) = "" Then
MkDir (strDirectoryPath3)
End If
strPath = strDirectoryPath3 & "\"
FileName = "Receipt" & Year & Month & Day
' Pull Data from eGlobal tables
DoCmd.SetWarnings False
DoCmd.OpenQuery "Update BCH_BRANCH", , acReadOnly
DoCmd.OpenQuery "Update CAC_CLIENT_ACCOUNTING_FILE", , acReadOnly
DoCmd.OpenQuery "Update CLI_CLIENT", , acReadOnly
DoCmd.OpenQuery "Update IBO_INSURERBRANCH", , acReadOnly
DoCmd.OpenQuery "Update ICA_INSURER_ACCOUNTING", , acReadOnly
DoCmd.OpenQuery "Update PLY_POLICY", , acReadOnly
DoCmd.OpenQuery "Update RCP_RECEIPTS", , acReadOnly
DoCmd.OpenQuery "Update RI_RISK", , acReadOnly
DoCmd.OpenQuery "AppendRunRegister", , acReadOnly
DoCmd.OpenQuery "Update GSE_GENERICSCREENENTRIES", , acReadOnly
' Run Queries and Store Results in
DoCmd.OpenQuery "EmptyInsurerInfo", , acReadOnly
DoCmd.OpenQuery "EmptyReceiptsData", , acReadOnly
DoCmd.OpenQuery "Upd ReceiptsData", , acReadOnly
DoCmd.OpenQuery "Upd InsurerInfo", , acReadOnly
' Output the Archive
DoCmd.OutputTo acOutputReport, "Receipt", acFormatPDF, strPath & FileName & ".pdf"
' Print the Receipts
DoCmd.OpenQuery "MailFileOutput", , acReadOnly
DoCmd.SetWarnings True
sql = "SELECT DISTINCT ReceiptsData.CLI_CLIENTNUMBER, ReceiptsData.GSE_FIELD1 , ReceiptsData.GSE_FIELD2 , ReceiptsData.GSE_FIELD3 , ReceiptsData.GSE_FIELD4 , ReceiptsData.Servicer , ReceiptsData.Broker FROM ReceiptsData;"
Set rs = CurrentDb().OpenRecordset(sql, dbOpenSnapshot)
Do While Not rs.EOF
strCLICode = rs!CLI_CLIENTNUMBER
GSE_FIELD1 = rs!GSE_FIELD1
GSE_FIELD2 = rs!GSE_FIELD2
Salutation = rs!GSE_FIELD3
Email = rs!GSE_FIELD4
Servicer = rs!Servicer
Broker = rs!Broker
If GSE_FIELD1 = "Y" Then
DoCmd.OutputTo acOutputReport, "PrintedReceipt", acFormatPDF, strPathEmail & FileName & strCLICode & ".pdf"
'make new mail message
'make new mail message
SigString = "C:\Program Files\lotus\notes\data\IrlAccounts.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
x = x + TimeValue("00:01:00")
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
objOutlook.Session.Logon
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
Set OutApp = CreateObject("Outlook.Application")
With objOutlookMsg
If Not IsNull(Email) Then
Set objOutlookRecip = .Recipients.Add(Email)
objOutlookRecip.Type = olTo
Else
Set objOutlookRecip = .Recipients.Add("Blank@Blank.ie")
objOutlookRecip.Type = olTo
End If
' Set the Subject, Body, and Importance of the message.
.Subject = "Receipt Attached - Payment to Aon"
.HTMLBody = "<SPAN STYLE='font: 8pt Arial'>Dear " _
& Salutation & "<BR></BR><BR></BR>" & _
"Please find attached Receipt for payment recently made to the Aon Group " & " ." & "<BR></BR><BR></BR>" & _
"<b>" & "Any queries regarding the attached should be referred to irelandaccounts@aon.ie ." & "</b>" & "<BR></BR><BR></BR>" & _
"Kind Regards." & "<BR></BR><BR></BR>" & _
"Accounts Dept." & "<BR></BR><BR></BR>" & _
"</span>" & "<BR></BR>" & Signature & "<BR></BR><BR></BR>" & _
"<SPAN STYLE='font: 8pt Verdana'>" & _
"Client Code " & strCLICode & "<BR></BR>" & _
"Account Manager " & Servicer & "<BR></BR>" & _
"Broker " & Broker & "<BR></BR>" & _
"</span>"
.Importance = olImportanceHigh 'High importance
' Add attachments to the message.
If Not IsMissing(AttachmentPath) Then
AttachmentPath = strPathEmail & FileName & strCLICode & ".pdf"
Set objOutlookAttach = .Attachments.Add(AttachmentPath)
End If
For Each objOutlookRecip In .Recipients
Next
.DeferredDeliveryTime = x
.SendUsingAccount = OutApp.Session.Accounts.Item(2)
.Send
End With
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
Else
DoCmd.OpenReport "PrintedReceipt", acViewNormal, "", "", acNormal
End If
rs.MoveNext
Loop
Set rs = Nothing
' Shows a listing all receipst generated
DoCmd.OutputTo acOutputReport, "Receipts Printed for Date", acFormatPDF, strPath & FileName & "Listing" & ".pdf"
DoCmd.OpenReport "Receipts Printed for Date", acViewPreview, "", "", acNormal
