CD Actual Thematic 25: Programming/pc_actual_25.iso/Basic/GridOne/setup.EXE/PRINTGRID.CLS

Visual Basic class definition | 2001-09-09 | 21.3 KB | 709 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "PrintBeeGrid"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"No"
Attribute VB_Ext_KEY = "Collection" ,"PrintLine"
Attribute VB_Ext_KEY = "Member0" ,"PrintLine"
Option Explicit
' ********************************************************************************
' * Description: Open, save and keep collection of print lines.
' *
' * Methods:
' *
' * Properties:
' *
' * Associations:
' * Events:
' * Revisions:
' *  12.02.1999   fml   Added comments.
' ********************************************************************************
' Mod INTERFACES
' Mod EVENTS
Public Event LoadPages(Page As Long)
Public Event PrinterChange()
Public Event ChengePage(Page As Long)
' Mod CONSTANTS
' Mod ENUMS
' Mod TYPES
Private miDestination As sgDestination

Public Enum sgDestination
   sgPreview = 1
   sgPrint = 2
End Enum
Public Enum sgOrientation
   sgPortrait = 1
   sgLandscape = 2
End Enum

Public Enum sgPaperSize
   sgLetter = 1 'Letter, 8 1/2 x 11 in.
   sgLetterSmall = 2 'Letter Small, 8 1/2 x 11 in.
   sgTabloid = 3 'Tabloid, 11 x 17 in.
   sgLedger = 4 'Ledger, 17 x 11 in.
   sgLegal = 5 'Legal, 8 1/2 x 14 in.
   sgStatement = 6 'Statement, 5 1/2 x 8 1/2 in.
   sgExecutive = 7 'Executive, 7 1/2 x 10 1/2 in.
   sgA3 = 8 'A3, 297 x 420 mm
   sgA4 = 9 'A4, 210 x 297 mm
   sgA4Small = 10 'A4 Small, 210 x 297 mm
   sgA5 = 11 'A5, 148 x 210 mm
   sgB4 = 12 'B4, 250 x 354 mm
   sgB5 = 13 'B5, 182 x 257 mm
   sgFolio = 14 'Folio, 8 1/2 x 13 in.
   sgQuarto = 15 'Quarto, 215 x 275 mm
   sg10x14 = 16 '10 x 14 in.
   sg11x17 = 17 '11 x 17 in.
   sgNote = 18 'Note, 8 1/2 x 11 in.
   sgEnv9 = 19 'Envelope #9, 3 7/8 x 8 7/8 in.
   sgEnv10 = 20 'Envelope #10, 4 1/8 x 9 1/2 in.
   sgEnv11 = 21 'Envelope #11, 4 1/2 x 10 3/8 in.
   sgEnv12 = 22 'Envelope #12, 4 1/2 x 11 in.
   sgEnv14 = 23 'Envelope #14, 5 x 11 1/2 in.
   sgCSheet = 24 'C size sheet
   sgDSheet = 25 'D size sheet
   sgESheet = 26 'E size sheet
   sgEnvDL = 27 'Envelope DL, 110 x 220 mm
   sgEnvC3 = 29 'Envelope C3, 324 x 458 mm
   sgEnvC4 = 30 'Envelope C4, 229 x 324 mm
   sgEnvC5 = 28 'Envelope C5, 162 x 229 mm
   sgEnvC6 = 31 'Envelope C6, 114 x 162 mm
   sgEnvC65 = 32 'Envelope C65, 114 x 229 mm
   sgEnvB4 = 33 'Envelope B4, 250 x 353 mm
   sgEnvB5 = 34 'Envelope B5, 176 x 250 mm
   sgEnvB6 = 35 'Envelope B6, 176 x 125 mm
   sgEnvItaly = 36 'Envelope, 110 x 230 mm
   sgEnvMonarch = 37 'Envelope Monarch, 3 7/8 x 7 1/2 in.
   sgEnvPersonal = 38 'Envelope, 3 5/8 x 6 1/2 in.
   sgFanfoldUS = 39 'U.S. Standard Fanfold, 14 7/8 x 11 in.
   sgFanfoldStdGerman = 40 'German Standard Fanfold, 8 1/2 x 12 in.
   sgFanfoldLglGerman = 41 'German Legal Fanfold, 8 1/2 x 13 in.
   sgUser = 256 'User-defined
