UPrinter.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "UPrinter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'
' Original code by [dilettante](http://www.vbforums.com/member.php?67924-dilettante)
' from [Unicode Printer Class project](http://www.vbforums.com/showthread.php?762177-VB6-UPrinter-Unicode-Printer-Class)
'
'UPrinter
'========
'
'A simple Unicode Printer class.
'
'This version does not deal with images, drawing, paper tray or size selection,
'orientation, etc.  It only prints in whole lines (or multiples if you have
'embedded newlines), long lines should wrap.
'
'All exceptions raised while the printer is open close the printer.
'
'NOTES:
'
'   o See "PRB: Printing Rotated Text with Visual Basic"
'           http://support.microsoft.com/kb/175535
'
'     "Visual Studio 97 Service Pack 2 and 3 for Visual Basic 5.0 and 6.0
'     include a fix for the Printer object that prevents any new SelectObject
'     calls from selecting a new Font for the Printer.hDC. So, when referencing
'     the Printer object, new fonts must be selected via the Printer object's
'     properties or they are ignored."
'
'     "To work around this problem, either print using the API only, or do not
'     reference the Printer object while printing with the API functions."
'
'     This applies here because we set printer fonts in this class, i.e. do not
'     reference the Printer object when using this class.
'
'   o Using GetTabbedTextExtent() and TabbedTextOut() would give more control
'     over tab stops.  You can have various tab stops, they are in logical
'     units instead of "the average character width" of the current font
'     settings, and you can have right-aligned tabstops.
'
'Most coordinates and measurements here are in Twips.
'

Private Const WIN32_NULL As Long = 0
Private Const INVALID_HANDLE_VALUE As Long = -1

Private Const ERROR_CANCELLED As Long = 1223
Private Const SP_ERROR As Long = -1

Private Const LF_FACESIZE = 32

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * LF_FACESIZE
End Type

Private Type DOCINFO
    cbSize As Long
    lpszDocName As Long
    lpszOutput As Long
    lpszDatatype As Long
    fwType As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type DRAWTEXTPARAMS
    cbSize As Long
    iTabLength As Long
    iLeftMargin As Long
    iRightMargin As Long
    uiLengthDrawn As Long
End Type

Private Const DT_BOTTOM As Long = &H8&
Private Const DT_CALCRECT As Long = &H400&
Private Const DT_CENTER As Long = &H1&
Private Const DT_EDITCONTROL As Long = &H2000&
Private Const DT_END_ELLIPSIS As Long = &H8000&
Private Const DT_EXPANDTABS As Long = &H40&
Private Const DT_EXTERNALLEADING As Long = &H200&
Private Const DT_HIDEPREFIX As Long = &H100000
Private Const DT_INTERNAL As Long = &H1000&
Private Const DT_LEFT As Long = &H0&
Private Const DT_MODIFYSTRING As Long = &H10000
Private Const DT_NOCLIP As Long = &H100&
Private Const DT_NOFULLWIDTHCHARBREAK As Long = &H80000
Private Const DT_NOPREFIX As Long = &H800&
Private Const DT_PATH_ELLIPSIS As Long = &H4000&
Private Const DT_PREFIXONLY As Long = &H200000
Private Const DT_RIGHT As Long = &H2&
Private Const DT_SINGLELINE As Long = &H20&
Private Const DT_TABSTOP As Long = &H80&
Private Const DT_TOP As Long = &H0&
Private Const DT_VCENTER As Long = &H4&
Private Const DT_WORDBREAK As Long = &H10&
Private Const DT_WORD_ELLIPSIS As Long = &H40000

Private Enum DeviceParms
    HORZRES = 8     'Width, in pixels.
    VERTRES = 10    'Height, in pixels.
    LOGPIXELSX = 88 'Logical pixels/inch in X.
    LOGPIXELSY = 90 'Logical pixels/inch in Y.
End Enum

Private Const MM_TWIPS = 6

Private Declare Function AbortDoc Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCW" ( _
    ByVal lpDriverName As Long, _
    ByVal lpDeviceName As Long, _
    ByVal lpOutput As Long, _
    ByVal lpInitData As Long) As Long

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectW" ( _
    ByVal lpLogFont As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function DrawTextEx Lib "user32" Alias "DrawTextExW" ( _
    ByVal hDC As Long, _
    ByVal lpString As Long, _
    ByVal nCount As Long, _
    ByRef DrawRect As RECT, _
    ByVal wFormat As Long, _
    ByRef DTParams As DRAWTEXTPARAMS) As Long

