I want to generate a PDF file using VBA, I found some tools but I am not sure if it supports to generate in a table format. Or is there another third party tool(free) to generate an access form in PDF format?
Depending on what you want to export and what VBA application you are using you have a few options.
If you are exporting an access report then this is good (and free!) http://www.lebans.com/reporttopdf.htm
For most other things you can use a PDF print driver and push anything you want to export to the “printer”. There are a number of free and commercial options here so google is your friend
Stephen Leban's PDF export library was great for it's era, but that was many years ago, and the library is now not supported at all, which you can see from a quick visit to his web site. Fortunately, you can now use the built-in PDF export capabilities of Access. Here's an example:
DoCmd.OutputTo acOutputReport, "SimpleReport", acFormatPDF, "C:\Users\Paul\Documents\PDFTest01.pdf", False
I believe this works in Access 2007 and up; it definitely works with Access 2013. Here's a link to an MSDN forum post with more information.
Install a PDF print driver and use it to print out your sheet. For example, I have PDFCreator installed.
ActiveSheet.PrintOut ActivePrinter:="PDFCreator"
Warning: PDFCreator is free, but versions 0.9.7 and later come bundled with "tormentware". I have the cleaner version 0.9.6. Of course you can also install some other PDF driver.
The best way for you to create a PDF in Access is to first make the report in access.
The reason being that when you generate the report in Access first, you will have full control on exactly how you want the report to look like in PDF.
Assuming you know how to create reports in Access the following code will help you convert that report into a PDF that then allows the users to save the PDF accordingly.
Dim strReportName = "RptYourReportName" ' first quote in the name of the report you already created in access
Docmd.OpenReport strReportName, acViewPreview 'tell access to open up the report
Reports(strReportName).Visible = False
If Reports(strReportName).HasData then
Call ConverReportToPDF(strReportName,,"Give_Generic_Name.PDF",True,False)
End if
DoCmd.Close acReport, strReportName
Below is the Function that will convert your report - simply copy this into the modules part of your VBA code.
Hope this helps!!
Public Function ConvertReportToPDF( _
Optional RptName As String = "", _
Optional SnapshotName As String = "", _
Optional OutputPDFName As String = "", _
Optional ShowSaveFileDialog As Boolean = False, _
Optional StartPDFViewer As Boolean = True, _
Optional CompressionLevel As Long = 0, _
Optional PasswordOpen As String = "", _
Optional PasswordOwner As String = "", _
Optional PasswordRestrictions As Long = 0, _
Optional PDFNoFontEmbedding As Long = 0, _
Optional PDFUnicodeFlags As Long = 0 _
) As Boolean
' RptName is the name of a report contained within this MDB
' SnapshotName is the name of an existing Snapshot file
' OutputPDFname is the name you select for the output PDF file
' ShowSaveFileDialog is a boolean param to specify whether or not to display
' the standard windows File Dialog window to select an exisiting Snapshot file
' CompressionLevel - not hooked up yet
' PasswordOwner - not hooked up yet
' PasswordOpen - not hooked up yet
' PasswordRestrictions - not hooked up yet
' PDFNoFontEmbedding - Do not Embed fonts in PDF. Set to 1 to stop the
' default process of embedding all fonts in the output PDF. If you are
' using ONLY - any of the standard Windows fonts
' using ONLY - any of the standard 14 Fonts natively supported by the PDF spec
'The 14 Standard Fonts
'All version of Adobe's Acrobat support 14 standard fonts. These fonts are always available
'independent whether they're embedded or not.
'Family name PostScript name Style
'Courier Courier fsNone
'Courier Courier-Bold fsBold
'Courier Courier-Oblique fsItalic
'Courier Courier-BoldOblique fsBold + fsItalic
'Helvetica Helvetica fsNone
'Helvetica Helvetica-Bold fsBold
'Helvetica Helvetica-Oblique fsItalic
'Helvetica Helvetica-BoldOblique fsBold + fsItalic
'Times Times-Roman fsNone
'Times Times-Bold fsBold
'Times Times-Italic fsItalic
'Times Times-BoldItalic fsBold + fsItalic
'Symbol Symbol fsNone, other styles are emulated only
'ZapfDingbats ZapfDingbats fsNone, other styles are emulated only
Dim blRet As Boolean
' Let's see if the DynaPDF.DLL is available.
blRet = LoadLib()
If blRet = False Then
' Cannot find DynaPDF.dll or StrStorage.dll file
Exit Function
End If
On Error GoTo ERR_CREATSNAP
Dim strPath As String
Dim strPathandFileName As String
Dim strEMFUncompressed As String
Dim sOutFile As String
Dim lngRet As Long
' Init our string buffer
strPath = Space(Pathlen)
'Save the ReportName to a local var
mReportName = RptName
' Let's kill any existing Temp SnapShot file
If Len(mUncompressedSnapFile & vbNullString) > 0 Then
Kill mUncompressedSnapFile
mUncompressedSnapFile = ""
End If
' If we have been passed the name of a Snapshot file then
' skip the Snapshot creation process below
If Len(SnapshotName & vbNullString) = 0 Then
' Make sure we were passed a ReportName
If Len(RptName & vbNullString) = 0 Then
' No valid parameters - FAIL AND EXIT!!
ConvertReportToPDF = ""
Exit Function
End If
' Get the Systems Temp path
' Returns Length of path(num characters in path)
lngRet = GetTempPath(Pathlen, strPath)
' Chop off NULLS and trailing "\"
strPath = Left(strPath, lngRet) & Chr(0)
' Now need a unique Filename
' locked from a previous aborted attemp.
' Needs more work!
strPathandFileName = GetUniqueFilename(strPath, "SNP" & Chr(0), "snp")
' Export the selected Report to SnapShot format
DoCmd.OutputTo acOutputReport, RptName, "SnapshotFormat(*.snp)", _
strPathandFileName
' Make sure the process has time to complete
DoEvents
Else
strPathandFileName = SnapshotName
End If
' Let's decompress into same filename but change type to ".tmp"
'strEMFUncompressed = Mid(strPathandFileName, 1, Len(strPathandFileName) - 3)
'strEMFUncompressed = strEMFUncompressed & "tmp"
Dim sPath As String * 512
lngRet = GetTempPath(512, sPath)
strEMFUncompressed = GetUniqueFilename(sPath, "SNP", "tmp")
lngRet = SetupDecompressOrCopyFile(strPathandFileName, strEMFUncompressed, 0&)
If lngRet <> 0 Then
Err.Raise vbObjectError + 525, "ConvertReportToPDF.SetupDecompressOrCopyFile", _
"Sorry...cannot Decompress SnapShot File" & vbCrLf & _
"Please select a different Report to Export"
End If
' Set our uncompressed SnapShot file name var
mUncompressedSnapFile = strEMFUncompressed
' Remember to Cleanup our Temp SnapShot File if we were NOT passed the
' Snapshot file as the optional param
If Len(SnapshotName & vbNullString) = 0 Then
Kill strPathandFileName
End If
' Do we name output file the same as the input file name
' and simply change the file extension to .PDF or
' do we show the File Save Dialog
If ShowSaveFileDialog = False Then
' let's decompress into same filename but change type to ".tmp"
' But first let's see if we were passed an output PDF file name
If Len(OutputPDFName & vbNullString) = 0 Then
sOutFile = Mid(strPathandFileName, 1, Len(strPathandFileName) - 3)
sOutFile = sOutFile & "PDF"
Else
sOutFile = OutputPDFName
End If
Else
' Call File Save Dialog
sOutFile = fFileDialog(OutputPDFName)
If Len(sOutFile & vbNullString) = 0 Then
Exit Function
End If
End If
' Call our function in the StrStorage DLL
' Note the Compression and Password params are not hooked up yet.
blRet = ConvertUncompressedSnapshot(mUncompressedSnapFile, sOutFile, _
CompressionLevel, PasswordOpen, PasswordOwner, PasswordRestrictions, PDFNoFontEmbedding, PDFUnicodeFlags)
If blRet = False Then
Err.Raise vbObjectError + 526, "ConvertReportToPDF.ConvertUncompressedSnaphot", _
"Sorry...damaged SnapShot File" & vbCrLf & _
"Please select a different Report to Export"
End If
' Do we open new PDF in registered PDF viewer on this system?
If StartPDFViewer = True Then
ShellExecuteA Application.hWndAccessApp, "open", sOutFile, vbNullString, vbNullString, 1
End If
' Success
ConvertReportToPDF = True
EXIT_CREATESNAP:
' Let's kill any existing Temp SnapShot file
'If Len(mUncompressedSnapFile & vbNullString) > 0 Then
On Error Resume Next
Kill mUncompressedSnapFile
mUncompressedSnapFile = ""
'End If
' If we aready loaded then free the library
If hLibStrStorage <> 0 Then
hLibStrStorage = FreeLibrary(hLibStrStorage)
End If
If hLibDynaPDF <> 0 Then
hLibDynaPDF = FreeLibrary(hLibDynaPDF)
End If
Exit Function
ERR_CREATSNAP:
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
mUncompressedSnapFile = ""
ConvertReportToPDF = False
Resume EXIT_CREATESNAP
End Function
Related
My question is about opening the document file.
I want to give the choice to my user to choose where he wants to save his file.
However, I may be wrong but I use a FileDialog (msoFileDialogFolderPicker)
which opens the file normally and afterwards sends me an error message !! I start in programming thank you for help.
this my code
Public Function ObtenirCheminFichier(path As String)
Dim fso As Object
Dim filePath As String
Set fso = CreateObject("scripting.filesystemobject")
ObtenirCheminFichier = path
If Not fso.FileExists(path) Then
Dim tmpPath As String
tmpPath = Replace(Replace(path, ".\", "", , 1), "\", "", 1, 0)
'ObtenirCheminFichier = Application.FileDialog(msoFileDialogFolderPicker).Show()
' ObtenirCheminFichier = CurrentProject.path & "\" & tmpPath
ObtenirCheminFichier = Application.FileDialog(msoFileDialogFolderPicker) & "\" & tmpPath
End If
End Function
and i doubt error this
DoCmd.OutputTo acOutputQuery, "Categorie_C2_req", acSpreadsheetTypeExcel12, spath, True
Add .SelectedItems(1) after the folder picker like this:
Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
For further details about FileDialog object you can check this API
As you want to open a single file I suggest you to add this line before opening the file dialog: Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = False
I'm writing a VBA code to add files, which are into several folders, into a ZIP file.
This procedure should run automatically, by a scheduled job, and I try to add a parameter to force "yes to all".
In Microsoft support there are some constants but if I add to my code, I don't have the aspected result.
the code is the following
Public Sub ZipFolder(ZipFileName As Variant, _
FolderPath As Variant, _
Optional ByVal FileFilter As String, _
Optional ByVal Overwrite As Boolean = False)
Dim fso As Object, tf As Object
Dim strZIPHeader As String, sFile As String
On Error GoTo done
' create zip file header
strZIPHeader = Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, Chr(0))
With CreateObject("Shell.Application")
sFile = Dir(FolderPath, vbNormal)
Do Until sFile = vbNullString
.Namespace(ZipFileName).CopyHere FolderPath & sFile, **"&H10&"**
sFile = Dir
Loop
End With
Set fso = Nothing
Set tf = Nothing
done:
If Err.Number <> 0 Then MsgBox Err.Description, vbApplicationModal + vbInformation
End Sub
The parameter &H10& doesn't work. I have tried with "&0X14&" as well but same result.
Any idea?
Thank you
You can study the article and full code here on exactly this subject:
Zip and unzip files and folders with VBA the Windows Explorer way
You'll see, that shall the file be overwritten, it is simply deleted before proceeding:
If FileSystemObject.FileExists(ZipFile) Then
If Overwrite = True Then
' Delete an existing file.
FileSystemObject.DeleteFile ZipFile, True
' At this point either the file is deleted or an error is raised.
Else
ZipBase = FileSystemObject.GetBaseName(ZipFile)
' Modify name of the zip file to be created to preserve an existing file:
' "Example.zip" -> "Example (2).zip", etc.
Version = Version + 1
Do
Version = Version + 1
ZipFile = FileSystemObject.BuildPath(ZipPath, ZipBase & Format(Version, " \(0\)") & ZipExtension)
Loop Until FileSystemObject.FileExists(ZipFile) = False Or Version > MaxZipVersion
If Version > MaxZipVersion Then
' Give up.
Err.Raise ErrorPathFile, "Zip Create", "File could not be created."
End If
End If
End If
I have a word document that uses mail merge feature and gets its information from the access db. When I use this code it does not open the word document with the current information. It opens the word document with the last saved information.
If I open the word document on its own, from the task bar, it asks if I want to run the SQL and I click yes and everything operates normally. I want to click a button from within access to accomplish this same task to open the contract.
Here is the code I used:
Private Sub Command205_Click()
Dim LWordDoc As String
Dim oApp As Object
'Path to the word document
LWordDoc = "C:\Users\.....k Up\01- Proposal\contract.docx"
If Dir(LWordDoc) = "" Then
MsgBox "Document not found."
Else
'Create an instance of MS Word
Set oApp = CreateObject(Class:="Word.Application")
oApp.Visible = True
'Open the Document
oApp.Documents.Open FileName:=LWordDoc
End If
End Sub
***I should add that I am not a coder and know nothing about VBA, I copied this from this website so any help you can offer would be greatly appreciated. If you can provide me with coding or enough guidance to get me on the way would be great. Thank you
This code will run in Access to open a Mail Merge document and update content and save.
Using the link I originally posted (http://www.minnesotaithub.com/2015/11/automatic-mail-merge-with-vba-and-access/), I made a couple of modifications and was able to get that code to work.
I needed to add: ReadOnly:=True, _ to prevent a sharing violation
and I changed the Table Name of the source data.
NOTE!! You will need to change sode marked with'###' as follows:
###-1 Change to specify the full path of your TEMPLATE!!!
###-2 Change the SQLSTATEMENT to specify your recordsource!!!
Paste this code into your form, make sure you have a Command Button Click Event that executes (Either rename 'Command205' in this code, or change your control name).
Option Compare Database
Option Explicit
Private Sub Command205_Click()
Dim strWordDoc As String
'Path to the word document of the Mail Merge
'###-1 CHANGE THE FOLLOWING LINE TO POINT TO YOUR DOCUMENT!!
strWordDoc = "C:\Users\.....k Up\01- Proposal\contract.docx"
' Call the code to merge the latest info
startMerge strWordDoc
End Sub
'----------------------------------------------------
' Auto Mail Merge With VBA and Access (Early Binding)
'----------------------------------------------------
' NOTE: To use this code, you must reference
' The Microsoft Word 14.0 (or current version)
' Object Library by clicking menu Tools > References
' Check the box for:
' Microsoft Word 14.0 Object Library in Word 2010
' Microsoft Word 15.0 Object Library in Word 2013
' Click OK
'----------------------------------------------------
Function startMerge(strDocPath As String)
Dim oWord As Word.Application
Dim oWdoc As Word.Document
Dim wdInputName As String
Dim wdOutputName As String
Dim outFileName As String
' Set Template Path
wdInputName = strDocPath ' was CurrentProject.Path & "\mail_merge.docx"
' Create unique save filename with minutes and seconds to prevent overwrite
outFileName = "MailMergeFile_" & Format(Now(), "yyyymmddmms")
' Output File Path w/outFileName
wdOutputName = CurrentProject.Path & "\" & outFileName
Set oWord = New Word.Application
Set oWdoc = oWord.Documents.Open(wdInputName)
' Start mail merge
'###-2 CHANGE THE SQLSTATEMENT AS NEEDED
With oWdoc.MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource _
Name:=CurrentProject.FullName, _
ReadOnly:=True, _
AddToRecentFiles:=False, _
LinkToSource:=True, _
Connection:="QUERY mailmerge", _
SQLStatement:="SELECT * FROM [tblEmployee]" ' Change the table name or your query
.Destination = wdSendToNewDocument
.Execute Pause:=False
End With
' Hide Word During Merge
oWord.Visible = False
' Save file as PDF
' Uncomment the line below and comment out
' the line below "Save file as Word Document"
'------------------------------------------------
'oWord.ActiveDocument.SaveAs2 wdOutputName & ".pdf", 17
' Save file as Word Document
' ###-3 IF YOU DON'T WANT TO SAVE AS A NEW NAME, COMMENT OUT NEXT LINE
oWord.ActiveDocument.SaveAs2 wdOutputName & ".docx", 16
' SHOW THE DOCUMENT
oWord.Visible = True
' Close the template file
If oWord.Documents(1).FullName = strDocPath Then
oWord.Documents(1).Close savechanges:=False
ElseIf oWord.Documents(2).FullName = strDocPath Then
oWord.Documents(2).Close savechanges:=False
Else
MsgBox "Well, this should never happen! Only expected two documents to be open"
End If
' Quit Word to Save Memory
'oWord.Quit savechanges:=False
' Clean up memory
'------------------------------------------------
Set oWord = Nothing
Set oWdoc = Nothing
End Function
Can anyone give me the code to create a backup/copy of the Database when opening? it I know how to use autoexec macro i just need the code. The database name is Datenbank and the back to have the time of back in its name
That command could be:
FileCopy CurrentDb.Name, Replace(CurrentDb.Name, ".accdb", Format(Now(), " yyyymmdd hhnnss") & ".accdb")
but you can't do that for the database file itself from inside the application.
Your best option would be to create a shortcut that runs a script that copies the file first, then opens it.
Addendum
I located a function that will create a zipped backup of the current project:
Option Compare Database
Option Explicit
' API call for sleep function.
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Function ZipCurrentProject() As Long
Dim ShellApplication As Object
Dim CurrentProjectFile As String
Dim ZipPath As String
Dim ZipName As String
Dim ZipFile As String
Dim FileNumber As Integer
' File and folder names.
CurrentProjectFile = CurrentProject.Path & "\" & CurrentProject.Name
' The path must exist.
ZipPath = CurrentProject.Path & "\#dbase_bk" & Format(Now, " yyyy-mm-dd hh.nn.ss") & "\"
ZipName = "CCOLearningHub.zip"
ZipFile = ZipPath & ZipName
' Create sub folder if missing.
If Dir(ZipPath, vbDirectory) = "" Then
MkDir ZipPath
End If
' Create empty zip folder.
FileNumber = FreeFile
Open ZipFile For Output As #FileNumber
Print #FileNumber, Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, vbNullChar)
Close #FileNumber
Set ShellApplication = CreateObject("Shell.Application")
' Copy the project file into the zip file.
With ShellApplication
Debug.Print Timer, "zipping started ..."
.Namespace(CVar(ZipFile)).CopyHere CVar(CurrentProjectFile)
' Ignore error while looking up the zipped file before is has been added.
On Error Resume Next
' Wait for the file to created.
Do Until .Namespace(CVar(ZipFile)).Items.Count = 1
' Wait a little ...
'DoEvents
Sleep 100
Debug.Print " .";
Loop
Debug.Print
' Resume normal error handling.
On Error GoTo 0
Debug.Print Timer, "zipping finished."
End With
Set ShellApplication = Nothing
ZipCurrentProject = Err.Number
End Function
I'm using a script from Rob van der Woude for the open file dialog (top post from here) which is apparently supposed to work in HTA but I get an error saying:
"ActiveX component can't create object: 'UserAccounts.CommonDialog'"
This function may be helps you !
BrowseForFile.vbs
'**************************************************************************************
' GetFileDlg() And GetFileDlgBar() by omen999 - may 2014 - http://omen999.developpez.com
' Universal Browse for files function
' compatibility : all versions windows and IE - supports start folder, filters and title
' note : the global size of the parameters cannot exceed 191 chars for GetFileDlg and 227 chars for GetFileDlgBar
'**************************************************************************************
Function GetFileDlg(sIniDir,sFilter,sTitle)
GetFileDlg=CreateObject("WScript.Shell").Exec("mshta.exe ""about:<object id=d classid=clsid:3050f4e1-98b5-11cf-bb82-00aa00bdce0b></object><script>moveTo(0,-9999);function window.onload(){var p=/[^\0]*/;new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1).Write(p.exec(d.object.openfiledlg('" & sIniDir & "',null,'" & sFilter & "','" & sTitle & "')));close();}</script><hta:application showintaskbar=no />""").StdOut.ReadAll
End Function
Function GetFileDlgBar(sIniDir,sFilter,sTitle)
GetFileDlgBar=CreateObject("WScript.Shell").Exec("mshta.exe ""about:<object id=d classid=clsid:3050f4e1-98b5-11cf-bb82-00aa00bdce0b></object><script>moveTo(0,-9999);function window.onload(){var p=/[^\0]*/;new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1).Write(p.exec(d.object.openfiledlg('" & sIniDir & "',null,'" & sFilter & "','" & sTitle & "')));close();}</script>""").StdOut.ReadAll
End Function
' sample test
sIniDir = "C:\Windows\Fonts\*"
sFilter = "All files (*.*)|*.*|Microsoft Word (*.doc;*.docx)|*.doc;*.docx|Adobe pdf (*.pdf)|*.pdf|"
sTitle = "GetFileDlg by omen999 2014 - omen999.developpez.com"
' (sIniDir + sFilter + sTitle) size doesn't exceed 191 chars (227 for GetFileDlgBar)
' MsgBox Len(Replace(sIniDir,"\","\\")) + Len(sFilter) + Len(sTitle)
' sIniDir must be conformed to the javascript syntax
rep = GetFileDlg(Replace(sIniDir,"\","\\"),sFilter,sTitle)
MsgBox rep & vbcrlf & Len(rep)
As #JosefZ mentioned in the comments, the UserAccounts.CommonDialog library is available in Windows XP only. However, there are other ways to display an "Open File" dialog.
The Shell.Application object has a BrowserForFolder() function that, by default, displays a dialog asking you to select a folder. However, you can configure this dialog in a number of ways by using combinations of the ulFlags values. For example, if you include the BIF_BROWSEINCLUDEFILES flag, the dialog will also show files in addition to folders.
Here's a minimal example showing how you can have the BrowserForFolder dialog to display files and prompt the user to select a file:
' BROWSEINFO Flags...
Const BIF_NONEWFOLDERBUTTON = &H0200 ' Hide the [New Folder] button
Const BIF_BROWSEINCLUDEFILES = &H4000 ' Show files in addition to folders
' ShellSpecialFolderConstants...
Const ssfDESKTOP = 0
Dim objStartIn, objFile
With CreateObject("Shell.Application")
' Specify the folder the dialog should start in...
Set objStartIn = .NameSpace(ssfDESKTOP) ' Start in a special folder
Set objStartIn = .NameSpace("c:\") ' Or, start in custom path
' Args = (parent window, dialog title, flags, start folder)
Set objFile = .BrowseForFolder(0, "Select a file:", _
BIF_BROWSEINCLUDEFILES Or BIF_NONEWFOLDERBUTTON, objStartIn)
End With
If Not objFile Is Nothing Then
WScript.Echo objFile.Self.Path
End If
Of course, the user could still select a folder. There's no way to stop that from happening. But you can check the item returned to see if it's a folder and prompt them to reselect (perhaps in a loop).
If objFile.Self.IsFolder Then
' Invalid
End If