End Enum
' Mod DECLARES
' Mod VARIABLES
'---BeeGrid-----------------
Private mGrid As SGGrid
Private mGridProps As CGrid
Public hImageList As Long
'---Printer-----------------
Private msDeviceName As String
Private miPrinterOrientation As sgOrientation
'---Preview-----------------
Private WithEvents mPreview As PictureBox
Attribute mPreview.VB_VarHelpID = -1
'---Pages-------------------
Private WithEvents mPages As Pages
Attribute mPages.VB_VarHelpID = -1
Private mobjCurrPage As Page
Private mbRecalcPages As Boolean
Private mDevice As ISGDevice




Private Function CreateHeading(hdc As Long) As Long
   Dim rc As RECT, pt As POINTAPI
   Dim row As SGRow, I%
   Dim cell As SGCell
   Dim sCaption As String
   Dim hbr As Long, pcs As PageColumns
   Dim pc As PageColumn
   Dim styapp As sgStyleAppearance

   Set row = mGrid.Rows.At(0)

   Call mGridProps.GetStyleAppearance("Heading", styapp)

   hbr = CreateSolidBrush(styapp.BackColor)
   Set pcs = mGridProps.GetPageColumns(mobjCurrPage.Index)

   'use font from Heading style
   Call mGridProps.SetFontFromStyle(mDevice, "Heading")

   For Each pc In pcs
      Set cell = row.Cells(pc.Position)

      SetCellRect rc, pc, 0, cell.Height

      FillRect hdc, rc, hbr
      If styapp.GridLines Then
         MoveToEx hdc, rc.Left, rc.Top, pt
         DrawLine hdc, styapp.BorderColor, rc.Right, rc.Top
         DrawLine hdc, styapp.BorderColor, rc.Right, rc.Bottom
         DrawLine hdc, styapp.BorderColor, rc.Left, rc.Bottom
         DrawLine hdc, styapp.BorderColor, rc.Left, rc.Top
         MoveToEx hdc, rc.Right, rc.Top, pt
         DrawLine hdc, styapp.BorderColor, rc.Right, rc.Bottom + 1
      End If
      If Not styapp.Flat Then
         rc.Left = rc.Left + 1: rc.Top = rc.Top + 1
         MoveToEx hdc, rc.Left, rc.Bottom - 1, pt
         DrawLine hdc, styapp.BorderHighlight, rc.Left, rc.Top
         DrawLine hdc, styapp.BorderHighlight, rc.Right, rc.Top
      End If

      rc.Left = rc.Left + 1: rc.Top = rc.Top + 1

      sCaption = cell.Column.Caption

      If Len(sCaption) = 0 Then
         sCaption = cell.Column.Key
      End If

      DrawText hdc, sCaption, Len(sCaption), rc, pc.HeaderTextAlignment
   Next

   CreateHeading = rc.Right
   Call DeleteObject(hbr)
   'delete fonts
   mGridProps.DeleteFont hdc
End Function

Private Sub GetPrinterProps()

   On Error Resume Next

   If Printer Is Nothing Then Exit Sub

   Printer.ScaleMode = 3 'twips
   Printer.Orientation = miPrinterOrientation

   If Printer.PaperSize = sgUser Then
      If miPrinterOrientation = sgPortrait Then
         Printer.Width = PrinterWidth
         Printer.Height = PrinterHeight
      Else
         Printer.Height = PrinterWidth
         Printer.Width = PrinterHeight
      End If
   Else
      If miPrinterOrientation = sgPortrait Then
         PrinterWidth = Printer.Width
         PrinterHeight = Printer.Height
      Else
         PrinterWidth = Printer.Height
         PrinterHeight = Printer.Width
      End If
   End If

   If Not mPreview Is Nothing Then
      mPreview.Width = PrinterWidth
      mPreview.Height = PrinterHeight
   End If

   msDeviceName = Printer.DeviceName

   mbRecalcPages = True
End Sub