Private Declare Function EndDoc Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function EndPage Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" ( _
    ByVal hDC As Long, _
    ByVal nIndex As DeviceParms) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32W" ( _
    ByVal hDC As Long, _
    ByVal lpsz As Long, _
    ByVal cbString As Long, _
    ByRef Sizes As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long

Private Declare Function SetMapMode Lib "gdi32" (ByVal hDC As Long, ByVal fnMapMode As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" ( _
    ByVal hDC As Long, _
    ByVal crColor As Long) As Long

Private Declare Function StartDoc Lib "gdi32" Alias "StartDocW" ( _
    ByVal hDC As Long, _
    ByRef DOCINFO As DOCINFO) As Long

Private Declare Function StartPage Lib "gdi32" (ByVal hDC As Long) As Long

Private Const ZWSP As Long = &H200B& 'Unicode Zero Width Space character.

Private CurrentBottom As Long 'Twips.
Private DOCINFO As DOCINFO
Private DoingFootingEvent As Boolean
Private FirstPage As Boolean
Private ForeColorRGB As Long
Private hFontOrig As Long
Private hFont As Long
Private IsOpen As Boolean
Private LastDllError As Long
Private LOGFONT As LOGFONT
Private StartedDoc As Boolean
Private StartedPage As Boolean
Private SuppressUpdates As Boolean 'Used to prevent updating printer Font on each individual change.
Private TopMarginChanged As Boolean
Private TypeNameOfMe As String

Private mBottomMargin As Long 'Twips.
Private mCurrentY As Long 'Twips.
Private mDocName As String
Private mOutputFile As String
Private WithEvents mFont As StdFont
Attribute mFont.VB_VarHelpID = -1
Private mFootingHeight As Long
Private mForeColor As stdole.OLE_COLOR
Private mhDC As Long
Private mHeadingHeight As Long
Private mPpiX As Long
Private mPpiY As Long
Private mPrintableHeight As Long 'Twips.
Private mPrintableWidth As Long 'Twips.
Private mTopMargin As Long 'Twips.

Public Event Footing(ByVal LastPage As Boolean)
Public Event Heading(ByVal FirstPage As Boolean)

Public LeftMargin As Long 'Twips.
Public RightMargin As Long 'Twips.
Public TabLength As Byte 'Tabstop settings in "average char width" and 0 means default every 8.

Public Property Get BottomMargin() As Long 'Twips.
    BottomMargin = mBottomMargin
End Property

Public Property Let BottomMargin(ByVal RHS As Long)
    If IsOpen Then
        If TopMargin + RHS >= PrintableHeight Then
            ClosePrinter
            Err.Raise 380, TypeNameOfMe 'Invalid property value.
        End If
        CurrentBottom = PrintableHeight - RHS
    End If
    mBottomMargin = RHS
End Property

Public Property Get CurrentY() As Long 'Reported in negative Twips.
    CurrentY = mCurrentY
End Property

Public Property Get Font() As StdFont
    Set Font = mFont
End Property

Public Property Set Font(NewFont As StdFont)
    With mFont
        SuppressUpdates = True
        '.Bold = NewFont.Bold 'We catch this in Weight below!
        .Italic = NewFont.Italic
        .Name = NewFont.Name
        .Size = NewFont.Size
        .Underline = NewFont.Underline
        SuppressUpdates = False 'Go ahead and update after the next change.
        .Weight = NewFont.Weight
    End With
End Property

Public Property Get FootingHeight() As Long 'Twips.
    FootingHeight = mFootingHeight
End Property

Public Property Let FootingHeight(ByVal RHS As Long)
    If IsOpen Then
        If TopMargin + RHS >= PrintableHeight Then
            ClosePrinter
            Err.Raise 380, TypeNameOfMe 'Invalid property value.
        End If
    End If
    mFootingHeight = RHS
End Property

Public Property Get ForeColor() As stdole.OLE_COLOR
    ForeColor = mForeColor
End Property

Public Property Let ForeColor(ByVal RHS As stdole.OLE_COLOR)
    mForeColor = RHS
    If RHS And &H80000000 Then
        ForeColorRGB = GetSysColor(RHS And &HFFFF&)
    Else
        ForeColorRGB = RHS
    End If
    SetTextColor hDC, ForeColorRGB
End Property

Public Property Get hDC() As Long
    hDC = mhDC
End Property

Private Property Let hDC(ByVal RHS As Long)
    mhDC = RHS
End Property

Public Property Get HeadingHeight() As Long 'Twips.
    HeadingHeight = mHeadingHeight
End Property

