Access VBA save object Report.pdf to a specific path with a unique name - ms-access-2007

I'm familiar with VBA but I am not a programmer so any help I can get in this matter is greatly appreciated. I have a report object that is mailed as a .pdf file. This portion of the code works fine but I would like to be able to save a copy of this file to a specific location with a unique name that includes the date and time the file was created. The first set of code is the SendObject that works the second set of code does not work, it is a separate procedure I have been testing to save the object. Once I can get it working I was going to integrate it into first. I would appreciate any help.
Private Sub Command21_Click()
DoCmd.SetWarnings (False)
Dim mailto As String
Dim ccto As String
Dim bccto As String
mailto = "Safety-RiskGroup#bargeacbl.com"
ccto = ""
bccto = ""
emailmsg = "The attached document is the updated Case Log." & vbNewLine
& "Please review the report, contact me and you find any discrepancies. "&vbNewLine & vbNewLine & "Thank You, " & vbNewLine & vbNewLine & vbNewLine & "Cary S. WInchester" & vbNewLine & "American Commercial Barge Line" & vbNewLine & "Safety Department"
mailsub = "Updated Case Log Report"
On Error Resume Next
DoCmd.SendObject acSendReport, "rpt_CaseLog-CurrentYear", acFormatPDF, mailto, ccto, bccto, mailsub, emailmsg, True
DoCmd.SetWarnings (True)
End Sub
This is the second set of code to attempt to save the object to a specific path with a unique name.
Private Sub Command23_Click()
On Error GoTo Command23_Click_Err
Dim filePath As String
filePath = "C:\Work\ACBL\Access Dbase\DayCount" & "CaseLog" _
& Format(Date, " yyyy/mm/dd") _
& Format(Time, " hh:MM:ss") & ".pdf"
DoCmd.OutputTo acOutputReport, "rpt_CaseLog-CurrentYear", _
"PDFFormat(*.pdf)", filePath, _
False, "", , acExportQualityPrint
Command23_Click_Exit:
Exit Sub
Command23_Click_Err:
MsgBox Error$
Resume Command23_Click_Exit
End Sub

Thanks Bit Accesser but that was not the problem, the code was laid out as it should be; however, the Date and Time formats were using characters that could be used for a file name, specifically, the colons and the backslashes were causing it to fail. Below is the corrected code. There are a few other spots I tweaked but this works great.
Private Sub Command25_Click()
On Error GoTo Command25_Click_Err
Dim filePath As String
filePath = "C:\Work\ACBL\Access Dbase\DayCount\Reports\"
DoCmd.OutputTo acOutputReport, "rpt_CaseLog-CurrentYear", acFormatPDF, _
filePath & " Case Log Update" & Format(Now(), " dd-mm-yyyy hhmmss") & ".pdf"
Command25_Click_Exit:
Exit Sub
Command25_Click_Err:
MsgBox Error$
Resume Command25_Click_Exit
End Sub

Related

In Access how can I make the email address to send to conditional based on a table of contacts?

