Example of creating simple PDF on-the-fly from Access 97

[James Fortune]

Here is an example of Access creating a single page PDF file. The
text in the textbox is scaled to fit horizontally into a grey box 100
pixels wide that is fontsize pixels high. Clicking the command button
creates the pdf file. Be sure to close Acrobat Reader before creating
another file with the same name. Form code is followed by module
code. No stream compression or pdf linearization is used in this
example. Note that the special characters ( ) and \ cannot be used for
this implementation. They can be implemented by using the length of
the pretransformed string and having the transformation prepend '\' to
those characters. The name of the output file is C:\TestOutput.pdf.
You should have the form allow you to choose an output file location.
Enjoy.

'----------Code behind Form----------
Private Sub cmdGo_Click()
Dim strStream As String
Dim strFileName As String
Dim lngBytesSoFar As Long
Dim intXRefObjCount As Integer
Dim lngXREFByteCount As Long
Dim lngObjOffset(20) As Long
Dim dblFontSize As Double

lngBytesSoFar = 0
intXRefObjCount = 0
If IsNull(txtToOutput.Value) Then Exit Sub
'Fit text to gray box knowing Courier is Fixed Width Width = .6 *
FontSize * NumChars
dblFontSize = 100# / (0.6 * Len(txtToOutput.Value))
dblFontSize = Int(dblFontSize * 100# + 0.5) / 100#
strStream = "%Gray Box 100 pixels long" & Chr(13) & "q" & Chr(13) &
"0.93 g" & Chr(13) & "h" & Chr(13)
strStream = strStream & "250 602 m" & Chr(13) & "250 " & CStr(Int(602
+ dblFontSize)) & " l" & Chr(13) & "350 " & CStr(Int(602 +
dblFontSize)) & " l" & Chr(13) & "350 602 l" & Chr(13)
strStream = strStream & "h f Q" & Chr(13)
strStream = strStream & "%Some Text" & Chr(13)
strStream = strStream & "BT" & Chr(13)
strStream = strStream & "/F1 " & CStr(dblFontSize) & " Tf" & Chr(13)
strStream = strStream & "250 602 Td" & Chr(13)
strStream = strStream & "(" & txtToOutput.Value & ") Tj" & Chr(13)
strStream = strStream & "ET" & Chr(13)
strFileName = "C:\TestOutput.pdf"
Open strFileName For Output As #1
Print #1, AddHeader(lngBytesSoFar, intXRefObjCount, lngObjOffset())
Print #1, AddCatalog(lngBytesSoFar, intXRefObjCount, lngObjOffset())
Print #1, AddOutlines(lngBytesSoFar, intXRefObjCount, lngObjOffset())
Print #1, AddPages(lngBytesSoFar, intXRefObjCount, lngObjOffset())
Print #1, AddPage(lngBytesSoFar, intXRefObjCount, lngObjOffset())
Print #1, AddStream(lngBytesSoFar, intXRefObjCount, lngObjOffset(),
strStream)
Print #1, AddPSA(lngBytesSoFar, intXRefObjCount, lngObjOffset())
Print #1, AddFonts(lngBytesSoFar, intXRefObjCount, lngObjOffset())
Print #1, AddFont(lngBytesSoFar, "Courier", intXRefObjCount,
lngObjOffset())
'Save the byte count here in order to reference the start of the xref
table
lngXREFByteCount = lngBytesSoFar
Print #1, AddXREFTable(lngBytesSoFar, intXRefObjCount, lngObjOffset())
Print #1, AddTrailer(lngBytesSoFar, intXRefObjCount)
Print #1, AddStartXREF(lngBytesSoFar, lngXREFByteCount)
Print #1, AddEOF(lngBytesSoFar)
Close #1
MsgBox ("Done.")
End Sub
'----------End Code behind Form----------

'----------Begin Module Code----------
Option Compare Database
Option Explicit

