| T O P I C R E V I E W |
| Waty Thierry |
Posted - 01/26/2004 : 23:14:09
You can see a demo of this generic routine
by downloading the ImmoAssist application on http://www.immoassist.com
Public Sub DoPrintGrid(oPreview As PrintPreview5.Preview, oGrid As ImmoGrid, nCol As Long, Optional bEmpty As Boolean = False)
' #VBIDEUtils#************************************************************
' * Author : Waty Thierry
' * Web Site : http://www.vbdiamond.com
' * E-Mail : waty.thierry@vbdiamond.com
' * Date : 02/06/2003
' * Project Name : ImmoAssist
' * Module Name : Main_Module
' * Module Filename : Main.bas
' * Procedure Name : DoPrintGrid
' * Purpose :
' * Parameters :
' * oPreview As PrintPreview5.Preview
' * oGrid As ImmoGrid
' * nCol As Long
' * Optional bEmpty As Boolean = False
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * Screenshot :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
' #VBIDEUtilsERROR#
On Error GoTo ERROR_DoPrintList
Dim nI As Integer
Dim nJ As Integer
Dim nWidth As Long
Dim oColHeader As New Collection
Dim oColRow As New Collection
Dim oColData As New Collection
Dim oColFormat As New Collection
Dim sFormat As String
Dim sOldFont As String
Dim nOldFontSize As Long
Dim nCurrentHeight As Long
Dim sTmp As String
nWidth = 0
With oPreview
sOldFont = .FontName
nOldFontSize = .FontSize
.FontSize = 8
.FontName = "Arial"
.FontBold = True
.FontUnderline = False
.CurrentX = nCol
' *** Get all the headers and set the formats
For nI = 1 To oGrid.Columns
If oGrid.ColumnVisible(nI) Then
oColHeader.Add oGrid.ColumnHeader(nI)
Else
oColHeader.Add ""
End If
sFormat = vbNullString
Select Case oGrid.ColumnAlign(nI)
Case ecgHdrTextALignCentre
sFormat = "c "
Case ecgHdrTextALignLeft
sFormat = "l "
Case ecgHdrTextALignRight
sFormat = "r "
End Select
sFormat = sFormat & .C_Twips(oGrid.ColumnWidth(nI) & " pt") & ";20"
nWidth = nWidth + .C_Twips(oGrid.ColumnWidth(nI) & " pt") + 20
oColFormat.Add sFormat
oColRow.Add sFormat
Next
If nWidth > .PageWidth Then
.Orientation = prORLandscape
End If
If .CurrentY >= .PageInsideHeight - .PageInsideTop - 300 Then
.AddPageTemplate
End If
' *** First add the headers
.FontBold = True
.Tabulate oColHeader, oColFormat, nCol, , prASCopypage
Set oColData = Nothing
.FontBold = False
' *** Get all data in the grid
For nI = 1 To oGrid.Rows
.FontSize = 8
.FontName = "Courier New"
.FontBold = False
.FontUnderline = False
Set oColData = New Collection
Set oColRow = New Collection
For nJ = 1 To oGrid.Columns
If Len(oGrid.CellFormattedText(nI, nJ)) > 0 Then
If nCurrentHeight < .TextHeight(oGrid.CellFormattedText(nI, nJ)) * (oGrid.EvaluateTextHeight(nI, nJ) / 13) Then
nCurrentHeight = .TextHeight(oGrid.CellFormattedText(nI, nJ)) * (oGrid.EvaluateTextHeight(nI, nJ) / 13)
End If
End If
If oGrid.ColumnVisible(nJ) And (oGrid.CellIcon(nI, nJ) = -1) Then
If oGrid.ColumnWidth(nJ) = 1 Then
sTmp = vbNullString
Else
sTmp = oGrid.CellFormattedText(nI, nJ)
End If
' *** Check if we need to add Carriage Return
sTmp = PrepareLine(sTmp, .C_Twips(oGrid.ColumnWidth(nJ) & " pt") / .TextWidth("A"))
oColData.Add sTmp
oColRow.Add oColFormat(nJ) & ";color=" & oGrid.CellForeColor(nI, nJ)
Else
' *** It is an Icon
If oGrid.CellIcon(nI, nJ) <> -1 Then
' *** Add if text anyway
On Error Resume Next
If oGrid.ColumnWidth(nJ) = 1 Then
sTmp = vbNullString
Else
sTmp = oGrid.CellFormattedText(nI, nJ)
End If
' *** Check if we need to add Carriage Return
sTmp = PrepareLine(sTmp, .C_Twips(oGrid.ColumnWidth(nJ) & " pt") / .TextWidth("A"))
oColData.Add Trim$(sTmp)
oColRow.Add oColFormat(nJ) & ";color=" & oGrid.CellForeColor(nI, nJ)
Err.Clear
On Error GoTo ERROR_DoPrintList
End If
End If
Next
' *** Check if we need to skip before
If .CurrentY + nCurrentHeight >= .PageInsideHeight - .PageInsideTop * 2 - 100 Then
If nI <= oGrid.Rows Then
.AddPageTemplate
' *** Add headers
.FontSize = 8
.FontName = "Arial"
.FontUnderline = False
.FontBold = True
.Tabulate oColHeader, oColFormat, nCol, , prASCopypage
.FontBold = False
End If
End If
.FontSize = 8
.FontName = "Courier New"
.FontBold = False
.FontUnderline = False
.Tabulate oColData, oColRow, nCol, , prASCopypage
Set oColData = Nothing
' *** Skip the page and add the headers
If .CurrentY >= .PageInsideHeight - .PageInsideTop * 2 - 100 Then
If nI < oGrid.Rows Then
.AddPageTemplate
' *** Add headers
.FontSize = 8
.FontName = "Arial"
.FontUnderline = False
.FontBold = True
.Tabulate oColHeader, oColFormat, nCol, , prASCopypage
.FontSize = 8
.FontName = "Courier New"
.FontBold = False
.FontUnderline = False
End If
End If
Set oColData = Nothing
nCurrentHeight = 0
Next
.FontName = sOldFont
.FontSize = nOldFontSize
End With
EXIT_DoPrintList:
On Error Resume Next
Exit Sub
' #VBIDEUtilsERROR#
ERROR_DoPrintList:
Select Case IAErrorHandler("Error " & Err.Number & ": " & Err.Description & vbCrLf & "in DoPrintList", vbAbortRetryIgnore + vbCritical, "Error")
Case vbAbort
Screen.MousePointer = vbDefault
Resume EXIT_DoPrintList
Case vbRetry
Resume
Case vbIgnore
Resume Next
End Select
Resume EXIT_DoPrintList
End Sub
Come and visit :
www.immoassist.com
www.ppreview.net
www.vbdiamond.com
www.d2dsources.com
www.mandix.com |
|
|