'********************************************************************************
'* Name: Printing
'* Description: Print the grid to the particular DC
'*
'* Parameters: hdc - printer or picture box DC
'* Created: Goran Borevkovic 04.12.2000 12:41:03
'********************************************************************************
Friend Sub Printing(hdc As Long)
   Dim rc As RECT, rcImg As RECT, pt As POINTAPI
   Dim cell As SGCell, row As SGRow, sCaption$
   Dim lTop As Long, lOldTop As Long
   Dim lBorderColor As Long, lBorder3D As Long
   Dim iHeadingCol As Integer
   Dim lWidth As Long, lHeight As Long
   Dim I As Long, j As Integer
   Dim pc As PageColumn, pcs As PageColumns
   Dim lForeColor As Long
   Dim styapp As sgStyleAppearance
   Dim stygrp As sgStyleAppearance
   Dim hbr As Long, lPadding As Long
   Dim clsPicture As New CCellPicture

   If mGrid Is Nothing Then Exit Sub

   On Error GoTo PrintingError
   'remove col heading
   clsPicture.Destination = Destination
   mGrid.RedrawEnabled = False
   iHeadingCol = mGrid.HeadingColCount
   mGrid.HeadingColCount = 0
   'print header
   lWidth = CreateHeading(hdc)
   'use font from Normal style
   Call mGridProps.SetFontFromStyle(mDevice, "Normal")
   'get border color
   lBorderColor = GetSysColor(COLOR_BTNFACE)

   lOldTop = mGridProps.CalculateHeight(mGrid.Rows.At(I).Height)
   Call mGridProps.GetStyleAppearance("Normal", styapp)

   Set pcs = mGridProps.GetPageColumns(mobjCurrPage.Index)
   clsPicture.ImageList = hImageList

   For I = mobjCurrPage.FirstRow To mobjCurrPage.LastRow
      Set row = mGrid.Rows.At(I)
      rc.Left = mPages.Margins.Left / mDevice.TwipsPerPixelX
      rc.Top = ((lOldTop + mPages.Margins.Top) / mDevice.TwipsPerPixelY)
      lHeight = mGridProps.CalculateHeight(row.Cells(0).Height)
      rc.Right = lWidth: rc.Bottom = (lHeight / mDevice.TwipsPerPixelY) + rc.Top

      Select Case row.Type
         Case sgSimpleRow
            rc.Top = rc.Top - 1
            If styapp.GridLines Then
               MoveToEx hdc, rc.Right, rc.Top, pt
               DrawLine hdc, lBorderColor, rc.Right, rc.Bottom
               DrawLine hdc, lBorderColor, rc.Left, rc.Bottom
               DrawLine hdc, lBorderColor, rc.Left, rc.Top
            End If

            For Each pc In pcs
               Set cell = row.Cells(pc.Position)
               SetCellRect rc, pc, lOldTop, lHeight

               If styapp.GridLines Then
                  MoveToEx hdc, rc.Right, rc.Top, pt
                  DrawLine hdc, lBorderColor, rc.Right, rc.Bottom + 1
               End If

               If cell.Style.DisplayType = sgDisplayPicture Or _
                     cell.Style.DisplayType = sgDisplayTextAndPicture Then
                  clsPicture.PictureAlignment = pc.PictureAlignment
                  clsPicture.DrawPicture hdc, cell, rc.Left, rc.Top, rc.Right, rc.Bottom
                  rc.Left = clsPicture.TextLeft
                  rc.Right = clsPicture.TextRight
               End If

               If cell.Style.DisplayType = sgDisplayText Or _
                  cell.Style.DisplayType = sgDisplayTextAndPicture Then
                  If Not IsNull(cell.Value) Then
                     lPadding = pc.Padding / mDevice.TwipsPerPixelX
                     rc.Left = rc.Left + lPadding: rc.Top = rc.Top + lPadding
                     rc.Right = rc.Right - lPadding: rc.Bottom = rc.Bottom - lPadding
                     sCaption = cell.Value
                     DrawText hdc, sCaption, Len(sCaption), rc, pc.TextAlignment
                  End If
               End If
            Next
         Case sgGroupHeader, sgGroupFooter
               If styapp.GridLines Then
                  MoveToEx hdc, rc.Right, rc.Top, pt
                  DrawLine hdc, lBorderColor, rc.Right, rc.Bottom
                  DrawLine hdc, lBorderColor, rc.Left, rc.Bottom
                  DrawLine hdc, lBorderColor, rc.Left, rc.Top
               End If
               mGridProps.DeleteFont hdc
               If row.Type = sgGroupHeader Then
                  Call mGridProps.SetFontFromStyle(mDevice, "GroupHeader")
                  Call mGridProps.GetStyleAppearance("GroupHeader", stygrp)
               Else
                  Call mGridProps.SetFontFromStyle(mDevice, "GroupFooter")
                  Call mGridProps.GetStyleAppearance("GroupFooter", stygrp)
               End If

               If stygrp.BackColor <> vbWhite Then
                  hbr = CreateSolidBrush(stygrp.BackColor)
                  FillRect hdc, rc, hbr
                  Call DeleteObject(hbr)
               End If

               sCaption = row.Cells(0).Value
               rc.Left = rc.Left + 2
               rc.Top = rc.Top + 2
               DrawText hdc, sCaption, Len(sCaption), rc, 0

               mGridProps.DeleteFont hdc
               Call mGridProps.SetFontFromStyle(mDevice, "Normal")
      End Select
      lOldTop = lOldTop + lHeight
   Next

   mGrid.HeadingColCount = iHeadingCol
   mGrid.RedrawEnabled = True
   'delete fonts
   mGridProps.DeleteFont hdc
   Exit Sub
