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 |
|
|