Option Compare Database
Option Explicit

'DEVELOPED AND TESTED UNDER MICROSOFT ACCESS 2000 through A2003
' Can be converted to A97 but you must modify the RelationSip window Blob
' structures to the A97 specific versions. You can find these structure declarations
' in the RelationShip Views project on my site.
'
'Copyright: Stephen Lebans - Lebans Holdings 1999 Ltd.

' Version 7.75
' Added Merge function to merge 2 PDF documents
'
' ******************************************************
#Const ConDebug = 1   ' Set to 1 to force loading of DEBUG StrStorage.DLL
#If (ConDebug = 1) Then

' This is where I screwed up the Font Embedding. Forgot to declare PDFNoFontEmbedding as ByVal!
    Public Declare Function ConvertUncompressedSnapshot Lib "C:\WINDOWS\System32\StrStorage.dll" _
    (ByVal UnCompressedSnapShotName As String, _
    ByVal OutputPDFname As String, _
    Optional ByVal CompressionLevel As Long = 0, _
    Optional ByVal PasswordOpen As String = "", _
    Optional ByVal PasswordOwner As String = "", _
    Optional ByVal PasswordRestrictions As Long = 0, _
    Optional ByVal PDFNoFontEmbedding As Long = 0, _
    Optional ByVal PDFUnicodeFlags As Long = 0 _
    ) As Boolean


    Public Declare Function DrawTableWindow Lib "C:\WINDOWS\System32\StrStorage.dll" _
    (ByVal TableName As String, _
    ByVal Fields As String, _
    ByVal NumFields As Long, _
    ByVal Xpos As Double, _
    ByVal Ypos As Double, _
    ByVal Width As Double, _
    ByVal Height As Double _
    ) As Long

    Public Declare Function DrawLine Lib "C:\WINDOWS\System32\StrStorage.dll" _
    (ByVal Width As Double, _
    ByVal Width1 As Double, _
    ByVal Xpos As Double, _
    ByVal Ypos As Double, _
    ByVal Xpos1 As Double, _
    ByVal Ypos1 As Double, _
    ByVal Attrib As Long _
    ) As Long


    Public Declare Function BeginPDF Lib "C:\WINDOWS\System32\StrStorage.dll" _
    (ByVal PDFfilename As String, _
    ByVal PageWidth As Long, _
    ByVal PageHeight As Long _
    ) As Long

    Public Declare Function EndPDF Lib "C:\WINDOWS\System32\StrStorage.dll" _
    () As Long

    Public Declare Function MergePDFDocuments Lib "C:\WINDOWS\System32\StrStorage.dll" _
    (ByVal PDFMaster As String, _
    ByVal PDFChild As String _
    ) As Boolean




#Else


' This is where I screwed up the Font Embedding. Forgot to declare PDFNoFontEmbedding as ByVal!
Public Declare Function ConvertUncompressedSnapshot Lib "StrStorage.dll" _
    (ByVal UnCompressedSnapShotName As String, _
    ByVal OutputPDFname As String, _
    Optional ByVal CompressionLevel As Long = 0, _
    Optional ByVal PasswordOpen As String = "", _
    Optional ByVal PasswordOwner As String = "", _
    Optional ByVal PasswordRestrictions As Long = 0, _
    Optional ByVal PDFNoFontEmbedding As Long = 0, _
    Optional ByVal PDFUnicodeFlags As Long = 0 _
    ) As Boolean
    
    
    Public Declare Function DrawTableWindow Lib "StrStorage.dll" _
    (ByVal TableName As String, _
    ByVal Fields As String, _
    ByVal NumFields As Long, _
    ByVal Xpos As Double, _
    ByVal Ypos As Double, _
    ByVal Width As Double, _
    ByVal Height As Double _
    ) As Long
    
    Public Declare Function DrawLine Lib "StrStorage.dll" _
    (ByVal Width As Double, _
    ByVal Width1 As Double, _
    ByVal Xpos As Double, _
    ByVal Ypos As Double, _
    ByVal Xpos1 As Double, _
    ByVal Ypos1 As Double, _
    ByVal Attrib As Long _
    ) As Long
    
    
    Public Declare Function BeginPDF Lib "StrStorage.dll" _
    (ByVal PDFfilename As String, _
    ByVal PageWidth As Long, _
    ByVal PageHeight As Long _
    ) As Long
    
    Public Declare Function EndPDF Lib "StrStorage.dll" _
    () As Long
    
    Public Declare Function MergePDFDocuments Lib "StrStorage.dll" _
    (ByVal PDFMaster As String, _
    ByVal PDFChild As String _
    ) As Boolean
    

