Sim,
Crie um formulário tabular que ficará mais fácil a visualização das alterações. Crie também um relatório que servirá de base para a criação do documento em PDF.
Baixe os arquivos da internet: StrStorage.dll e dynapdf.dll
Coloque esses arquivos na pasta onde está seu arquivo .mdb ou .accdb
Coloque uma caixa de texto em seu formulário com a fonte de controle ="NomedoSeuRelatorio"
Dê um nome a esta caixa de texto: lstRptName
Código do botão que gerará o arquivo em PDF:
No evento Click de seu botão no formulário:
Dim blRet As Boolean
blRet = ConvertReportToPDF(Me.lstRptName, vbNullString, _
Me.lstRptName.Value & ".pdf", False, True, 0, "", "", 0, 0)
Por fim, crie um módulo que contenha a função ConvertReportToPDF:
Dê o nome de : modReportToPDF
Cole este código que eu acredito que seja do Stephen Lebans no ambiente de código deste módulo:
Não fique pasmado pois ele é bem longo.
Public Declare Function ConvertUncompressedSnapshot Lib "StrStorage.dll" _
(ByVal UnCompressedSnapShotName As String, _
ByVal OutputPDFname As String, _
Optional ByVal CompressionLevel As Long = 0, _
Optional ByVal PasswordOwner As String = "", _
Optional ByVal PasswordOpen As String = "", _
Optional ByVal PasswordRestrictions As Long = 0, _
Optional PDFNoFontEmbedding As Long = 0 _
) As Boolean
Private Declare Function ShellExecuteA Lib "shell32.dll" _
(ByVal hWnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" _
Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" _
(ByVal hLibModule As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName _
Lib "kernel32" Alias "GetTempFileNameA" _
(ByVal lpszPath As String, _
ByVal lpPrefixString As String, _
ByVal wUnique As Long, _
ByVal lpTempFileName As String) As Long
Private Declare Function SetupDecompressOrCopyFile _
Lib "setupAPI" _
Alias "SetupDecompressOrCopyFileA" ( _
ByVal SourceFileName As String, _
ByVal TargetFileName As String, _
ByVal CompressionType As Integer) As Long
Private Declare Function SetupGetFileCompressionInfo _
Lib "setupAPI" _
Alias "SetupGetFileCompressionInfoA" ( _
ByVal SourceFileName As String, _
TargetFileName As String, _
SourceFileSize As Long, _
DestinationFileSize As Long, _
CompressionType As Integer _
) As Long
'Compression types
Private Const FILE_COMPRESSION_NONE = 0
Private Const FILE_COMPRESSION_WINLZA = 1
Private Const FILE_COMPRESSION_MSZIP = 2
Private Const Pathlen = 256
Private Const MaxPath = 256
' Allow user to set FileName instead
' of using API Temp Filename or
' popping File Dialog Window
Private mSaveFileName As String
' Full path and name of uncompressed SnapShot file
Private mUncompressedSnapFile As String
' Name of the Report we ' working with
Private mReportName As String
' Instance returned from LoadLibrary calls
Private hLibDynaPDF As Long
Private hLibStrStorage As Long
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 PasswordOwner As String = "", _
Optional PasswordOpen As String = "", _
Optional PasswordRestrictions As Long = 0, _
Optional PDFNoFontEmbedding As Long = 0 _
) As Boolean
Dim s As String
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", _
"Lamento...não é possível descomprimir o arquivo SnapShot" & vbCrLf & _
"Por favor selecione um Relatório para exportar"
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()
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, PasswordOwner, PasswordOpen, PasswordRestrictions, PDFNoFontEmbedding)
If blRet = False Then
err.Raise vbObjectError 526, "ConvertReportToPDF.ConvertUncompressedSnaphot", _
"Lamento...arquivo SnapShot danificado" & vbCrLf & _
"Por favor selecione um relatório diferente para exportar"
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
Private Function LoadLib() As Boolean
Dim s As String
Dim blRet As Boolean
On Error Resume Next
LoadLib = False
' If we aready loaded then free the library
If hLibDynaPDF <> 0 Then
hLibDynaPDF = FreeLibrary(hLibDynaPDF)
End If
' Our error string
s = "Lamento...não é possível encontrar o arquivo DynaPDF.dll" & vbCrLf
s = s & "Por favor copie o arquivo DynaPDF.dll para a sub-pasta System32 da pasta Windows ou dentro da mesma pasta deste Access MDB."
' OK Try to load the DLL assuming it is in the Window System folder
hLibDynaPDF = LoadLibrary("DynaPDF.dll")
If hLibDynaPDF = 0 Then
' See if the DLL is in the same folder as this MDB
' CurrentDB works with both A97 and A2K or higher
hLibDynaPDF = LoadLibrary(CurrentDBDir() & "DynaPDF.dll")
If hLibDynaPDF = 0 Then
MsgBox s, vbOKOnly, "MISSING DynaPDF.dll FILE"
LoadLib = False
Exit Function
End If
End If
' Our error string
s = "Lamento...não é possível encontrar o arquivo StrStorage.dll" & vbCrLf
s = s & "Por favor copie o arquivo StrStorage.dll para a sub-pasta System32 da pasta Windows ou dentro da mesma pasta deste Access MDB."
' ** Commented out for Debugging only - Must be active
' ***************************************************************************
'
' OK Try to load the DLL assuming it is in the Window System folder
hLibStrStorage = LoadLibrary("StrStorage.dll")
If hLibStrStorage = 0 Then
' See if the DLL is in the same folder as this MDB
' CurrentDB works with both A97 and A2K or higher
hLibStrStorage = LoadLibrary(CurrentDBDir() & "StrStorage.dll")
If hLibStrStorage = 0 Then
MsgBox s, vbOKOnly, "MISSING StrStorage.dll FILE"
Exit Function
End If
End If
' RETURN SUCCESS
LoadLib = True
End Function
'******************** Code Begin ****************
'Code courtesy of
'Terry Kreft & Ken Getz
'
Private Function CurrentDBDir() As String
Dim strDBPath As String
Dim strDBFile As String
strDBPath = CurrentDb.Name
strDBFile = Dir(strDBPath)
CurrentDBDir = Left$(strDBPath, Len(strDBPath) - Len(strDBFile))
End Function
'******************** Code End ****************
Private Function GetUniqueFilename(Optional path As String = "", _
Optional Prefix As String = "", _
Optional UseExtension As String = "") _
As String
' originally Posted by Terry Kreft
' to: comp.Databases.ms -Access
' Subject: Re: Creating Unique filename ??? (Dev code)
' Date: 01/15/2000
' Author: Terry Kreft
' SL Note: Input strings must be NULL terminated.
' Here it is done by the calling function.
Dim wUnique As Long
Dim lpTempFileName As String
Dim lngRet As Long
wUnique = 0
If path = "" Then path = CurDir
lpTempFileName = String(MaxPath, 0)
lngRet = GetTempFileName(path, Prefix, _
wUnique, lpTempFileName)
lpTempFileName = Left(lpTempFileName, _
InStr(lpTempFileName, Chr(0)) - 1)
Call Kill(lpTempFileName)
If Len(UseExtension) > 0 Then
lpTempFileName = Left(lpTempFileName, Len(lpTempFileName) - 3) & UseExtension
End If
GetUniqueFilename = lpTempFileName
End Function
Private Function fFileDialog() As String
' Calls the API File Save Dialog Window
' Returns full path to new File
On Error GoTo Err_fFileDialog
' Call the File Common Dialog Window
Dim clsDialog As Object
Dim strTemp As String
Dim strFName As String
Set clsDialog = New clsCommonDialog
' Fill in our structure
' I'll leave in how to select Gif and Jpeg to
' show you how to build the Filter in case you want
' to use this code in another project.
clsDialog.Filter = "PDF (*.PDF)" & Chr$(0) & "*.PDF" & Chr$(0)
'clsDialog.Filter = clsDialog.Filter & "Gif (*.GIF)" & Chr$(0) & "*.GIF" & Chr$(0)
'clsDialog.Filter = "ALL (*.*)" & Chr$(0) & "*.*" & Chr$(0)
clsDialog.hDC = 0
clsDialog.MaxFileSize = 256
clsDialog.Max = 256
clsDialog.FileTitle = vbNullString
clsDialog.DialogTitle = "Please Select a path and Enter a Name for the PDF File"
clsDialog.InitDir = vbNullString
clsDialog.DefaultExt = vbNullString
' Display the File Dialog
clsDialog.ShowSave
' See if user clicked Cancel or even selected
' the very same file already selected
strFName = clsDialog.FileName
'If Len(strFname & vbNullString) = 0 Then
' Raise the exception
' Err.Raise vbObjectError 513, "clsPrintToFit.fFileDialog", _
'"Please type in a Name for a New File"
'End If
' Return File Path and Name
fFileDialog = strFName
Exit_fFileDialog:
err.Clear
Set clsDialog = Nothing
Exit Function
Err_fFileDialog:
fFileDialog = ""
MsgBox err.Description, vbOKOnly, err.Source & ":" & err.Number
Resume Exit_fFileDialog
End Function
Public Function fFileDialogSnapshot() As String
' Calls the API File Open Dialog Window
' Returns full path to existing Snapshot File
On Error GoTo Err_fFileDialog
' Call the File Common Dialog Window
Dim clsDialog As Object
Dim strTemp As String
Dim strFName As String
Set clsDialog = New clsCommonDialog
' Fill in our structure
' I'll leave in how to select Gif and Jpeg to
' show you how to build the Filter in case you want
' to use this code in another project.
clsDialog.Filter = "SNAPSHOT (*.SNP)" & Chr$(0) & "*.SNP" & Chr$(0)
'clsDialog.Filter = "ALL (*.*)" & Chr$(0) & "*.*" & Chr$(0)
clsDialog.hDC = 0
clsDialog.MaxFileSize = 256
clsDialog.Max = 256
clsDialog.FileTitle = vbNullString
clsDialog.DialogTitle = "Please Select a Snapshot File"
clsDialog.InitDir = vbNullString
clsDialog.DefaultExt = vbNullString
' Display the File Dialog
clsDialog.ShowOpen
' See if user clicked Cancel or even selected
' the very same file already selected
strFName = clsDialog.FileName
If Len(strFName & vbNullString) = 0 Then
' Do nothing. Add your desired error logic here.
End If
' Return File Path and Name
fFileDialogSnapshot = strFName
Exit_fFileDialog:
err.Clear
Set clsDialog = Nothing
Exit Function
Err_fFileDialog:
fFileDialogSnapshot = ""
MsgBox err.Description, vbOKOnly, err.Source & ":" & err.Number
Resume Exit_fFileDialog
End Function
Public Function fFileDialogSavePDFname() As String
' Calls the API File Open Dialog Window
' Returns full path to existing Snapshot File
On Error GoTo Err_fFileDialog
' Call the File Common Dialog Window
Dim clsDialog As Object
Dim strTemp As String
Dim strFName As String
Set clsDialog = New clsCommonDialog
' Fill in our structure
' I'll leave in how to select Gif and Jpeg to
' show you how to build the Filter in case you want
' to use this code in another project.
clsDialog.Filter = "PDF (*.PDF)" & Chr$(0) & "*.PDF" & Chr$(0)
'clsDialog.Filter = "ALL (*.*)" & Chr$(0) & "*.*" & Chr$(0)
clsDialog.hDC = 0
clsDialog.MaxFileSize = 256
clsDialog.Max = 256
clsDialog.FileTitle = vbNullString
clsDialog.DialogTitle = "Please Select a name for the PDF File"
clsDialog.InitDir = vbNullString
clsDialog.DefaultExt = vbNullString
' Display the File Dialog
clsDialog.ShowOpen
' See if user clicked Cancel or even selected
' the very same file already selected
strFName = clsDialog.FileName
If Len(strFName & vbNullString) = 0 Then
' Do nothing. Add your desired error logic here.
End If
' Return File Path and Name
fFileDialogSavePDFname = strFName
Exit_fFileDialog:
err.Clear
Set clsDialog = Nothing
Exit Function
Err_fFileDialog:
fFileDialogSavePDFname = ""
MsgBox err.Description, vbOKOnly, err.Source & ":" & err.Number
Resume Exit_fFileDialog
End Function
Última edição por good guy em 24/4/2012, 20:36, editado 1 vez(es)
Início
RobertsonSaraiva 24/4/2012, 12:04