I set up a code to save each page of a report as a separate PDF with the file name being the "release number"
I was able to get it to email each file in a separate email to a single email address.
But I can't figure out how to have the email recipient be dependent on the field "account"?
I have a table called "Distribution list" with the fields "Company" (the account name) and "Email".
I want it to send to the corresponding email for each company/account.
How could I achieve this?
Private Sub Command11_Click()
Dim rs As DAO.Recordset
Dim sFolder As String
Dim sFile As String
Const sReportName = "BLreport2"
'Dim strTo As String
' Dim strMessage As String
'Dim strSubject As String
On Error GoTo Error_Handler
'The folder in which to save the PDFs
sFolder = Application.CurrentProject.Path & "\"
'Define the Records that you will use to filtered the report with
Set rs = CurrentDb.OpenRecordset("SELECT account, [release number], contents3 FROM selectedbols", dbOpenSnapshot)
With rs
If .RecordCount <> 0 Then 'Make sure we have record to generate PDF with
.MoveFirst
Do While Not .EOF
'Build the PDF filename we are going to use to save the PDF with
sFile = sFolder & Nz(![release number], "") & ".pdf"
'Open the report filtered to the specific record or criteria we want in hidden mode
DoCmd.OpenReport sReportName, acViewPreview, , "[release number]=" & ![release number], acHidden
'Print it out as a PDF
DoCmd.OutputTo acOutputReport, sReportName, acFormatPDF, sFile, , , , acExportQualityPrint
'Close the report now that we're done with this criteria
'strTo = test#gmail.com
' strSubject = "Your invoice"
'strMessage = "Please find the invoice attached"
'DoCmd.SendObject acSendReport, "BLreport2", acFormatPDF, _
strTo, , , strSubject, strMessage
DoCmd.Close acReport, sReportName
'If you wanted to create an e-mail and include an individual report, you would do so now
.MoveNext
Loop
End If
End With
'Open the folder housing the PDF files (Optional)
Application.FollowHyperlink sFolder
Error_Handler_Exit:
On Error Resume Next
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Exit Sub
Error_Handler:
If Err.Number <> 2501 Then 'Let's ignore user cancellation of this action!
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Command0_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
End If
Resume Error_Handler_Exit
End Sub

printing report to PDF based on each record in query

I have a query in Access (Q_Invoices) that has separate records based on the invoice number (Invoice_Number). I also have a report that is linking to this query (R_Invoices_PDF). What I would like to do is to have VBA code to loop through each record in the query, and print the record as a separate PDF from the report.
I copied the following code from some website, and tried to adapt it for my purposes. It works to an extent. However, I stop it before it loops, and it saves all the records, not just the first one.
Private Sub cmd_GenPDFs_Click()
Dim rs As DAO.Recordset
Dim sFolder As String
Dim sFile As String
On Error GoTo Error_Handler
sFolder = "D:\Documents\Orchestra\Invoices\Invoice files\"
Set rs = CurrentDb.OpenRecordset("SELECT Invoice_Number FROM Q_Invoices", dbOpenSnapshot)
With rs
.MoveFirst
Do While Not .EOF
DoCmd.OpenReport "R_Invoices_PDF", acViewPreview, , "[Invoice_Number]=" & ![Invoice_Number], acHidden
sFile = Nz(![Invoice_Number], "") & ".pdf"
sFile = sFolder & sFile
DoCmd.OutputTo acOutputReport, "R_Invoices_PDF", acFormatPDF, sFile, acExportQualityPrint
'If you wanted to create an e-mail and include an individual report, you would do so now
DoCmd.Close acReport, "R_Invoices_PDF"
.MoveNext
Loop
End With
Application.FollowHyperlink sFolder 'Optional / Open the folder housing the files
Error_Handler_Exit:
On Error Resume Next
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Exit Sub
Error_Handler:
If Err.Number <> 2501 Then 'Let's ignore user cancellation of this action!
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: cmd_GenPDFs_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
End If
Resume Error_Handler_Exit
End Sub
I recall some issue with filtering the report. Thus, we filter the query that drives the report to return only data for a single invoice using a TempVars.
Here, Faktura means Invoice:
Private Sub FakturaPrint( _
ByVal PrintType As CdPrintType, _
Optional ByRef FullPath As String)
Const ReportName As String = "Faktura"
Const FileNameMask As String = "Faktura{0}.pdf"
Const FileIdMask As String = "kladde Job {0}"
Const CancelError As Long = 2212 ' Cactus TimeSag cannot print the object.
Const PrintError As Long = 2501 ' PrintOut was cancelled.
Dim Path As String
Dim FileName As String
Dim FileId As String
Dim PrintCount As Integer
Dim PrintCopy As Integer
On Error GoTo FakturaPrint_Click_Error
' Set filter on the source query of the report.
TempVars("FakturaID").Value = Me!FaktID.Value
Select Case PrintType
Case cdPrintPreview
DoCmd.OpenReport ReportName, acViewPreview, , , acWindowNormal
Case cdPrintPrinter
PrintCount = Nz(Me!UdskFakt.Column(2), 1)
If PrintCount < 1 Then
PrintCount = 1
End If
For PrintCopy = 1 To PrintCount
DoCmd.OpenReport ReportName, acViewNormal, , , acWindowNormal
Next
Case cdPrintPdf
Path = Environ("USERPROFILE") & "\Documents\"
FileId = Nz(Str(Me!Faktura.Value), Replace(FileIdMask, "{0}", Me!JobID.Value))
FileName = Replace(FileNameMask, "{0}", FileId)
' Return FullPath by reference for e-mail.
FullPath = Path & FileName
DoCmd.OutputTo acOutputReport, ReportName, acFormatPDF, FullPath, False, , , acExportQualityPrint
End Select
FakturaPrint_Click_Exit:
Me!TextForClipboard.SetFocus
Exit Sub
FakturaPrint_Click_Error:
Select Case Err.Number
Case CancelError, PrintError
' Printing cancelled by user.
' Ignore.
Case Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FakturaPrint_Click of Sub Form_Faktura"
End Select
Resume FakturaPrint_Click_Exit
End Sub
It is not a loop, but you can probably easily abstract from that.