PrintingError:
   'MsgBox VBA.Error
   'Debug.Print "Printing: " & VBA.Error
   Resume Next
End Sub

Private Sub DrawLine(hdc As Long, clr As Long, x As Long, Y As Long)
   Dim hPen As Long
   Dim hOldPen As Long
   ' Create pen
   hPen = CreatePen(0, 1, clr)
   hOldPen = SelectObject(hdc, hPen)
   LineTo hdc, x, Y
   ' Release pen
   SelectObject hdc, hOldPen
   DeleteObject hPen
End Sub

'********************************************************************************
'* Name: PrintGrid
'* Description:
'*
'* Parameters:
'* Created: Goran Borevkovic 11.12.2000 13:22:01
'********************************************************************************
Public Sub PrintGrid()
   Dim hdc As Long
   Dim lpdi As DOCINFO
   Dim I As Long

   On Error Resume Next

   RecalcPages

   If mPages.Count = 0 Then Exit Sub

   Select Case miDestination
      Case sgPreview
         Set mDevice = New CPreview
         Set mDevice.Destination = mPreview
      Case sgPrint
         Set mDevice = New CPrinter
   End Select

   Set mobjCurrPage = mPages(1)

   Set mDevice.PrintGrid = Me

   mDevice.PrintReport

End Sub

Private Sub SetCellRect(rc As RECT, pc As PageColumn, lTop As Long, lHeight As Long)

   rc.Left = ((pc.Left + mPages.Margins.Left) / mDevice.TwipsPerPixelX)
   rc.Top = ((lTop + mPages.Margins.Top) / mDevice.TwipsPerPixelY)

   rc.Right = (pc.Width / mDevice.TwipsPerPixelX) + rc.Left
   rc.Bottom = (lHeight / mDevice.TwipsPerPixelY) + rc.Top

End Sub
Friend Sub PreviewPage(direction As String)

   Select Case direction
      Case S_CMD_FIRST
         mPages.CurrentPage = 1
      Case S_CMD_PREV
         If mobjCurrPage.Index > 1 Then _
            mPages.CurrentPage = mobjCurrPage.Index - 1
      Case S_CMD_NEXT
         If mobjCurrPage.Index < mPages.Count Then _
            mPages.CurrentPage = mobjCurrPage.Index + 1
      Case S_CMD_LAST
         mPages.CurrentPage = mPages.Count
   End Select

End Sub