Public Property Let HeadingHeight(ByVal RHS As Long)
    If IsOpen Then
        If TopMargin + RHS >= PrintableHeight Then
            ClosePrinter
            Err.Raise 380, TypeNameOfMe 'Invalid property value.
        End If
    End If
    mHeadingHeight = RHS
End Property

Public Property Get PpiX() As Long
    PpiX = mPpiX
End Property

Private Property Let PpiX(ByVal RHS As Long)
    mPpiX = RHS
End Property

Public Property Get PpiY() As Long
    PpiY = mPpiY
End Property

Private Property Let PpiY(ByVal RHS As Long)
    mPpiY = RHS
End Property

Public Property Get PrintableHeight() As Long 'Twips.
    PrintableHeight = mPrintableHeight
End Property

Private Property Let PrintableHeight(ByVal RHS As Long)
    mPrintableHeight = RHS
End Property

Public Property Get PrintableWidth() As Long 'Twips.
    PrintableWidth = mPrintableWidth
End Property

Private Property Let PrintableWidth(ByVal RHS As Long)
    mPrintableWidth = RHS
End Property

Public Property Get TopMargin() As Long
    TopMargin = mTopMargin
End Property

Public Property Let TopMargin(ByVal RHS As Long)
    If IsOpen Then
        If RHS + BottomMargin >= PrintableHeight Then
            ClosePrinter
            Err.Raise 380, TypeNameOfMe 'Invalid property value.
        End If
        TopMarginChanged = True
    End If
    mTopMargin = RHS
End Property

Public Sub ClosePrinter()
    Dim hFontPrev As Long
    
    If IsOpen Then
        If StartedPage Then
            mCurrentY = -(CurrentBottom - FootingHeight)
            DoingFootingEvent = True
            RaiseEvent Footing(True)
            DoingFootingEvent = False
        End If
        hFontPrev = SelectObject(hDC, hFontOrig)
        DeleteObject hFontPrev
        If StartedPage Then
            EndPage hDC
            StartedPage = False
        End If
        If StartedDoc Then
            EndDoc hDC
            StartedDoc = False
        End If
        DeleteDC hDC
        hDC = WIN32_NULL
        
        TopMarginChanged = False
        IsOpen = False
    End If
End Sub

Public Function KillDoc() As Boolean
    'Returns False on failure.
    
    If Not IsOpen Then
        Err.Raise &H80049900, TypeNameOfMe, "UPrinter not open"
    End If
    
    KillDoc = AbortDoc(hDC) <> SP_ERROR
    ClosePrinter
End Function

Public Sub NewPage()
    If Not IsOpen Then
        Err.Raise &H80049900, TypeNameOfMe, "UPrinter not open"
    End If
    
    'We're open, so StartedPage is known to be True here:
    If Not FirstPage Then
        mCurrentY = -(CurrentBottom - FootingHeight)
        DoingFootingEvent = True
        RaiseEvent Footing(False)
        DoingFootingEvent = False
    End If
    EndPage hDC
    StartPage hDC
    mCurrentY = -TopMargin
    If FirstPage Then
        FirstPage = False
        RaiseEvent Heading(True)
    Else
        RaiseEvent Heading(False)
    End If
    mCurrentY = -(TopMargin + HeadingHeight)
End Sub

Public Function OpenPrinter( _
    ByVal DeviceName As String, _
    ByVal DriverName As String, _
    Optional ByVal DocName As String, _
    Optional ByVal OutputFile As String) As Boolean
    'Returns False if user canceled printing from any printer dialog
    'during StartDoc.  These dialogs normally occur when a virtual
    'printer is used to select a file to print to.
    
    If IsOpen Then
        ClosePrinter
        Err.Raise &H80049902, TypeNameOfMe, "UPrinter already open"
    End If
    
    If DocName = vbNullString Then DocName = App.EXEName
    
    hDC = CreateDC(StrPtr(DriverName), StrPtr(DeviceName), 0, 0)
    If hDC = WIN32_NULL Then
        Err.Raise &H80049912, TypeNameOfMe, "CreateDC error " & CStr(Err.LastDllError)
    End If
    
    DOCINFO.cbSize = Len(DOCINFO)
    mDocName = DocName
    DOCINFO.lpszDocName = StrPtr(mDocName)
    mOutputFile = OutputFile
    If LenB(mOutputFile) <> 0 Then
        DOCINFO.lpszOutput = StrPtr(mOutputFile)
    End If
    If StartDoc(hDC, DOCINFO) <= 0 Then
        If Err.LastDllError = ERROR_CANCELLED Then
            ClosePrinter
            Exit Function
        Else
            LastDllError = Err.LastDllError
            ClosePrinter
            Err.Raise &H80049912, TypeNameOfMe, "StartDoc error " & CStr(LastDllError)
        End If
    End If
    StartedDoc = True
    
    PpiX = GetDeviceCaps(hDC, LOGPIXELSX)
    PrintableWidth = TwipsX(GetDeviceCaps(hDC, HORZRES))
    PpiY = GetDeviceCaps(hDC, LOGPIXELSY)
    PrintableHeight = TwipsY(GetDeviceCaps(hDC, VERTRES))
    mCurrentY = -TopMargin
    CurrentBottom = PrintableHeight - BottomMargin
    SetMapMode hDC, MM_TWIPS
    UpdateFont
    ForeColor = vbBlack
    
    StartPage hDC
    StartedPage = True
    FirstPage = True
    TopMarginChanged = False
    DoingFootingEvent = False
    IsOpen = True
    
    OpenPrinter = True