Find mailfolder in Outlook with Redemption

I try to find a folder in an Outlook account (I use Multiple accounts) using VBA and Redemption by using the FIND method but I cannot get it to work. On the Redemption webpage there is a reference made to an example and this may help but unfortunately the example isn't there.
Here's my code so far:
Public Function FindFolderRDO(strCrit As String) As String
If Not TempVars![appdebug] Then On Error GoTo Err_Proc
Dim objRdoSession As Redemption.RDOSession
Dim objRdoFolder As RDOFolder
Dim strFoundFolder As String
Dim objFoundFolder As RDOFolder
Dim strFolderName As String
Set objRdoSession = CreateObject("Redemption.RDOSession")
objRdoSession.Logon
objRdoSession.MAPIOBJECT = Outlook.Session.MAPIOBJECT
strFolderName = "\\[mailbox name]\[foldername]\[foldername]" 'actual names removed
Set objRdoFolder = objRdoSession.GetFolderFromPath(strFolderName)
Debug.Print objRdoFolder.Parent.Name 'Prints the folder name
Set objFoundFolder = objRdoFolder.Folders.Find("LIKE 'strCrit%' ") 'Does not work
Debug.Print objFoundFolder.Name
strFoundFOlder = objRdoFolder.Folders.Find("LIKE 'strCrit%' ") 'Does not work
Debug.Print strFoundFOlder
Exit_Proc:
On Error Resume Next
Set objRdoFolder = Nothing
Set objRdoSession = Nothing
Set objFoundFolder = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case Else
MsgBox "Error: " & CStr(Err.Number) & vbCrLf & _
"Desc: " & Err.Description & vbCrLf & vbCrLf & _
"Source: " & Err.Source & vbCrLf & _
"Library: " & Application.CurrentProject.Name & vbCrLf & _
"Module: Mod_RDO" & vbCrLf & _
"Function: FindFolderRDO" & vbCrLf, _
vbCritical, "Error"
End Select
Resume Exit_Proc
End Function
Purpose of this function is to find a subfolder (can be up to 4 dimensions deep) having an unique case number of 6 numbers (for example "200332") on the first 6 positions. This function should provide NULL if not found or the full path and the name of the found folder.
I can create the full path with a seperate function (calling the parent folder until top level) but maybe there is a procedure in Redemption such as "fullpath" which I overlooked.
Eventually I want to use this function to delete, move or rename the mailbox folder.
My main question is how to use the "Find(Filter)" method. But any reply on the full path is welcome as well.
Thx! Art.
You are you trying to find a suborder with a name that starts with "strCrit"?
You are almost there:
Set objFoundFolder = objRdoFolder.Folders.Find("Name LIKE 'strCrit%' ")

Get destination of save in DocumentBeforeSave

