Output Access Reports to PDF Writer 4

[GammelNok]

I would like to write a number of Records to PDF format, ie one record at a time into individual files. Creating the new filenames is not a problem, but how do I write the new filename to the Print Dialog and close it through code.
Whenever I print to PDF, it insists on manual intervention.
PS have tried SendKeys to no awail.
Gratefull for any help
Regards

Hans

 

[GHolden]

If you go to this link...

http://www.pdfzone.com/resources/tips/tip0022.html

it explains how to edit either the win.ini file or pdf.ini file to prevent these window from showing. The only down side is that all the pdf's you create will have the default name (specified in the ini file) so you have to do some extra code to move and rename the file after printing.

There are two ways to write error-free programs; only the third one works.

 

[GammelNok]

Thanks, I'll have a go

 

[Rockaway]

Option Compare Database
Option Explicit

Const MAX_SIZE = 255
Const MAX_SECTION = 2048

Dim pdfPath As String

Declare Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" (ByVal strAppName As String, ByVal strKeyName As String, ByVal strValue As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Declare Function GetVersion Lib "kernel32" () As Long
Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal strAppName As String, ByVal strKeyName As String, ByVal strDefault As String, ByVal strReturned As String, ByVal lngSize As Long) As Long

Type prnDevice
drDeviceName As String
drDriverName As String
drPort As String
End Type

Function GetDefaultPrinter(dr As prnDevice) As Boolean
'*******************************************
'Purpose: Get the default printer
'Date: 10-oct-2002, 12:04:50
'Called by:
'Calls: GetToken(), GetINIString()
'Inputs: ?GetDefaultPrinter(dr)
'*******************************************
Dim strBuffer As String