End Function

Public Function PixelsX(ByVal TwipsX As Long)
    PixelsX = Int(CDbl(TwipsX) * PpiX / 1440 + 0.5)
End Function

Public Function PixelsY(ByVal TwipsY As Long)
    PixelsY = Int(CDbl(TwipsY) * PpiY / 1440 + 0.5)
End Function

Public Sub PrintLine( _
    Optional ByVal Text As String, _
    Optional ByVal Alignment As AlignmentConstants = vbLeftJustify)

    'Can't call this "Print" since that is a reserved word.
    '
    'NOTE:
    '
    '   Vertical Y coordinates and heights are in "logical units" which are negative
    '   values for Y.
    '
    '   This also means that our mCurrentY coordinate runs from 0 to -PrintableHeight.
    '
    Dim RECT As RECT
    Dim DRAWTEXTPARAMS As DRAWTEXTPARAMS
    Dim Align As Long
    Dim SetStops As Long
    Dim MeasuredHeight As Long
    
    If Not IsOpen Then Err.Raise &H80049900, TypeNameOfMe, "UPrinter not open"

    If FirstPage Then
        FirstPage = False
        RaiseEvent Heading(True)
        mCurrentY = -(TopMargin + HeadingHeight)
    End If
    
    If TopMarginChanged And (mCurrentY > -TopMargin) Then
        TopMarginChanged = False
        mCurrentY = -TopMargin
    End If
    
    If Alignment <> vbLeftJustify Then
        If Alignment = vbRightJustify Then
            Align = DT_RIGHT
        Else
            Align = DT_CENTER
        End If
    End If
    
    If Len(Text) = 0 Then Text = ChrW$(ZWSP)
    
    With DRAWTEXTPARAMS
        .cbSize = Len(DRAWTEXTPARAMS)
        .iLeftMargin = LeftMargin
        .iRightMargin = RightMargin
        If TabLength > 0 Then
            SetStops = DT_TABSTOP
            .iTabLength = TabLength
        End If
    End With
    
    'Measure height:
    RECT.Right = PrintableWidth
    MeasuredHeight = DrawTextEx(hDC, _
                                StrPtr(Text), _
                                -1, _
                                RECT, _
                                DT_CALCRECT _
                             Or Align _
                             Or DT_EDITCONTROL _
                             Or DT_EXPANDTABS _
                             Or DT_NOPREFIX _
                             Or DT_WORDBREAK _
                             Or DT_NOCLIP _
                             Or SetStops, _
                                DRAWTEXTPARAMS)
    If MeasuredHeight = 0 Then
        LastDllError = Err.LastDllError
        ClosePrinter
        Err.Raise &H80049922, TypeNameOfMe, "PrintLine: DrawText error " & CStr(LastDllError)
    End If
    
    If Not DoingFootingEvent Then
        If mCurrentY + MeasuredHeight < -(CurrentBottom - FootingHeight) Then NewPage
    End If
    
    With RECT
        .Top = mCurrentY
        mCurrentY = mCurrentY + MeasuredHeight
        .Bottom = mCurrentY
        .Right = PrintableWidth - RightMargin
    End With
    DrawTextEx hDC, _
               StrPtr(Text), _
               -1, _
               RECT, _
               Align _
            Or DT_EDITCONTROL _
            Or DT_EXPANDTABS _
            Or DT_NOPREFIX _
            Or DT_WORDBREAK _
            Or DT_NOCLIP _
            Or SetStops, _
               DRAWTEXTPARAMS
End Sub

