clsprint.cls

This application provides much functionality for creating data-driven reports, including preview, gr

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsPrint"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Attribute VB_Ext_KEY = "Member0" ,"clsCollection"
Option Explicit

Public Tables As clsTables
Public Labels As clsLabels
Public LabelsEx As clsLabelsEx
Public Lines As clsLines
Public Images As clsImages
Public Rectangles As clsRectangles
Public Points As clsPoints
Public PageBreaks As clsPageBreaks
Public Repeats As clsRepeats

Public Enum PrintRangeConstants
    AllPages& = 0
    OddPages& = 1
    EvenPages& = 2
End Enum

Public Enum PageOrientationConstants
    OPortrait& = 1
    OLandscape& = 2
End Enum

Public Enum PageSizeConstants
    sizeA3& = vbPRPSA3
    sizeA4& = vbPRPSA4
    sizeA5& = vbPRPSA5
    sizeB4& = vbPRPSB4
    sizeB5& = vbPRPSB5
    sizeLetter& = vbPRPSLetter
    sizeCustom& = vbPRPSUser
End Enum

Public Enum TextAlignConstants
    DT_LEFT& = &H0
    DT_CENTER& = &H1
    DT_RIGHT& = &H2
    DT_EXPANDTABS& = &H40
    DT_NOCLIP& = &H100
    DT_NOPREFIX& = &H800
    DT_SINGLELINE& = &H20
    DT_TOP& = &H0 Or &H20
    DT_VCENTER& = &H4 Or &H20
    DT_BOTTOM& = &H8 Or &H20
End Enum

Private Const DT_WORDBREAK& = &H10

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

Private Const LOGPIXELSX& = 88
Private Const LOGPIXELSY& = 90

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function DrawAnimatedRects Lib "user32" (ByVal hWnd As Long, ByVal idAni As Long, lprcFrom As RECT, lprcTo As RECT) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hWnd As Long, ByVal fEnable As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long

Public Collate As Boolean
Private pOrientation As PageOrientationConstants
Private pPageSize As PageSizeConstants
Private pCopies As Integer
Private pFromPage As Integer
Private pToPage As Integer
Private pRange As PrintRangeConstants

Private pHeight As Single, pWidth As Single
Private pPrintableWidth As Single, pPrintableHeight As Single
Private pLeftMargin As Single, pTopMargin As Single
Private pRightMargin As Single, pBottomMargin As Single
Private sngMaxMargin As Single

Private blnKillDoc As Boolean, blnViewPaginateStatus As Boolean

Private pOwner_hWnd As Long
Private intCurrentPage As Integer, sngCurrentPos As Single


Private Sub Class_Initialize()
    With Printer
        .TrackDefault = False
        .ScaleMode = vbMillimeters
        pOrientation = .Orientation
        pPageSize = .PaperSize
        pCopies = .Copies
    End With

    PageChanged pPageSize, pOrientation

    Set Tables = New clsTables
    Set Labels = New clsLabels
    Set LabelsEx = New clsLabelsEx
    Set Lines = New clsLines
    Set Images = New clsImages
    Set Rectangles = New clsRectangles
    Set Points = New clsPoints
    Set PageBreaks = New clsPageBreaks
    Set Repeats = New clsRepeats
    Set CQueue = New clsQueue
End Sub

Private Sub Class_Terminate()
    Set Tables = Nothing
    Set Labels = Nothing
    Set LabelsEx = Nothing
    Set Lines = Nothing
    Set Images = Nothing
    Set Rectangles = Nothing
    Set Points = Nothing
    Set PageBreaks = Nothing
    Set Repeats = Nothing
    Set CQueue = Nothing

    Erase colPage()
End Sub

Public Property Let Copies(ByVal c As Integer)
    If c < 1 Or c > 999 Then
        Err.Raise 9, , "Valid range is from 1 to 999"
    Else
        pCopies = c
    End If
End Property

Public Property Get Copies() As Integer
    Copies = pCopies
End Property

Public Property Let FromPage(ByVal f As Integer)
    If f < 0 Or f > 999 Then
        Err.Raise 9, , "Valid range is from 0 to 999"
    Else
        pFromPage = f
    End If
End Property

Public Property Get FromPage() As Integer
    FromPage = pFromPage
End Property

Public Property Let ToPage(ByVal t As Integer)
    If t < 0 Or t > 999 Then
        Err.Raise 9, , "Valid range is from 0 to 999"
    Else
        pToPage = t
    End If
End Property

Public Property Get ToPage() As Integer
    ToPage = pToPage
End Property

Public Property Let Range(ByVal r As PrintRangeConstants)
    If r < 0 Or r > 2 Then
        Err.Raise 9, , "Valid range is from 0 to 2"
    Else
        pRange = r
    End If