#End If

'

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

' Note: I converted the Enums to Constants to allow for use in Access 97.

'Enum TDocumentInfo 'Coming Soon!
 '  diAuthor
 '  diCreator
 '  diKeywords
 '  diProducer
 '  diSubject
 '  diTitle
 '  diCompany
 '  diPDFX_Ver ' GetInDocInfo() only -> The PDF/X version is set by SetPDFVersion()!
 '  diCustom   ' User defined key
'End Enum

'Enum TKeyLen
   Public Const kl40bit = 0    '  40 bit RC4 encryption (Acrobat 3 or higher)
   Public Const kl128bit = 1 ' 128 bit RC4 encryption (Acrobat 5 or higher)
   Public Const kl128bitEx = 2 ' 128 bit RC4 encryption (Acrobat 6 or higher)
'End Enum

'Enum TRestrictions
  Public Const rsDenyNothing = 0
  Public Const rsDenyAll = 3900
  Public Const rsPrint = 4
  Public Const rsModify = 8
  Public Const rsCopyObj = 16
  Public Const rsAddObj = 32
  ' 128 bit encryption only -> these values are ignored if 40 bit encryption is used
  Public Const rsFillInFormFields = 256
  Public Const rsExtractObj = 512
  Public Const rsAssemble = 1024
  Public Const rsPrintHighRes = 2048
  Public Const rsExlMetadata = 4096      ' PDF 1.5 -> can be used with kl128bitEx only
'End Enum



'Public Type POINTAPI
'   x As Long
'   Y As Long
'End Type

'Public Type RECTL
'   Left As Long
'   Top As Long
'   Right As Long
'   Bottom As Long
'End Type


Public Const AAAlength = 12
Public Const FFFlength = 8
Public Const Padding = 12
Public Const NameLengthMax = 128
' 64 Char MAX for a DAO Table Name * 2 = Unicode

' 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 = False, _
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 mReportName As String

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 mUncompressedSnapFile 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, "Snapshot Format", _
       strPathandFileName
    'debug.print "ok " & acOutputReport, RptName
    
    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
    myerror "sOutFile = fFileDialog()"
    'sOutFile = BrowseFolder
    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", _
    "Неправильный формат SnapShot File" & vbCrLf & _
    "Операция не завершена"
    '"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
Kill mUncompressedSnapFile
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

' *** Please Note ***
' If you are going to process many reports at once then to improve performance you
' should only call LoadLib once.

' May 16/2008
' Always look in the folder where this MDB resides First before checking the System folder.

LoadLib = False

' If we aready loaded then free the library
If hLibDynaPDF <> 0 Then
    hLibDynaPDF = FreeLibrary(hLibDynaPDF)
End If


' Our error string
S = "Sorry...cannot find the DynaPDF.dll file" & vbCrLf
S = S & "Please copy the DynaPDF.dll file into the same folder as this Access MDB or your Windows System32 folder."

' OK Try to load the DLL assuming it 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
    ' OK Try to load the DLL assuming it is in the Window System folder
    hLibDynaPDF = LoadLibrary("DynaPDF.dll")
End If

If hLibDynaPDF = 0 Then
    MsgBox S, vbOKOnly, "MISSING DynaPDF.dll FILE"
    LoadLib = False
    Exit Function
End If