Private Sub SetPrinterProp()
   On Error Resume Next

   Exit Sub
   '---Set printer-----
   If Len(msDeviceName) = 0 Then
      msDeviceName = Printer.DeviceName
   Else
      If Printer.DeviceName <> msDeviceName Then
         Dim oPrinter As Printer

         For Each oPrinter In Printers
            If oPrinter.DeviceName = msDeviceName Then
               Set Printer = oPrinter
               Exit For
            End If
         Next
      End If
   End If

   If Printer.PaperSize = vbPRPSUser Then  'User-defined
      Printer.Width = mPages.PrinterWidth
      Printer.Height = mPages.PrinterHeight
   End If

   Printer.Orientation = miPrinterOrientation
End Sub



Private Sub Class_Initialize()
   Set mPages = New Pages

   miDestination = sgPrint
   miPrinterOrientation = Printer.Orientation
   GetPrinterProps
End Sub

Private Sub Class_Terminate()

   Set mDevice = Nothing
   '---del controls----------
   Set mPreview = Nothing
   '---del print items
   Set mGridProps = Nothing
   Set mGrid = Nothing
   Set mobjCurrPage = Nothing
   Set mPages = Nothing
End Sub




Public Property Get PrinterWidth() As Single
   PrinterWidth = mPages.PrinterWidth
End Property

Public Property Let PrinterWidth(ByVal vNewValue As Single)
   mPages.PrinterWidth = vNewValue
   If Printer.PaperSize = sgUser Then
      GetPrinterProps
   End If
End Property

Public Property Get PrinterHeight() As Single
   PrinterHeight = mPages.PrinterHeight
End Property

Public Property Let PrinterHeight(ByVal vNewValue As Single)
   mPages.PrinterHeight = vNewValue
   If Printer.PaperSize = sgUser Then
      GetPrinterProps
   End If
End Property





Private Sub mPages_Change()
   If mPages Is Nothing Then Exit Sub

   On Error Resume Next

   Set mobjCurrPage = mPages(mPages.CurrentPage)

   If mobjCurrPage Is Nothing Then Exit Sub

   mDevice.PrintReport
   mPreview.Refresh

   RaiseEvent ChengePage(mobjCurrPage.Index)
End Sub

Private Sub mPages_Refresh()
   mbRecalcPages = True
End Sub

Private Sub mPreview_Paint()
   If mDevice Is Nothing Then Exit Sub

   mDevice.Paint
End Sub

Public Property Get DeviceName() As String
   DeviceName = msDeviceName
End Property

Public Property Let DeviceName(ByVal vNewValue As String)
   msDeviceName = vNewValue
End Property


Public Property Get PrinterOrientation() As sgOrientation
   PrinterOrientation = miPrinterOrientation
End Property

Public Property Let PrinterOrientation(ByVal vNewValue As sgOrientation)
   miPrinterOrientation = vNewValue
   GetPrinterProps
End Property

Public Property Get PaperSize() As sgPaperSize
   PaperSize = Printer.PaperSize
End Property

Public Property Let PaperSize(ByVal vNewValue As sgPaperSize)
   On Error GoTo PaperSizeError

   Printer.PaperSize = vNewValue
   GetPrinterProps

   Exit Property
PaperSizeError:
   MsgBox VBA.Error, vbExclamation
   Exit Property
End Property





Public Property Get Grid() As Object
   Set Grid = mGrid
End Property

Public Property Set Grid(ByVal vNewValue As Object)
   Set mGrid = vNewValue
   Set mGridProps = New CGrid
   Set mGridProps.Grid = mGrid
End Property

