Format and print a recordset

The example below shows how to format and print a recordset. I see a lot of people ask about this in Tek-Tips.


Public Function PrintRecordSet(rs As Recordset, PRN As Printer)
' Use .75 inch margins.
Const TOP_MARGIN = 1440 * 0.5
Const LEFT_MARGIN = 1440 * 0.75

Dim lCurrentPos As Long
Dim sCurrentField As String
Dim bChange() As Boolean
Dim iLongest As Integer
Dim lShorten As Long
Dim i As Integer
Dim x As Long
Dim lTotalHeaderLength As Long
Dim maxWidthPerLine As Long
Dim lLineWidth As Long
Dim maxFlengths() As Long
Dim fStartPos() As Long
Dim BM As Single
Dim numFields As Integer
Dim lFlengths() As Long
Dim sFNames() As String
Dim lFHeaderlenghts() As Long
Dim iNumToExpand As Integer
Dim PLines As Integer
Dim lCurrentY As Long
Dim Tlen As Integer
Dim LowY As Long

numFields = rs.Fields.Count - 1

ReDim lFlengths(numFields)
ReDim sFNames(numFields)
ReDim lFHeaderlenghts(numFields)
ReDim maxFlengths(numFields)
ReDim bChange(numFields)
ReDim fStartPos(numFields)
ReDim fEndPos(numFields)

'set bottom margin to an inch
BM = PRN.ScaleTop + PRN.ScaleHeight - 1440
maxWidthPerLine = PRN.Width - (LEFT_MARGIN * 2)
maxWidthPerLine = maxWidthPerLine - (100 * numFields)

For i = 0 To numFields
sFNames(i) = rs.Fields(i).Name
' maxFlengths(i) = PRN.TextWidth(sFNames(i)) + 100
lFHeaderlenghts(i) = PRN.TextWidth(sFNames(i))
lTotalHeaderLength = lTotalHeaderLength + lFHeaderlenghts(i)
Next

'get longest text in all fields
rs.MoveFirst
Do While rs.EOF <> True
For i = 0 To numFields
sCurrentField = rs(i)
If PRN.TextWidth(sCurrentField) > maxFlengths(i) Then
maxFlengths(i) = PRN.TextWidth(sCurrentField)
End If
Next i
rs.MoveNext
Loop

For i = 0 To numFields
If lFHeaderlenghts(i) > maxFlengths(i) Then
lFlengths(i) = lFHeaderlenghts(i)
bChange(i) = False
Else
lFlengths(i) = maxFlengths(i)
bChange(i) = True
iNumToExpand = iNumToExpand + 1
End If
lLineWidth = lLineWidth + lFlengths(i)
Next

'determine linewidths

Do While lLineWidth > maxWidthPerLine
iLongest = 1
For i = 0 To numFields
If lFlengths(i) > lFlengths(iLongest) Then
iLongest = i
End If
Next
lShorten = 0.05 * (lFlengths(iLongest))
lFlengths(iLongest) = lFlengths(iLongest) - lShorten
lLineWidth = lLineWidth - lShorten

Loop



lCurrentPos = LEFT_MARGIN
For i = 0 To numFields

fStartPos(i) = lCurrentPos
If i <= numFields Then
lCurrentPos = lCurrentPos + lFlengths(i) + 100
End If

Debug.Print CStr(fStartPos(i)) & " " & CStr(lFlengths(i))
Next i

rs.MoveFirst

Printer.CurrentX = TOP_MARGIN
Printer.CurrentY = LEFT_MARGIN
For i = 0 To numFields
PRN.CurrentX = fStartPos(i)
PRN.Print sFNames(i);
Next i
PRN.Print
PRN.Line (LEFT_MARGIN, PRN.CurrentY)-(PRN.Width - LEFT_MARGIN, PRN.CurrentY)


Do While rs.EOF = False
'print a line
lCurrentY = PRN.CurrentY
For i = 0 To numFields
PRN.CurrentX = fStartPos(i)
sCurrentField = rs.Fields(i) & ""
If PRN.TextWidth(sCurrentField) > lFlengths(i) Then
PRN.CurrentY = lCurrentY
PLines = PRN.TextWidth(sCurrentField) \ lFlengths(i) + 1
Tlen = Len(sCurrentField) / PLines
PRN.Print Left(sCurrentField, Tlen);
For x = 2 To PLines
PRN.Print
PRN.CurrentX = fStartPos(i)
PRN.Print Mid(sCurrentField, (x - 1) * Tlen + 1, Tlen);
If PRN.CurrentY > LowY Then
LowY = PRN.CurrentY
End If
Next x

Else
PRN.CurrentY = lCurrentY
PRN.Print sCurrentField;
If PRN.CurrentY > LowY Then
LowY = PRN.CurrentY
End If
End If
Next i
If PRN.CurrentY >= BM Then
' Start a new page.

PRN.NewPage
PRN.CurrentY = TOP_MARGIN
Printer.CurrentX = TOP_MARGIN
Printer.CurrentY = LEFT_MARGIN
LowY = PRN.CurrentY
For i = 1 To numFields
PRN.CurrentX = fStartPos(i)
PRN.Print sFNames(i);
Next i
PRN.Print
PRN.Line (LEFT_MARGIN, PRN.CurrentY)-(PRN.Width - LEFT_MARGIN, PRN.CurrentY)

Else
PRN.CurrentY = LowY
PRN.Print
PRN.Line (LEFT_MARGIN, PRN.CurrentY)-(PRN.Width - LEFT_MARGIN, PRN.CurrentY)
End If
rs.MoveNext

Loop

Printer.EndDoc

End Function