modprint.bas

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

Attribute VB_Name = "modPrint"
Option Explicit

Public Const defFontName As String = "Arial"
Public Const defFontSize As Single = 8.25

Public CInteraction As New clsInteraction

Public PrinterEx As clsPrint
Public CQueue As clsQueue

Public colPage() As Collection

Public sngLineWidthCoefficient As Single
Public sngLabelExCoefficient As Single

Private Const DT_WORDBREAK& = &H10

Private Const LF_FACESIZE& = 32
Private Const DEFAULT_QUALITY& = 0
Private Const DEFAULT_PITCH& = 0
Private Const OUT_DEFAULT_PRECIS& = 0
Private Const FF_DONTCARE& = 0
Private Const DEFAULT_CHARSET& = 1

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(LF_FACESIZE - 1) As Byte
End Type

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

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long


Public Sub NewReport()
    Set PrinterEx = Nothing
    Set PrinterEx = New clsPrint
End Sub

Public Sub SendPage(OutputObj As Object, _
                                        ByVal Page As Integer, _
                                        Optional ByVal Zoom As Single = 1, _
                                        Optional ByVal Indent_X As Long, _
                                        Optional ByVal Indent_Y As Long)
                                        
Dim CPointA As clsPointAttributes
Dim CLineA As clsLineAttributes
Dim CLabelA As clsLabelAttributes
Dim CRectangleA As clsRectangleAttributes
Dim CLabelExA As clsLabelExAttributes
Dim CImageA As clsImageAttributes
Dim CTableA As clsTableAttributes

Dim lngDC As Long
Dim strItem As String
Dim x1_ As Single, y1_ As Single, x2_ As Single, y2_ As Single
Dim i As Long, j As Long, k As Long, Align As Long
Dim sngLeftMargin As Single, sngRightMargin As Single, sngPW As Single, sngPH As Single
Dim IndentX As Single, IndentY As Single
Dim sngLineWidthCoefficient_ As Single, sngLabelExCoefficient_ As Single

Dim TextArray() As String, sngTableTop As Single, FirstRowIsTitle As Boolean
Dim sngCellSpacing As Single, intBorderWidth As Integer, sngColumnSpacing As Single
Dim sngTitleHeight As Single, sngBodyHeight As Single
Dim lngTotalColumns As Long, lngColumnsCount As Long
Dim lngBorderColor As Long, sngColsWidth() As Single, sngTableWidth As Single
Dim Col_ As Long
Dim strTableLex() As String, lngAryIndex As Long
Dim lngRowsOnPage As Long, lngTotalRows As Long
Dim lngStartRow As Long, lngEndRow As Long
Dim ly As Long, uy As Long
Dim x1__  As Single, y1__ As Single

Dim lf As LOGFONT
Dim FontToUse As Long, oldFont As Long
Dim TempByteArray() As Byte