Public Function AddCatalog(ByRef lngBytesSoFar As Long, ByRef
intXRefObjCount As Integer, lngObjOffset() As Long) As String
Dim strTemp As String
strTemp = "1 0 obj" & Chr(13) & " << /Type /Catalog" & Chr(13) & "
/Outlines 2 0 R" & Chr(13) & " /Pages 3 0 R" & Chr(13) & " >>" &
Chr(13) & "endobj" & Chr(13) & Chr(13)
intXRefObjCount = intXRefObjCount + 1
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
lngObjOffset(intXRefObjCount) = lngBytesSoFar
AddCatalog = strTemp
End Function
Public Function AddEOF(ByRef lngBytesSoFar As Long) As String
Dim strTemp As String
strTemp = "%%EOF" & Chr(13) & Chr(10)
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
AddEOF = strTemp
End Function
Public Function AddFont(ByRef lngBytesSoFar As Long, strFontName As
String, ByRef intXRefObjCount As Integer, lngObjOffset() As Long) As
String
Dim strTemp As String
strTemp = CStr(intXRefObjCount) & " 0 obj" & Chr(13) & " <<" &
Chr(13)
strTemp = strTemp & " /BaseFont/" & strFontName &
"/Type/Font/Name/F1" & Chr(13)
strTemp = strTemp & " /Encoding /WinAnsiEncoding" & Chr(13) & "
/Subtype/Type1" & Chr(13)
strTemp = strTemp & " >>" & Chr(13) & "endobj" & Chr(13) & Chr(13)
intXRefObjCount = intXRefObjCount + 1
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
lngObjOffset(intXRefObjCount) = lngBytesSoFar
AddFont = strTemp
End Function
Public Function AddFonts(ByRef lngBytesSoFar As Long, ByRef
intXRefObjCount As Integer, lngObjOffset() As Long) As String
Dim strTemp As String
strTemp = CStr(intXRefObjCount) & " 0 obj" & Chr(13) & " <<" &
Chr(13) & " /F1 8 0 R" & Chr(13) & " >>" & Chr(13) & "endobj" &
Chr(13)
intXRefObjCount = intXRefObjCount + 1
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
lngObjOffset(intXRefObjCount) = lngBytesSoFar
AddFonts = strTemp
End Function
Public Function AddHeader(ByRef lngBytesSoFar As Long, ByRef
intXRefObjCount As Integer, lngObjOffset() As Long) As String
Dim strTemp As String
strTemp = "%PDF-1.4%" & Chr(223) & Chr(204) & Chr(209) & Chr(192) &
"R" & Chr(221) & Chr(13) & Chr(13)
intXRefObjCount = intXRefObjCount + 1
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
lngObjOffset(intXRefObjCount) = lngBytesSoFar
AddHeader = strTemp
End Function
Public Function AddOutlines(ByRef lngBytesSoFar As Long, ByRef
intXRefObjCount As Integer, lngObjOffset() As Long) As String
Dim strTemp As String
strTemp = "2 0 obj" & Chr(13) & " << /Type /Outlines" & Chr(13) & "
/Count 0" & Chr(13) & " >>" & Chr(13) & "endobj" & Chr(13) & Chr(13)
intXRefObjCount = intXRefObjCount + 1
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
lngObjOffset(intXRefObjCount) = lngBytesSoFar
AddOutlines = strTemp
End Function
Public Function AddPage(ByRef lngBytesSoFar As Long, ByRef
intXRefObjCount As Integer, lngObjOffset() As Long) As String
Dim strTemp As String
strTemp = "4 0 obj" & Chr(13) & " << /Type /Page" & Chr(13) & "
/Parent 3 0 R" & Chr(13) & " /MediaBox [0 0 612 792]" & Chr(13) & "
/CropBox [0 0 612 792]" & Chr(13) & " /Rotate 0" & Chr(13)
strTemp = strTemp & " /Contents [ 5 0 R]" & Chr(13) & "
/Resources << /ProcSet 6 0 R" & Chr(13) & " /Font 7 0 R" & Chr(13)
strTemp = strTemp & " >>" & Chr(13) & " >>" & Chr(13) & "endobj" &
Chr(13) & Chr(13)
intXRefObjCount = intXRefObjCount + 1
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
lngObjOffset(intXRefObjCount) = lngBytesSoFar
AddPage = strTemp
End Function
Public Function AddPages(ByRef lngBytesSoFar As Long, ByRef
intXRefObjCount As Integer, lngObjOffset() As Long) As String
Dim strTemp As String
strTemp = "3 0 obj" & Chr(13) & " << /Type /Pages" & Chr(13) & "
/Kids [4 0 R]" & Chr(13)
strTemp = strTemp & " /Count 1" & Chr(13) & " >>" & Chr(13) &
"endobj" & Chr(13) & Chr(13)
intXRefObjCount = intXRefObjCount + 1
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
lngObjOffset(intXRefObjCount) = lngBytesSoFar
AddPages = strTemp
End Function
Public Function AddPSA(ByRef lngBytesSoFar As Long, ByRef
intXRefObjCount As Integer, lngObjOffset() As Long) As String
Dim strTemp As String
strTemp = "6 0 obj" & Chr(13) & " << /Procset [/PDF /Text] >>" &
Chr(13) & "endobj" & Chr(13) & Chr(13)
intXRefObjCount = intXRefObjCount + 1
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
lngObjOffset(intXRefObjCount) = lngBytesSoFar
AddPSA = strTemp
End Function
Public Function AddStartXREF(ByRef lngBytesSoFar As Long,
lngXREFByteCount As Long) As String
Dim strTemp As String
strTemp = "startxref" & Chr(13) & CStr(lngXREFByteCount) & Chr(13) &
Chr(13)
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
AddStartXREF = strTemp
End Function
Public Function AddStream(ByRef lngBytesSoFar As Long, ByRef
intXRefObjCount As Integer, lngObjOffset() As Long, strStream As
String) As String
Dim strTemp As String
strTemp = strTemp & CStr(intXRefObjCount) & " 0 obj" & Chr(13) & " <<
/Length " & CStr(Len(strStream)) & " >>" & Chr(13)
strTemp = strTemp & "stream" & Chr(13) & Chr(10) & strStream &
"endstream" & Chr(13) & "endobj" & Chr(13) & Chr(13)
intXRefObjCount = intXRefObjCount + 1
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
lngObjOffset(intXRefObjCount) = lngBytesSoFar
AddStream = strTemp
End Function
Public Function AddTrailer(ByRef lngBytesSoFar As Long,
intXRefObjCount As Integer) As String
Dim strTemp As String
strTemp = "trailer" & Chr(13) & " << /Size " & CStr(intXRefObjCount)
& Chr(13) & " /Root 1 0 R" & Chr(13) & " >>" & Chr(13) & Chr(13)
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
AddTrailer = strTemp
End Function
Public Function AddXREFTable(ByRef lngBytesSoFar As Long,
intXRefObjCount As Integer, lngObjOffset() As Long) As String
Dim strTemp As String
Dim intI As Integer
strTemp = "xref" & Chr(13) & "0 " & CStr(intXRefObjCount) & Chr(13) &
"0000000000 65535 f" & Chr(13)
For intI = 1 To intXRefObjCount - 1
strTemp = strTemp & Format$(lngObjOffset(intI), "0000000000") & "
00000 n" & Chr(13)
Next intI
strTemp = strTemp & Chr(13)
lngBytesSoFar = lngBytesSoFar + Len(strTemp)
AddXREFTable = strTemp
End Function
'----------End Module Code----------

James A. Fortune