Public Function TextHeight(Optional ByVal Text As String) As Long 'Twips.
    Dim RECT As RECT
    Dim DRAWTEXTPARAMS As DRAWTEXTPARAMS
    Dim SetStops As Long

    If Len(Text) = 0 Then Text = ChrW$(ZWSP)
    
    With DRAWTEXTPARAMS
        .cbSize = Len(DRAWTEXTPARAMS)
        .iLeftMargin = LeftMargin
        .iRightMargin = RightMargin
        If TabLength > 0 Then
            SetStops = DT_TABSTOP
            .iTabLength = TabLength
        End If
    End With
    
    'Measure height:
    RECT.Right = PrintableWidth
    TextHeight = -DrawTextEx(hDC, _
                             StrPtr(Text), _
                             -1, _
                             RECT, _
                             DT_CALCRECT _
                          Or DT_EDITCONTROL _
                          Or DT_EXPANDTABS _
                          Or DT_NOPREFIX _
                          Or DT_WORDBREAK _
                          Or DT_NOCLIP _
                          Or SetStops, _
                             DRAWTEXTPARAMS)
    If TextHeight = 0 Then
        LastDllError = Err.LastDllError
        ClosePrinter
        Err.Raise &H80049924, TypeNameOfMe, "TextHeight: DrawText error " & CStr(LastDllError)
    End If
End Function

Public Function TwipsX(ByVal PixelsX As Long)
    TwipsX = Int(PixelsX * 1440# / PpiX + 0.5)
End Function

Public Function TwipsY(ByVal PixelsY As Long)
    TwipsY = Int(PixelsY * 1440# / PpiY + 0.5)
End Function

Private Sub ChangeLogFont(ByVal PropertyName As String)
    Select Case PropertyName
        Case "Bold" 'This can be triggered by itself instead of via Weight so we handle it here.
            LOGFONT.lfWeight = IIf(mFont.Bold, 700, 400)
        Case "Italic"
            LOGFONT.lfItalic = IIf(mFont.Italic, 1, 0)
        Case "Name"
            LOGFONT.lfFaceName = mFont.Name & vbNullChar
        Case "Size"
            LOGFONT.lfHeight = mFont.Size * -20 'Points to Twips, negative.
        Case "Underline"
            LOGFONT.lfUnderline = IIf(mFont.Underline, 1, 0)
        Case "Weight"
            LOGFONT.lfWeight = mFont.Weight
        'Case Else
            'Do nothing.
    End Select
End Sub

Private Sub UpdateFont()
    Dim hFontPrev As Long
    
    hFont = CreateFontIndirect(VarPtr(LOGFONT))
    hFontPrev = SelectObject(hDC, hFont)
    If hFontOrig = INVALID_HANDLE_VALUE Then
        hFontOrig = hFontPrev
    Else
        DeleteObject hFontPrev
    End If
End Sub

Private Sub Class_Initialize()
    TypeNameOfMe = TypeName(Me)
    'Implied: hDC = WIN32_NULL
    hFontOrig = INVALID_HANDLE_VALUE
    Set mFont = New StdFont
    ChangeLogFont "Name"
    ChangeLogFont "Size"
    ChangeLogFont "Weight"
End Sub

Private Sub Class_Terminate()
    ClosePrinter
End Sub

Private Sub mFont_FontChanged(ByVal PropertyName As String)
    ChangeLogFont PropertyName
    If IsOpen And Not SuppressUpdates Then UpdateFont
End Sub

UPrinter.cls.diff

 Private mBottomMargin As Long 'Twips.
 Private mCurrentY As Long 'Twips.
 Private mDocName As String
+Private mOutputFile As String
 Private WithEvents mFont As StdFont
 Attribute mFont.VB_VarHelpID = -1
 Private mFootingHeight As Long
@@ -422,7 +423,8 @@ End Sub
 Public Function OpenPrinter( _
     ByVal DeviceName As String, _
     ByVal DriverName As String, _
-    Optional ByVal DocName As String) As Boolean
+    Optional ByVal DocName As String, _
+    Optional ByVal OutputFile As String) As Boolean
     'Returns False if user canceled printing from any printer dialog
     'during StartDoc.  These dialogs normally occur when a virtual
     'printer is used to select a file to print to.
@@ -442,6 +444,10 @@ Public Function OpenPrinter( _
     DOCINFO.cbSize = Len(DOCINFO)
     mDocName = DocName
     DOCINFO.lpszDocName = StrPtr(mDocName)
+    mOutputFile = OutputFile
+    If LenB(mOutputFile) <> 0 Then
+        DOCINFO.lpszOutput = StrPtr(mOutputFile)
+    End If
     If StartDoc(hDC, DOCINFO) <= 0 Then
         If Err.LastDllError = ERROR_CANCELLED Then
             ClosePrinter