I have a template in which I want to display the document path in the footer just before a save happends.
I have got the DocumentBeforeSave Sub all ready and functioning but the problem is I seem to have no way to get the destination path for the document, unless i'm missing something.
Private WithEvents App As Word.Application
Private Sub App_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As Boolean, Cancel As Boolean)
' UPDATE FOOTER HERE '
End Sub
I first thought that maybe the parameter Doc contained the destination, but I've only found the current directory.
The problem is only when doing a 'Save As', otherwise the footer don't need changing.
By now you know you need to save as a '.docm' if you have VBA code. Not that the following will do what you want, but it is an example of how to see the default save path, and the 'latest' save path for this document. I set it to display different messages (on close) if someone does a SaveAs.
Option Explicit
Dim strPath As String
Private Sub Document_Open()
MsgBox "On Open, default save path is: " & Options.DefaultFilePath(wdDocumentsPath)
strPath = ActiveDocument.Path
End Sub
Private Sub Document_Close()
If strPath <> ActiveDocument.Path Then
MsgBox "Document now in DIFFERENT path." & vbCrLf & _
"On Close, document was saved at: " & ActiveDocument.Path & vbCrLf & _
"Originally the document was in path: " & strPath
Else
MsgBox "Document still in same path." & vbCrLf & _
"On Close, document was saved at: " & ActiveDocument.Path & vbCrLf & _
"Full Path & Name: " & ActiveDocument.FullName
End If
End Sub

MSXML2.DOMDocument load function fails in VBA

I've been struggling with the below issue for a while now and couldn't find the solution yet.
There is an iShare page with an XML file that I want to download using VBA code, then later process the XML file and save into MS Access database.
I've been using the below code for about 4 years now, it worked perfectly without any issues. But suddenly it stopped working this week.
Any ideas why?
the code:
Private Function GetRequests() As Boolean
On Error GoTo ErrHandler
Dim oDoc As MSXML2.DOMDocument
Dim Url As String
Dim sFileName As String
Set oDoc = New MSXML2.DOMDocument
oDoc.async = False
Url = cUrlDatabase & "/" & cApplicationName & "/In/" & cReqXmlFile
UpdateStatus "Loading " & cReqXmlFile
If Not oDoc.Load(Url) Then
c_sLastError = "Could not load XML " & Url
GoTo EndProc
End If
sFileName = sPath & "\Data\requests.xml"
oDoc.Save sFileName
GetRequests = True
End Function
The code fails at the oDoc.Load(Url) part, it comes back false.
Here's an example of how to gather error details:
Dim xDoc As MSXML.DOMDocument
Set xDoc = New MSXML.DOMDocument
If xDoc.Load("C:\My Documents\cds.xml") Then
' The document loaded successfully.
' Now do something intersting.
Else
' The document failed to load.
Dim strErrText As String
Dim xPE As MSXML.IXMLDOMParseError
' Obtain the ParseError object
Set xPE = xDoc.parseError
With xPE
strErrText = "Your XML Document failed to load" & _
"due the following error." & vbCrLf & _
"Error #: " & .errorCode & ": " & xPE.reason & _
"Line #: " & .Line & vbCrLf & _
"Line Position: " & .linepos & vbCrLf & _
"Position In File: " & .filepos & vbCrLf & _
"Source Text: " & .srcText & vbCrLf & _
"Document URL: " & .url
End With
MsgBox strErrText, vbExclamation End If
Set xPE = Nothing
End If
Example taken from here.
For other people finding this post:
The xml parser by now has implemented different error types (see here).
You would have to use the following code
Set objXML = CreateObject("Msxml2.DOMDocument.6.0")
ObjXML.async=true
objXML.load "/path/to/xml"
If objXML.parseError.errorCode <> 0 Then
MsgBox "Error was " + objXML.parseError.reason
End If
This should help you debug your .xml file.
For anyone else struggling with this, I found this error to be caused by text encoded in a format which could not be parsed in VBA (some weird E symbol). The objXML was nothing after the .load. I'm sure there are many possible causes, but I'll share what I found in case this helps someone. Thanks to the guys above for the error handling routines.