FreePDF unter MSAccess
======================

Um Unter MS Access einen Bericht in ein PDF zu wandeln muss etwas Aufwand betrieben werden:

- Bei einem RTF Export werden nur Text, keine Grafiken exportiert

Eine mglichkeit, unter Access einen Bericht in ein PDF zu wandeln ist:

O Legen Sie einen neuen Drucker namens "AccessBericht" mit dem Druckertreiber 
  "Apple Color LW 12/660 PS" und einem Anschluss "Local Port" mit der Bezeichnung
  "C:\Temp\Bericht.ps" an.

O Legen Sie drei Module an und verwenden Sie den untenstehenden Code:

Ablauf:
=======

1. Bericht ffnen

2. Aktuellen Standart Drucker zurcksichern

3. Standart-Drucker auf "AccessBericht" setzen

4. Bericht durcken

5. Standart Drucker auf ursprnglichen Drucker setzen

6. Bericht schlieen

7. Bericht mit ps2pdf umwandeln

(8. Bericht in einer neuen Email ffnen)


#################################################################################################
Code:
#################################################################################################

#################################################################################################
1. Funktion, die den Bericht ffnet und in ein PDF umwandelt
   Modul Bericht1
#################################################################################################
Function EmailFormAsPDF(Email_adr As String)
'Diese Funktion hat hnlich schon einmal funktioniert, wurde aber von mir 
'abgendert. Die Funktionen ps2pdf, GetDefaulPrinter und SetDefaultPrinter
'sollten jedoch funktionieren. Da ich selbst normal kein VBA Programmiere
'kennen Sie sich vermutlich besser mit den Access Funktionen DoCMD.* aus.
'(Stefan Heinz, http://shbox.de)
'
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim Betreff As String: Betreff = "Access Report as PDF"
Dim Nachricht As String, An As String, ATT1, ATT2
Dim db As Database, rs As Recordset
Dim OldPrinter As String
  
  'Verzeichnis erstellen und Berichte reinschieben
  On Error Resume Next
  MkDir "C:\temp"
  On Error GoTo Er
  
  'Bericht Anzeigen
  DoCmd.OpenReport "Berichtname", acViewPreview

  'Berichte ausgeben    
  OldPrinter = GetDefaultPrinter           'Windows Standarddrucker merken
  SetDefaultPrinter "AccessBericht"        'Windows Standarddrucker auf "AccessBericht" setzen
  DoCmd.PrintOut acPrintAll, , , acHigh, 1 'Drucken, Drucker erstellt Datei C:\Temp\Bericht.ps
  SetDefaultPrinter OldPrinter             'Originalen Widnows Standarddrucker wiederherstellen

  'Bericht schlieen
  DoCmd.Close acReport, stDocName, acSavePrompt
  
  'PDF erzeugen
  ps2PDF "C:\temp\Ber_verz\Bericht.ps", "C:\temp\Ber_verz\Bericht.pdf"
  

  'Outlook Email senden
  ATT1 = "C:\temp\Ber_verz\Bericht.pdf"

  'Email Text
  Nachricht = "Bitte beiliegendes PDF ffnen."
  
  'Mailobjekt erstellen
  Set objOutlook = CreateObject("Outlook.Application")
  Set objOutlookMsg = objOutlook.CreateItem(0)
    
  With objOutlookMsg
    'Durch alle Empfnger
    An = "Test@test.de"
    .Recipients.Add An
   'Inhalt des Mails festlegen
    .Importance = 1 ' normale prioritt
    .Subject = Betreff
    '#.HTMLBody = Nachricht   'HTML-Format
    .Attachments.Add ATT1 'Berichte anhngen
    '#.Attachments.Add ATT2
    For Each objOutlookRecip In .Recipients
      objOutlookRecip.Resolve 'Namen berprfen
    Next
    .Display 'Nachricht wird angezeigt
    '#.Send   'Nachricht wird sofort gesendet
  End With

Ex:
  On Error Resume Next
  rs.Close
  Set objOutlook = Nothing
  'Verzeichnis und Dateien werden gelscht
  Kill "C:\temp\bericht.ps"
  Kill "C:\temp\bericht.pdf"
  Exit Function
  
Er:
  MsgBox Err.Description
  Resume Ex
End Function