strBuffer = GetINIString("Windows", "Device&quot
If Len(strBuffer) > 0 Then
With dr
.drDeviceName = GetToken(strBuffer, ",", 1)
.drDriverName = GetToken(strBuffer, ",", 2)
.drPort = GetToken(strBuffer, ",", 3)
End With
GetDefaultPrinter = True
Else
GetDefaultPrinter = False
End If
End Function

Function GetINIString(ByVal strGroup As String, ByVal strItem As String) As Variant
'*******************************************
'Purpose: Get a string value from the WIN.INI file, from the register
'Author: A126423
'Date: 10-oct-2002, 12:02:47
'Called by: GetDefaultPrinter
'Calls: GetProfileString
'Inputs: ? GetINIString("Windows", "Device&quot
'*******************************************
Dim intChars As Integer
Dim strBuffer As String

strBuffer = String(MAX_SIZE, 0)
intChars = GetProfileString(strGroup, strItem, "", strBuffer, MAX_SIZE)
GetINIString = Left(strBuffer, intChars)
End Function

Function GetToken(ByVal strValue As String, ByVal strDelimiter As String, ByVal intPiece As Integer) As Variant
'*******************************************
'Date: 10-oct-2002, 12:08:25
'Called by: GetDefaultPrinter
'Inputs: ? GetToken(strBuffer, ",", 1)
'Output: "Acrobat PDFWriter"
'*******************************************
Dim intPos As Integer
Dim intLastPos As Integer
Dim intNewPos As Integer

On Error GoTo GetTokenExit

' Make sure the delimiter is just one character.
strDelimiter = Left(strDelimiter, 1)

' If the delimiter doesn't occur at all, or if
' the user's asked for a negative item, just return the item
' they passed in.

If (InStr(strValue, strDelimiter) = 0) Or (intPiece <= 0) Then
GetToken = strValue
Else
intPos = 0
intLastPos = 0
Do While intPiece > 0
intLastPos = intPos
intNewPos = InStr(intPos + 1, strValue, strDelimiter)
If intNewPos > 0 Then
intPos = intNewPos
intPiece = intPiece - 1
Else
' Catch the last piece, where there's no
' trailing token.
intPos = Len(strValue) + 1
Exit Do
End If
Loop
If intPiece > 1 Then
GetToken = Null
Else
GetToken = Mid$(strValue, intLastPos + 1, intPos - intLastPos - 1)
End If
End If

GetTokenExit:
Exit Function

GetTokenErr:
MsgBox &quot;Error in GetToken: &quot; & Error & &quot; (&quot; & Err & &quot&quot;
Resume GetTokenExit
End Function

Function SetDefaultPrinter(dr As prnDevice) As Boolean
'*******************************************
'Purpose: Set the default printer
'Date: 10-oct-2002, 12:11:59
'Called by: SendToPDF(),...
'Calls: WriteProfileString() [aht_apiWriteProfileString]
'Inputs: Call SetDefaultPrinter(dr)
'Output: False/True
'*******************************************

' Set the default printer device in Win.INI
' In:
' dr: a aht_tagDeviceRec structure to use as the source of information.
' Out:
' Return Value: True if set correctly, False otherwise.
' If successful, writes a string in the form:
' device=HP LaserJet 4,HPPCL5E,LPT1:
' to your Win.INI file.
'
' Requires the aht_apiWriteProfileString() declaration
' Requires type definitions

Dim strBuffer As String

' Build up the appropriate string.
strBuffer = dr.drDeviceName & &quot;,&quot;
strBuffer = strBuffer & dr.drDriverName & &quot;,&quot;
strBuffer = strBuffer & dr.drPort

' Now write that string out to WIN.INI.
SetDefaultPrinter = (WriteProfileString(&quot;Windows&quot;, &quot;Device&quot;, strBuffer) <> 0)

End Function

Function OSVersion() As Boolean
'Purpose: Identify OS
'Date: 10-oct-2002, 12:28:17
'Called by: WriteIniFile
'Calls: GetVersion()
'Inputs: If OSVersion Then ...
'Output: True/False
'*******************************************
Dim nOSMajorVersion As Integer
Dim nOSMinorVersion As Integer

Dim versionNum As Long
Dim temp As Long

On Error Resume Next

nOSMajorVersion = 0
nOSMinorVersion = 0

versionNum = GetVersion()
If ((versionNum And &H80000000) = 0) Then

nOSMajorVersion = versionNum And &HFF
temp = (versionNum - (versionNum And &HFFFF0000)) / 256
nOSMinorVersion = temp

If (nOSMajorVersion > 4) Then 'WinNT4/2000
OSVersion = True
Exit Function
End If

If (nOSMajorVersion = 3) Then
OSVersion = False
Exit Function
End If
Else
OSVersion = False
Exit Function
End If

End Function

Sub WriteIniFile(key As String, value As String)
'*******************************************
'Purpose: Write in the registry, the default name for the Acrobat file
'Date: 10-oct-2002, 12:26:23
'Called by:
'Calls: OSVersion, WritePrivateProfileString
'Inputs: WriteIniFile &quot;PDFFilename&quot;, pdfPath & codOwner & &quot;0.pdf&quot;
'*******************************************
Dim svPDFIni As String
If OSVersion Then
svPDFIni = &quot;c:\winnt\system32\spool\drivers\w32x86\2\__pdf.ini&quot; 'CARE: Windows NT
Else
svPDFIni = &quot;c:\windows\system\pdfwritr.ini&quot; 'CARE: Windows 95/98
End If

Call WritePrivateProfileString(&quot;Acrobat PDFWriter&quot;, key, value, svPDFIni)
End Sub


'Call Print_To_PDF(.dat01.Column(1), &quot;Report&quot;, &quot;_tmp\&quot
Function Print_To_PDF(rptName As String, FileName As String, URL As String)
'*******************************************
'Purpose:
'Date: octubre 24, 2001, 10:13:15
'*******************************************
Dim dr As prnDevice
Dim s0 As String, s1 As String, s2 As String
Dim pdfApp As Object

pdfPath = CurrentDBDir & URL & &quot;\&quot; ' &quot;_tmp\&quot;

If GetDefaultPrinter(dr) Then
s0 = dr.drDeviceName
s1 = dr.drDriverName
s2 = dr.drPort
End If

With dr
.drDeviceName = &quot;Acrobat PDFWriter&quot;
'.drDeviceName = &quot;Acrobat Distiller&quot;
.drDriverName = &quot;winspool&quot;
.drPort = &quot;LPT1:&quot;
End With

' set default printer to &quot;Acrobat PDFWriter&quot;
Call SetDefaultPrinter(dr)

' write the pdf file
Set pdfApp = CreateObject(&quot;Acroexch.app&quot

If Dir(pdfPath & FileName & &quot;*.*&quot <> &quot;&quot; Then 'if pdf doc exist
If URL = &quot;_tmp\&quot; Then Kill pdfPath & rptName & &quot;*.*&quot; 'del it
End If

DoCmd.Hourglass True

WriteIniFile &quot;PDFFilename&quot;, pdfPath & FileName & &quot;.pdf&quot;
DoCmd.OpenReport rptName, acViewNormal

Set pdfApp = Nothing

' restore default printer
With dr
.drDeviceName = s0
.drDriverName = s1
.drPort = s2
End With

Call SetDefaultPrinter(dr)

DoCmd.Hourglass False

End Function

Function CurrentDBDir() As String
'*******************************************
'Name: CurrentDBDir (Function)
'Purpose: Devuelve el directorio de trabajo, donde está ubicada la BD
'Author: U500026@u50000@cm
'Date: mayo 11, 2001, 09:28:05
'Output: string: &quot;k:\project\ovempr\&quot;
'*******************************************
Dim strDBPath As String
Dim strDBFile As String
strDBPath = CurrentDb.Name
strDBFile = Dir(strDBPath)
CurrentDBDir = Left(strDBPath, Len(strDBPath) - Len(strDBFile))
End Function

 

[GammelNok]

Thanks
This look promising
I'll let you know
Hans

 

[SgtJarrow]

Also look at faq703-2533....it is all set and ready to go for what you are looking to do. Please remember to give helpful posts the stars they deserve!
This makes the post more visible to others in need!

Robert L. Johnson III, A+, Network+, MCP
Access Developer/Programmer
robert.l.johnson.iii@citigroup.com

 

[GammelNok]

To mstrmage1768
Thanks for that
That worked a treat
What I would like to know now, is how to
Either
close the PDF Report through code, so I can loop through a whole recordset, producing 1 report per Record
Or Just create the report without actualy seing the result

Regards
Hans

 

[SgtJarrow]

Unfortunately I am unsure......mine never opens when I try it.

Are you previewing the report?? If so, try taking that section out....all you need is the SaveReportAsPDF sub call. It should not even open for you to see. Please remember to give helpful posts the stars they deserve!
This makes the post more visible to others in need!

Robert L. Johnson III, A+, Network+, MCP
Access Developer/Programmer
robert.l.johnson.iii@citigroup.com

 

[GammelNok]

Fixed it. I had to open a report and print to PDF Writer, to get to the 'Preview File' Tickbox. Once that was unticked, things worked a treat
Cheers
You have made my week
Hans