End Property

Public Property Get Range() As PrintRangeConstants
    Range = pRange
End Property

Public Property Get Orientation() As PageOrientationConstants
    Orientation = pOrientation
End Property

Public Property Let Orientation(ByVal o As PageOrientationConstants)
    If o > 0 And o < 3 Then
        If PageChanged(pPageSize, o) Then
            pOrientation = o
        End If
    Else
        Err.Raise 9, , "Valid value is 1 or 2"
    End If
End Property

Public Property Get PageSize() As PageSizeConstants
    PageSize = pPageSize
End Property

Public Property Let PageSize(ByVal ps As PageSizeConstants)
    If PageChanged(ps, pOrientation) Then
        pPageSize = ps
    End If
End Property

Private Function PageChanged(ps As PageSizeConstants, po As PageOrientationConstants) As Boolean
Dim RetVal As Boolean
Const MarginFactor As Single = 0.4

    RetVal = True
    On Error GoTo hErr:
    With Printer
        .Orientation = po
        .PaperSize = ps
        pHeight = .ScaleY(.Height, vbTwips, vbMillimeters)
        pWidth = .ScaleX(.Width, vbTwips, vbMillimeters)
        pPrintableHeight = .ScaleHeight
        pPrintableWidth = .ScaleWidth
    End With
    If pWidth > pHeight Then
        sngMaxMargin = pHeight * MarginFactor
    Else
        sngMaxMargin = pWidth * MarginFactor
    End If
    If pLeftMargin > sngMaxMargin Then pLeftMargin = sngMaxMargin
    If pTopMargin > sngMaxMargin Then pTopMargin = sngMaxMargin
    If pRightMargin > sngMaxMargin Then pRightMargin = sngMaxMargin
    If pBottomMargin > sngMaxMargin Then pBottomMargin = sngMaxMargin

    PageChanged = RetVal
    Exit Function

hErr:
    RetVal = False
    Resume Next
End Function

Public Property Let LeftMargin(ByVal m As Single)
    If m < 0 Or m > sngMaxMargin Then
        Err.Raise 9, , "Valid range is from 0 to " & sngMaxMargin
    Else
        pLeftMargin = m
    End If
End Property

Public Property Get LeftMargin() As Single
    LeftMargin = pLeftMargin
End Property

Public Property Let RightMargin(ByVal m As Single)
    If m < 0 Or m > sngMaxMargin Then
        Err.Raise 9, , "Valid range is from 0 to " & sngMaxMargin
    Else
        pRightMargin = m
    End If
End Property

Public Property Get RightMargin() As Single
    RightMargin = pRightMargin
End Property

Public Property Let TopMargin(ByVal m As Single)
    If m < 0 Or m > sngMaxMargin Then
        Err.Raise 9, , "Valid range is from 0 to " & sngMaxMargin
    Else
        pTopMargin = m
    End If
End Property

Public Property Get TopMargin() As Single
    TopMargin = pTopMargin
End Property

Public Property Let BottomMargin(ByVal m As Single)
    If m < 0 Or m > sngMaxMargin Then
        Err.Raise 9, , "Valid range is from 0 to " & sngMaxMargin
    Else
        pBottomMargin = m
    End If
End Property

Public Property Get BottomMargin() As Single
    BottomMargin = pBottomMargin
End Property

Public Property Get MaxMargin() As Single
    MaxMargin = sngMaxMargin
End Property

Public Property Get Width() As Single
    Width = pWidth
End Property

Public Property Get Height() As Single
    Height = pHeight
End Property

Public Property Get PrintableWidth() As Single
    PrintableWidth = pPrintableWidth
End Property

Public Property Get PrintableHeight() As Single
    PrintableHeight = pPrintableHeight
End Property

Public Property Get Owner_hWnd() As Long
    Owner_hWnd = pOwner_hWnd
End Property

Public Sub KillDoc()
    blnKillDoc = True
End Sub

Public Sub PreviewDoc(ByVal Owner_hWnd As Long, Optional ByVal ViewPaginateStatus As Boolean = False)
    pOwner_hWnd = Owner_hWnd
    blnViewPaginateStatus = ViewPaginateStatus

    InitLineWidthCoefficient (frmPreview.picPage.hDC)

    Paginate

    frmPreview.Show vbModal

    Call SetForegroundWindow(pOwner_hWnd)
End Sub

Public Sub PrintDoc(ByVal Owner_hWnd As Long, Optional ShowPrinterWindow As Boolean = True)
Const conSeparator As String = " / "
Dim i As Integer, j As Integer, fPrint As Boolean