'********************************************************************************
'* Name: RecalcPages
'* Description:
'*
'* Parameters:
'* Created: Goran Borevkovic 04.12.2000 12:42:48
'********************************************************************************
Friend Sub RecalcPages()
   Dim cell As SGCell, row As SGRow
   Dim col As SGColumn, iLastCol As Integer, lLastRow As Long
   Dim lTop As Long, lOldTop As Long
   Dim lWidth As Long, lHeight As Long
   Dim iHeadingCol As Integer, iHeadingRow%, I&
   Dim colPage As New Collection
   Dim pg As Page, lCurrLeft As Long
   Dim pgcols As PageColumns, lPage As Long
   Dim pgcol As PageColumn

   On Error GoTo RecalcPagesError

   If Not mbRecalcPages Then Exit Sub

   If mGrid Is Nothing Then Exit Sub

   mGrid.RedrawEnabled = False
   iHeadingCol = mGrid.HeadingColCount
   iHeadingRow = mGrid.HeadingRowCount
   mGrid.HeadingColCount = 0

   mGridProps.ClearPageCols
   mPages.Clear
   Set pgcols = mGridProps.AddPageColumns

   For I = 0 To mGrid.Columns.Count - 1
      Set col = mGrid.Columns.At(I)
      If Not col.Hidden Then
         lWidth = lWidth + mGridProps.CalculateWidth(col.Width)
         If lWidth >= mPages.ScaleWidth Then
            colPage.Add mPages.Add(iLastCol, I - 1)
            iLastCol = I: lCurrLeft = 0
            lWidth = mGridProps.CalculateWidth(col.Width)
            Set pgcols = mGridProps.AddPageColumns
         End If
         Set pgcol = pgcols.Add(CInt(I), lCurrLeft, mGridProps.CalculateWidth(col.Width))
         pgcol.TextAlignment = mGridProps.GetColAlignment(col)
         pgcol.HeaderTextAlignment = mGridProps.GetColAlignment(col, True)
         pgcol.Padding = mGridProps.GetPadding(col)
         pgcol.PictureAlignment = mGridProps.GetPictureAlignment(col)
         lCurrLeft = lCurrLeft + mGridProps.CalculateWidth(col.Width)
      End If
   Next

   colPage.Add mPages.Add(iLastCol, mGrid.Columns.Count - 1)
   lHeight = mGridProps.CalculateHeight(mGrid.Rows.At(0).Height)

   For I = iHeadingRow To mGrid.Rows.Count - 1
      Set row = mGrid.Rows.At(I)
      lHeight = lHeight + mGridProps.CalculateHeight(row.Height)
      If lHeight >= mPages.ScaleHeight Then
         If lLastRow = 0 Then
            For Each pg In mPages
               pg.FirstRow = iHeadingRow: pg.LastRow = I - 1
               lPage = lPage + 1
               RaiseEvent LoadPages(lPage)
            Next
         Else
            For Each pg In colPage
               Call mPages.Add(pg.FirstColumn, pg.LastColumn, lLastRow, I - 1)
               lPage = lPage + 1
               RaiseEvent LoadPages(lPage)
            Next
         End If
         lHeight = mGridProps.CalculateHeight(mGrid.Rows.At(0).Height)
         lHeight = lHeight + mGridProps.CalculateHeight(row.Height)
         lLastRow = I
      End If
   Next

   If lLastRow <> mGrid.Rows.Count - 1 Then
         If lLastRow = 0 Then
            For Each pg In mPages
               pg.FirstRow = iHeadingRow: pg.LastRow = mGrid.Rows.Count - 1
               lPage = lPage + 1
               RaiseEvent LoadPages(lPage)
            Next
         Else
            For Each pg In colPage
               Call mPages.Add(pg.FirstColumn, _
                  pg.LastColumn, lLastRow, mGrid.Rows.Count - 1)
               lPage = lPage + 1
               RaiseEvent LoadPages(lPage)
            Next
         End If
   End If

   mGrid.HeadingColCount = iHeadingCol
   mGrid.RedrawEnabled = True
   mbRecalcPages = False
   Exit Sub
RecalcPagesError:
   MsgBox VBA.Error, vbExclamation
   Exit Sub
End Sub


Public Property Get Pages() As Pages
   Set Pages = mPages
End Property

Public Property Set Pages(ByVal vNewValue As Pages)
   Set mPages = Pages
End Property




Friend Property Get Container() As PictureBox
   Set Container = mPreview
End Property

Friend Property Set Container(ByVal vNewValue As PictureBox)
   Set mPreview = vNewValue

   mPreview.Width = PrinterWidth
   mPreview.Height = PrinterHeight
End Property

Friend Property Get Destination() As sgDestination
   Destination = miDestination
End Property

Friend Property Let Destination(ByVal vNewValue As sgDestination)
   miDestination = vNewValue
End Property

Friend Property Get SelectedPage() As Page
   Set SelectedPage = mobjCurrPage
End Property

Friend Property Set SelectedPage(ByVal vNewValue As Page)
   Set mobjCurrPage = vNewValue
End Property