'' ** Commented out for Debugging only - Must be active
'' ***************************************************************************
'
' Load StrStorage.DLL
' If we aready loaded then free the library
If hLibStrStorage <> 0 Then
    hLibStrStorage = FreeLibrary(hLibStrStorage)
End If


' Our error string
S = "Не найдена библиотека StrStorage.dll file" & vbCrLf
S = S & "Обратитесь к Администртору"

' OK Try to load the DLL assuming it 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
    ' OK Try to load the DLL assuming it is in the Window System folder
    hLibStrStorage = LoadLibrary("StrStorage.dll")
End If

If hLibStrStorage = 0 Then
    MsgBox S, vbOKOnly, "Ошибка библиотеки" ' StrStorage.dll"
    LoadLib = False
    Exit Function
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 <terry.kreft@mps.co.uk>

' 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

Public Function RepToPdf(srepname$, spdfname$, Optional DistinationTo$ = "", Optional Show As Boolean = False) As Byte
Dim blRet
Dim S$
Dim bResult As Byte
bResult = 0 '1 - Перезаписать 2- отменить 3- показать
On Error GoTo errpdf
If DistinationTo <> "" Then
'Существует ли заданная папка

    If Len(Dir(DistinationTo, vbDirectory)) = 0 Then
      '  DistinationTo = Left$(DistinationTo, 2): GoTo 1
        S = "Папка по умолчанию " & DistinationTo & " не найдена. Выберите папку для сохранения файла PDF"
    Else
        S = "Выберите папку для сохранения файла PDF"
    End If
        

  '      DistinationTo = fnShellBrowseForFolderVB(0, S, 1, DistinationTo)
        DistinationTo = FixPath(DistinationTo)
        DistinationTo = BrowseForFolderByPath(DistinationTo, S) & "\"
            If DistinationTo = "" Or DistinationTo = "\" Then 'НАЖАТА ОТМЕНА
                RepToPdf = 2 'ОТМЕНИТЬ
                Exit Function
            End If
            If Len(Dir(DistinationTo & spdfname & ".pdf")) > 0 Then 'файл существует
            Select Case MsgBox("Файл " & DistinationTo & spdfname & ".pdf" & " существует." & vbCrLf & _
            "Создан " & FileDateTime(DistinationTo & spdfname & ".pdf") & vbCrLf & _
            "Перезаписать? (Отмена - открыть для просмотра)", vbYesNoCancel, S_vnim)
                Case vbYes:
                    bResult = 1 'ПЕРЕЗАПИСАТЬ
                Case vbNo:
                    RepToPdf = 2 'ОТМЕНИТЬ
                    Exit Function
                Case vbCancel:
                'ShellExecuteA Application.hWndAccessApp, "open", sDirpdf & spdf, vbNullString, vbNullString, 1
                    FHLinkOpen DistinationTo & spdfname & ".pdf"
                    RepToPdf = 3 'показать
                    Exit Function
                End Select
            End If
    RepToPdf = bResult
End If  'пишем в заданную папку
    'Проверка доступа
    On Error Resume Next
    blRet = Dir(DistinationTo & spdfname & ".pdf")
    If Err.Number = 52 Then
        MsgBox "К папке " & DistinationTo & vbCr & "отказано в доступе", vbExclamation & vbOKOnly, S_error
    Exit Function
    End If
    If DistinationTo = "" Then DistinationTo = CurrentProject.path & "\"
    'ПИШЕМ*****************
    blRet = ConvertReportToPDF(srepname, vbNullString, _
    DistinationTo & spdfname & ".pdf", , True, 150, "", "", 0, 0, 0)
    '**********************
    'debug.print "" & blRet, Dir(DistinationTo & spdfname & ".pdf")
    ' To modify the above call to force the File Save Dialog to select the name and path
    ' for the saved PDF file simply change the ShowSaveFileDialog param to TRUE.
Exit Function
errpdf:
myerror " PDF "
End Function

'Пример:
Public Sub tst()
RepToPdf "Rep1", "ИМЯ ФАЙЛА", "С:\Обмен\", True 
End Sub