Dim PointArray() As Single

    OutputObj.Print ""

    IndentX = Indent_X * Zoom
    IndentY = Indent_Y * Zoom

    sngLabelExCoefficient_ = sngLabelExCoefficient * Zoom
    sngLineWidthCoefficient_ = sngLineWidthCoefficient * Zoom

    lngDC = OutputObj.hDC
    With PrinterEx
        sngPW = .PrintableWidth * Zoom
        sngPH = .PrintableHeight * Zoom
        sngLeftMargin = .LeftMargin * Zoom + IndentX
        sngRightMargin = .RightMargin * Zoom
    End With

    OutputObj.DrawStyle = vbSolid
    For i = 1 To PrinterEx.Repeats.Count
        Select Case TypeName(PrinterEx.Repeats(i))
            Case "clsLabelAttributes"
                Set CLabelA = PrinterEx.Repeats(i)
                With CLabelA
                    OutputObj.FontBold = .FontBold
                    OutputObj.FontItalic = .FontItalic
                    OutputObj.FontName = .FontName
                    OutputObj.FontStrikethru = .FontStrikethru
                    OutputObj.FontUnderline = .FontUnderline
                    OutputObj.FontSize = .FontSize * Zoom
                    OutputObj.ForeColor = .ForeColor
                    Align = .Align
                    sngCellSpacing = .CellSpacing * Zoom
                    x1_ = .Left * Zoom + sngLeftMargin
                    y1_ = .Top * Zoom + IndentY
                    x2_ = .Right * Zoom + sngLeftMargin
                    y2_ = .Bottom * Zoom + IndentY
                    If .WordWrap Then Align = Align Or DT_WORDBREAK
                    intBorderWidth = Abs(Int(-(.BorderWidth / 10) * sngLineWidthCoefficient_))
                    If intBorderWidth > 0 Then
                        OutputObj.DrawWidth = intBorderWidth
                        OutputObj.FillStyle = .FillStyle
                        OutputObj.FillColor = .FillColor
                        OutputObj.Line (x1_, y1_)-(x2_, y2_), .BorderColor, B
                    End If

                    Draw_Text lngDC, Replace(.Caption, "&[Page]", Page), _
                                        CLng(OutputObj.ScaleX(x1_ + sngCellSpacing, vbMillimeters, vbPixels)), _
                                        CLng(OutputObj.ScaleY(y1_ + sngCellSpacing, vbMillimeters, vbPixels)), _
                                        CLng(OutputObj.ScaleX(x2_ - sngCellSpacing, vbMillimeters, vbPixels)), _
                                        CLng(OutputObj.ScaleY(y2_ - sngCellSpacing, vbMillimeters, vbPixels)), _
                                        Align
                End With
            Case "clsLabelExAttributes"
                Set CLabelExA = PrinterEx.Repeats(i)
                With CLabelExA
                    OutputObj.ForeColor = .ForeColor
                    Align = .Align
                    sngCellSpacing = .CellSpacing * Zoom
                    x1_ = .Left * Zoom + sngLeftMargin
                    y1_ = .Top * Zoom + IndentY
                    x2_ = .Right * Zoom + sngLeftMargin
                    y2_ = .Bottom * Zoom + IndentY
                    If .WordWrap Then Align = Align Or DT_WORDBREAK
                    lf.lfHeight = .CharHeight * sngLabelExCoefficient_
                    lf.lfWidth = .CharWidth * sngLabelExCoefficient_
                    lf.lfEscapement = .Angle
                    lf.lfWeight = .CharWeight
                    lf.lfItalic = Abs(CLng(.FontItalic))
                    lf.lfUnderline = Abs(CLng(.FontUnderline))
                    lf.lfStrikeOut = Abs(CLng(.FontStrikeOut))
                    lf.lfOutPrecision = OUT_DEFAULT_PRECIS
                    lf.lfClipPrecision = OUT_DEFAULT_PRECIS
                    lf.lfQuality = DEFAULT_QUALITY
                    lf.lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
                    lf.lfCharSet = DEFAULT_CHARSET
                    TempByteArray = StrConv(.FontName & vbNullChar, vbFromUnicode)
                    For j = 0 To UBound(TempByteArray)
                        lf.lfFaceName(j) = TempByteArray(j)
                    Next j
                    FontToUse = CreateFontIndirect(lf)
                    intBorderWidth = Abs(Int(-(.BorderWidth / 10) * sngLineWidthCoefficient_))
                    If intBorderWidth > 0 Then
                        OutputObj.DrawWidth = intBorderWidth
                        OutputObj.FillStyle = .FillStyle
                        OutputObj.FillColor = .FillColor
                        OutputObj.Line (x1_, y1_)-(x2_, y2_), .BorderColor, B
                    End If
                    oldFont = SelectObject(lngDC, FontToUse)
                    Draw_Text lngDC, Replace(.Caption, "&[Page]", Page), _
                                        CLng(OutputObj.ScaleX(x1_ + sngCellSpacing, vbMillimeters, vbPixels)), _
                                        CLng(OutputObj.ScaleY(y1_ + sngCellSpacing, vbMillimeters, vbPixels)), _
                                        CLng(OutputObj.ScaleX(x2_ - sngCellSpacing, vbMillimeters, vbPixels)), _
                                        CLng(OutputObj.ScaleY(y2_ - sngCellSpacing, vbMillimeters, vbPixels)), _
                                        Align
                    If oldFont <> 0 Then
                        Call SelectObject(lngDC, oldFont)
                        Call DeleteObject(FontToUse)
                        FontToUse = 0
                        oldFont = 0
                    End If
                End With
            Case "clsLineAttributes"
                Set CLineA = PrinterEx.Repeats(i)
                With CLineA
                    OutputObj.DrawWidth = Abs(Int(-(.Size / 10) * sngLineWidthCoefficient_))
                    OutputObj.Line (.X1 * Zoom + sngLeftMargin, .Y1 * Zoom + IndentY)- _
                                                (.X2 * Zoom + sngLeftMargin, .Y2 * Zoom + IndentY), .Color
                End With
            Case "clsImageAttributes"
                Set CImageA = PrinterEx.Repeats(i)
                With CImageA
                    If IsMissing(.Height) Then
                        y1_ = .Image.Height / 100
                    Else
                        y1_ = CSng(.Height)
                    End If

                    If IsMissing(.Width) Then
                        x1_ = .Image.Width / 100
                    Else
                        x1_ = CSng(.Width)
                    End If

                    OutputObj.PaintPicture .Image, .Left * Zoom + sngLeftMargin, .Top * Zoom + IndentY, x1_ * Zoom, y1_ * Zoom
                End With
            Case "clsRectangleAttributes"
                Set CRectangleA = PrinterEx.Repeats(i)
                With CRectangleA
                    OutputObj.DrawWidth = Abs(Int(-(.BorderWidth / 10) * sngLineWidthCoefficient_))
                    OutputObj.FillStyle = .FillStyle
                    OutputObj.FillColor = .FillColor
                    OutputObj.Line (.Left * Zoom + sngLeftMargin, .Top * Zoom + IndentY)- _
                                                (.Right * Zoom + sngLeftMargin, .Bottom * Zoom + IndentY), .BorderColor, B
                End With
            Case "clsPointAttributes"
                Set CPointA = PrinterEx.Repeats(i)
                With CPointA
                    OutputObj.DrawWidth = Abs(Int(-(.Size / 10) * sngLineWidthCoefficient_))
                    PointArray = .PointArray
                    lngBorderColor = .Color
                    For j = 1 To UBound(PointArray, 2)
                        OutputObj.PSet (PointArray(1, j) * Zoom + sngLeftMargin, PointArray(2, j) * Zoom + IndentY), lngBorderColor
                    Next j
                End With
        End Select
    Next i

    'Report Body
    For i = 1 To colPage(Page).Count
        strItem = TypeName(colPage(Page)(i))
        Select Case strItem
            Case "clsPointAttributes"
                Set CPointA = colPage(Page)(i)
                With CPointA
                    OutputObj.DrawStyle = vbSolid
                    OutputObj.DrawWidth = Abs(Int(-.Size * Zoom))
                    lngBorderColor = .Color
                    PointArray = .PointArray
                    For j = 1 To UBound(PointArray, 2)
                        OutputObj.PSet (PointArray(1, j) * Zoom + IndentX, PointArray(2, j) * Zoom + IndentY), lngBorderColor
                    Next j
                End With
            Case "clsLineAttributes"
                Set CLineA = colPage(Page)(i)
                With CLineA
                    OutputObj.DrawStyle = vbSolid
                    OutputObj.DrawWidth = Abs(Int(-.Size * Zoom))
                    OutputObj.Line (.X1 * Zoom + IndentX, .Y1 * Zoom + IndentY)- _
                                                (.X2 * Zoom + IndentX, .Y2 * Zoom + IndentY), .Color
                End With
            Case "clsRectangleAttributes"
                Set CRectangleA = colPage(Page)(i)
                With CRectangleA
                    OutputObj.DrawStyle = vbSolid
                    OutputObj.DrawWidth = Abs(Int(-.BorderWidth * Zoom))
                    OutputObj.FillStyle = .FillStyle
                    OutputObj.FillColor = .FillColor
                    OutputObj.Line (.Left * Zoom + IndentX, .Top * Zoom + IndentY)- _
                                                (.Right * Zoom + IndentX, .Bottom * Zoom + IndentY), .BorderColor, B
                End With
            Case "clsLabelAttributes"
                Set CLabelA = colPage(Page)(i)