#################################################################################################
2. ps2pdf
   Modul ps2pdf1
#################################################################################################
Option Compare Database
Option Explicit

'ps2psd Modul by Stefan Heinz, http://shbox.de
'
'Convert PostScript File to PDF using FreePDF XP (http://shbox.de)
'
'This Module can be used and changed in any way.
'
'Call the ps2PDF function in this way:
'x = ps2pdf("C:\temp\test.ps", "C:\temp\test.pdf")

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function OpenProcess Lib "kernel32" _
      (ByVal dwDesiredAccess As Long, _
      ByVal bInheritHandle As Long, _
      ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
      (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
      (ByVal hObject As Long) As Long

Public Function ps2PDF(psFile As String, pdfFile As String) As Boolean
If Dir(psFile) <> "" Then
    Dim FreePDF
    'FreePDF festlegen
    FreePDF = Environ("programfiles") & "\freepdf_xp\freepdf.exe"
    'Prfen, ob FreePDF vorhanden ist
    If Dir(FreePDF) <> "" Then
        'FreePDF aufrufen
        If ShellAndWait(FreePDF & " /3 delps,end ""eBook"" " & """" & pdfFile & """ """ & psFile & """") = 0 Then
            'Aufruf erfolgreich
            ps2PDF = True
        End If
    Else
        MsgBox "FreePDF ist nicht unter " & FreePDF & " installiert", vbExclamation
    End If
End If
End Function


Private Function ShellAndWait(Befehl As String) As Integer ', Optional WindowStyle As VbAppWinStyle = vbNormalFocus
'Needed by ps2pdf
Dim hProcess As Long
Dim ProcessId As Long
Dim exitCode As Long
Dim x, y

ProcessId = Shell(Befehl, vbNormalFocus)
hProcess = OpenProcess(&H400, False, ProcessId)

Do  'Warten auf Ende der Konvertierung
    Call GetExitCodeProcess(hProcess, exitCode)
    '0,5 Sekunden Warten:
    DoEvents
    Sleep 500
Loop While exitCode = &H103&

Call CloseHandle(hProcess)

ShellAndWait = exitCode
End Function

#################################################################################################
3. Standart Drucker auslesen und setzen:
   Modul Printer1
#################################################################################################
Option Compare Database
Option Explicit

'************************
' Printer setup module
' Set/retrieves the default printer - originaly for VB6
' Works for A97/a2000
' This is minimal code.
' Albert D.Kallal - 01/13/2002
' Rev history:       Date           Who                   notes
'                    01/13/2002     Albert D. kallal
'
' I wrote this after looking at some the code on the net. Some of the routines
' to change a printer were approaching 500 + of lines of code. Just the printer
' constant defs was over 100 lines of code! Yikes!
' I use only TWO API's (the 3rd one is optional). There is a total of only 4 functions!
' KISS is the word. Keep it simple stupid. I don't care about device drivers, or the
' port number. All these routines just work with the simple printer name. If you do
' actually care about the device driver and port stuff..then use the one of many
' examples available on the net. Those other examples also deal with margins, orientation
' etc.
'
' You can paste this code into a module..and away you go
'
'************************
' How to use
' To get the default printer
'        debug.print   GetDefaultPrinter
' To set the default printer
'        debug.print SetDefaultPrinter("HP Laser JET")
'  above returns true if success.
' To get a list of printers suitable for a listbox, or combo
'        debug.print GetPrinters
'
' that is all there folks!
'
' Thus, when printing a report, you can:
'
'       1) save the default printer into a string
'              strCurrentPtr = GetDefaultPrinter
'       2) switch to your report printer
'              SetDefaultPrinter strReportsPtr
'       3) print report
'       4) switch back to the default printer
'              SetDefaultPrinter strCurrentPtr
'
' Download von http://www.attcanada.net/~kallal.msn/msaccess/msaccess.html

Private Const HWND_BROADCAST As Long = &HFFFF&
Private Const WM_WININICHANGE As Long = &H1A

' The following code allows one to read, and write to the WIN.INI files
' In win 2000 the printer settings are actually in the registry. However, windows
' handles this correctly
'
Private Declare Function GetProfileString Lib "kernel32" _
   Alias "GetProfileStringA" _
  (ByVal lpAppName As String, _
   ByVal lpKeyName As String, _
   ByVal lpDefault As String, _
   ByVal lpReturnedString As String, _
   ByVal nSize As Long) As Long

Private Declare Function WriteProfileString Lib "kernel32" _
   Alias "WriteProfileStringA" _
  (ByVal lpszSection As String, _
   ByVal lpszKeyName As String, _
   ByVal lpszString As String) As Long

Private Declare Function SendMessage Lib "user32" _
   Alias "SendMessageA" _
  (ByVal hwnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lparam As Any) As Long
   
         

Private Function fstrDField(mytext As String, delim As String, groupnum As Integer) As String

   ' this is a standard delimiter routine that every developer I know has.
   ' This routine has a million uses. This routine is great for splitting up
   ' data fields, or sending multiple parms to a openargs of a form
   '
   '  Parms are
   '        mytext   - a delimited string
   '        delim    - our delimiter (usually a , or / or a space)
   '        groupnum - which of the delimited values to return
   '
   
Dim startpos As Integer, endpos As Integer
Dim groupptr As Integer, chptr As Integer

chptr = 1
startpos = 0
 For groupptr = 1 To groupnum - 1
    chptr = InStr(chptr, mytext, delim)
    If chptr = 0 Then
       fstrDField = ""
       Exit Function
    Else
       chptr = chptr + 1
    End If
 Next groupptr
startpos = chptr
endpos = InStr(startpos + 1, mytext, delim)
If endpos = 0 Then
   endpos = Len(mytext) + 1
End If

fstrDField = Mid$(mytext, startpos, endpos - startpos)

End Function

Function SetDefaultPrinter(strPrinterName As String) As Boolean

   Dim strDeviceLine As String
   Dim strBuffer     As String
   Dim lngbuf        As Long
    
  ' get the full device string
  '
   strBuffer = Space(1024)
   lngbuf = GetProfileString("PrinterPorts", strPrinterName, "", strBuffer, Len(strBuffer))
  
  'Write out this new printer information in
  ' WIN.INI file for DEVICE item
  If lngbuf > 0 Then
     
     strDeviceLine = strPrinterName & "," & _
                     fstrDField(strBuffer, Chr(0), 1) & "," & _
                     fstrDField(strBuffer, Chr(0), 2)
                     
     Call WriteProfileString("windows", "Device", strDeviceLine)
     SetDefaultPrinter = True
     
     ' Below is optional, and should be done. It updates the existing windows
     ' so the "default" printer icon changes. If you don't do the below..then
     ' you will often see more than one printer as the default! The reason *not*
     ' to do the SendMessage is that many open applications will now sense the change
     ' in printer. I vote to leave it in..but your case you might not want this.
     '
     
     Call SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, ByVal "windows")
    
  Else
     SetDefaultPrinter = False
  End If
       
End Function

Function GetDefaultPrinter() As String

   Dim strDefault    As String
   Dim lngbuf        As Long

   strDefault = String(255, Chr(0))
   lngbuf = GetProfileString("Windows", "Device", "", strDefault, Len(strDefault))
   If lngbuf > 0 Then
      GetDefaultPrinter = fstrDField(strDefault, ",", 1)
   Else
      GetDefaultPrinter = ""
   End If

End Function


Function GetPrinters() As String
   
   ' this routine returns a list of printers, separated by
   ' a ";", and thus the results are suitable for stuffing into a combo box
   
   Dim strBuffer  As String
   Dim strOnePtr  As String
   Dim intPos     As Integer
   Dim lngChars   As Long
   
   strBuffer = Space(2048)
   lngChars = GetProfileString("PrinterPorts", vbNullString, "", strBuffer, Len(strBuffer))
   
   If lngChars > 0 Then
      intPos = InStr(strBuffer, Chr(0))
     Do While intPos > 1
        strOnePtr = Left(strBuffer, intPos - 1)
        strBuffer = Mid(strBuffer, intPos + 1)
        If GetPrinters <> "" Then GetPrinters = GetPrinters & ";"
        GetPrinters = GetPrinters & strOnePtr
        intPos = InStr(strBuffer, Chr(0))
     Loop
   Else
      GetPrinters = ""
   End If
   
 End Function

Public Function testPrintersGet()

   Debug.Print GetDefaultPrinter
   Debug.Print GetPrinters
   
   
End Function
