modpreviewdata.bas

VB做的报表设计源程序,非常不错,可以自定义模版

                    strFValue = FormatDateTime(Now(), vbLongDate)
                Else
                    strFValue = Format(Now(), strFValue)
                End If
            ElseIf InStr(1, .strText, "[PageNo]") > 0 Then
                strFValue = "Page " & PageNo
                If InStr(1, .strText, "[NumPages]") > 0 Then
                    strFValue = strFValue & " of " & NumPages
                End If
            End If
        ElseIf .Type = cCalcField Then
            If ReportFile.DataBound Then
                Dim strOper As String
                Dim strGetField As String
                Dim strRemainder As String
                Dim strModified As String
                Dim StartNextField As Integer
                Dim EndLastField As Integer
                Dim blnFieldFound As Boolean
                StartNextField = 1
                EndLastField = 1
                strRemainder = Mid(.strText, 3, InStr(1, .strText, "}") - 3) 'parse out stuff in curly brackets
                blnFieldFound = True
                Do While blnFieldFound
                    StartNextField = InStr(1, strRemainder, "[")
                    If StartNextField > 0 Then
                        blnFieldFound = True
                        strModified = strModified & Mid(strRemainder, EndLastField, StartNextField - EndLastField)
                        strRemainder = Right(strRemainder, Len(strRemainder) - StartNextField)
                        strGetField = Left(strRemainder, InStr(1, strRemainder, "]") - 1)
                        EndLastField = InStr(1, strRemainder, "]") + 1
                        For i = 0 To rstData.Fields.count - 1
                            If rstData.Fields(i).Name = strGetField Then
                                strModified = strModified & Str(rstData.Fields(i).value)
                                Exit For
                            End If
                        Next i
                    Else
                        blnFieldFound = False
                    End If
                Loop
            End If
            If Len(strRemainder) > EndLastField - 1 Then
                strModified = strModified & Right(strRemainder, Len(strRemainder) - (EndLastField - 1))
            End If
            strFValue = Eval(strModified)
            SaveCalc(CalcNum).strFieldName = .Fieldname
            SaveCalc(CalcNum).strValue = strFValue
            CalcNum = CalcNum + 1
        ElseIf .Type = cSumField Then
            If ReportFile.DataBound Then
                Dim rst As ADODB.Recordset
                Dim TotalNum As Double
                Dim AvgNum As Double
                Dim MinNum As Double
                Dim MaxNum As Double
                Dim count As Integer
                Dim strFilter As String
                AggFunc = Mid(.strText, 3, 5)
                Set rst = rstData.Clone
                If .SecNo > 5 And .SecNo < 9 Then
                    For i = 0 To (8 - .SecNo)
                        If ReportFile.SortField(i) > "" Then
                            If strFilter > "" Then
                                strFilter = strFilter & " AND " & ReportFile.SortField(i) & " = '" & CStr(rstData.Fields(FieldNo(i)).value) & "'"
                            Else
                                strFilter = ReportFile.SortField(i) & " = '" & CStr(rstData.Fields(FieldNo(i)).value) & "'"
                            End If
                        End If
                    Next i
                    rst.filter = strFilter
                End If
                rst.MoveFirst
                For i = 0 To rst.Fields.count - 1
                    If rst.Fields(i).Name = .Fieldname Then
                        MinNum = rst.Fields(i).value
                        For j = 0 To rst.RecordCount - 1
                            TotalNum = TotalNum + Abs(rst.Fields(i).value)
                            If rst.Fields(i).value < MinNum Then MinNum = rst.Fields(i).value
                            If rst.Fields(i).value > MaxNum Then MaxNum = rst.Fields(i).value
                            count = count + 1
                            If Not rst.EOF Then rst.MoveNext
                        Next j
                        AvgNum = TotalNum / count
                        Select Case AggFunc
                            Case "SumOf": strFValue = TotalNum
                            Case "AvgOf": strFValue = AvgNum
                            Case "MinOf": strFValue = MinNum
                            Case "MaxOf": strFValue = MaxNum
                            Case "CntOf": strFValue = count
                        End Select
                        Exit For
                    End If
                Next i
                Set rst = Nothing
                If blnHasCalcDataFields Then
                    Dim varValue As Variant
                    MinNum = Val(SaveCalc(0).strValue)
                    For i = 0 To UBound(SaveCalc)
                        If SaveCalc(i).strFieldName = .Fieldname Then
                            varValue = Val(SaveCalc(i).strValue)
                            TotalNum = TotalNum + Abs(varValue)
                            If varValue < MinNum Then MinNum = varValue
                            If varValue > MaxNum Then MaxNum = varValue
                            count = count + 1
                        End If
                    Next i
                    AvgNum = TotalNum / count
                    Select Case AggFunc
                        Case "SumOf": strFValue = TotalNum
                        Case "AvgOf": strFValue = AvgNum
                        Case "MinOf": strFValue = MinNum
                        Case "MaxOf": strFValue = MaxNum
                        Case "CntOf": strFValue = count
                    End Select
                End If
            End If
        Else
            If ReportFile.DataBound Then
                If Not rstData.EOF Then
                    For i = 0 To UBound(DataField) - 1
                        If DataField(i, 0) = .Fieldname Then
                            strFValue = rstData.Fields(i).value
                            Exit For
                        End If
                    Next i
                End If
            End If
        End If
        If InStr(1, .strText, "|") > 0 Then
            strGetFormat = Right(.strText, Len(.strText) - (InStr(1, .strText, "|")))
            If strGetFormat = "(Whole)" Then
                strFValue = FormatNumber(strFValue, 0, vbFalse, vbFalse)
            ElseIf Left(strGetFormat, 8) = "(Decimal" Then
                strFValue = FormatNumber(strFValue, Val(Mid(strGetFormat, 10, 2)))
            ElseIf Left(strGetFormat, 8) = "(Percent" Then
                strFValue = FormatPercent(strFValue, Val(Mid(strGetFormat, 10, 2)))
            ElseIf Left(strGetFormat, 9) = "(Currency" Then
                strFValue = FormatCurrency(strFValue)
            ElseIf Left(strGetFormat, 5) = "(Date" Then
                If Mid(strGetFormat, 7, 4) = "wwww" Then
                    strFValue = FormatDateTime(strFValue, vbLongDate)
                Else
                    strFValue = Format(strFValue, Mid(strGetFormat, 7, Len(strGetFormat) - 1 - InStr(1, strGetFormat, ":")))
                End If
            ElseIf Left(strGetFormat, 5) = "(Time" Then
                If Mid(strGetFormat, 7, 5) = "hh:ss" Then
                    strFValue = FormatDateTime(strFValue, vbShortTime)
                ElseIf Mid(strGetFormat, 7, 10) = "h:mm:ss AM" Then
                    strFValue = FormatDateTime(strFValue, vbLongTime)
                End If
            End If
        End If
        If .BckStl = 0 Then
            bkcolor = -1
        Else
            bkcolor = .BckClr
        End If
        
        PP.Pages.ActivePage.DrawShape 0, ReportFile.LMarg + .Left, TopOffset + .Top, _
        ctlwidth, ctlheight, bdrcolor, bkcolor, 1, .BdrStl - 1
        
        PP.Pages.ActivePage.SetFont .FntNam, .FntSiz, .FntBld, .FntItl, .FntUnd, False, 0
        PP.Pages.ActivePage.DrawText strFValue, ReportFile.LMarg + .Left + .BdrWd * 0.01, TopOffset + .Top + .BdrWd * 0.01, _
        ctlwidth - .BdrWd * 0.02, ctlheight - .BdrWd * 0.02, .ForClr, bkcolor, .Align
    
    ElseIf .Type = cBoundImage Then
        If ReportFile.DataBound Then                                    'to dynamically load the picture into the report
            If Not rstData.EOF Then                                     'OLE picture field in Access, which bloats the
                For i = 0 To UBound(DataField) - 1                        'size of the database terribly
                    If DataField(i, 0) = .Fieldname Then
                        strFValue = rstData.Fields(i).value
                        Exit For
                    End If
                Next i
            End If
        End If
        If ReportFile.ImageFolder > "" Then
            PP.Pages.ActivePage.DrawPicture .Left + ReportFile.LMarg, .Top + TopOffset, ctlwidth, ctlheight, LoadPicture(ReportFile.ImageFolder & "\" & strFValue), True
        End If
    ElseIf .Type = cImage Then
        Open App.Path & "\tmpfile" For Binary As #5
        Put 5, , .ImgData
        Close 5
        PP.Pages.ActivePage.DrawPicture ReportFile.LMarg + .Left, .Top + TopOffset, ctlwidth, ctlheight, LoadPicture(App.Path & "\tmpfile"), True
        Kill App.Path & "\tmpfile"
        DoEvents
    ElseIf .Type = cCheckBox Then
        Dim blnValue As Boolean
        If ReportFile.DataBound Then
            If Not rstData.EOF Then                                     'OLE picture field in Access, which bloats the
                For i = 0 To UBound(DataField) - 1                        'size of the database terribly
                    If DataField(i, 0) = .Fieldname Then
                        blnValue = rstData.Fields(i).value
                        Exit For
                    End If
                Next i
            End If
        End If
        PP.Pages.ActivePage.DrawCheckBox .DisplayType, blnValue, .Left + ReportFile.LMarg, _
        .Top + TopOffset, 0.125, 0.166, .ForClr, .BckClr, 1, .Sunken
    End If
    
End With
    
Exit Sub

NoDraw:
    MsgBox "Error in DrawObject : " & Err.Description
    
    
End Sub

Public Sub PreviewWithNoData(GoPreview As Boolean)
'On Error GoTo NoPreview

Dim PgHeadTop As Single
Dim PgFootTop As Single
Dim PageFreeHt As Single
Dim PageFreeWd As Single
Dim DetTop As Single
Dim PageNo As Integer
Dim i As Integer
Dim j As Integer

'set variables for free space heights to be used below
    With ReportFile
        PageFreeHt = .PageHt - .TMarg - .BMarg - .HeaderHt(1) - .FooterHt(1) - .HeaderHt(0) - .FooterHt(0)
        PageFreeWd = .PageWd - .LMarg - .RMarg
    End With

'generate the report page
    Set PP = New Preview
    PageNo = 0
    With PP
        .Cls
        With .Pages
            .ScaleMode = vbInches
            If ReportFile.Orient = cPortrait Then
                .Landscape = False
            Else
                .Landscape = True
            End If
            .width = ReportFile.PageWd
            .Height = ReportFile.PageHt
            .Add
            PageNo = PageNo + 1
            If ReportFile.SectColor(0) <> vbWhite Then
                PP.Pages.ActivePage.DrawShape 0, ReportFile.LMarg, ReportFile.TMarg, _
                PageFreeWd, ReportFile.HeaderHt(0), -1, ReportFile.SectColor(0)
            End If
            PgHeadTop = ReportFile.HeaderHt(0) + ReportFile.TMarg
            If ReportFile.SectColor(1) <> vbWhite Then
                PP.Pages.ActivePage.DrawShape 0, ReportFile.LMarg, PgHeadTop, _
                PageFreeWd, ReportFile.HeaderHt(1), -1, ReportFile.SectColor(1)
            End If
            DetTop = PgHeadTop + ReportFile.HeaderHt(1)
            If ReportFile.SectColor(5) <> vbWhite Then
                PP.Pages.ActivePage.DrawShape 0, ReportFile.LMarg, DetTop, _
                PageFreeWd, ReportFile.DetHt, -1, ReportFile.SectColor(5)
            End If
            If ReportFile.SectColor(9) <> vbWhite Then
                PP.Pages.ActivePage.DrawShape 0, ReportFile.LMarg, DetTop + PageFreeHt, _
                PageFreeWd, ReportFile.FooterHt(9), -1, ReportFile.SectColor(9)
            End If
            If ReportFile.SectColor(10) <> vbWhite Then
                PP.Pages.ActivePage.DrawShape 0, ReportFile.LMarg, DetTop + ReportFile.DetHt, _
                PageFreeWd, ReportFile.FooterHt(0), -1, ReportFile.SectColor(10)
            End If
            For i = 1 To UBound(ReportFile.RpControl)
                If ReportFile.RpControl(i).SecNo = 0 Then
                    DrawObject i, ReportFile.TMarg
                ElseIf ReportFile.RpControl(i).SecNo = 1 Then
                    DrawObject i, PgHeadTop
                ElseIf ReportFile.RpControl(i).SecNo = 5 Then
                    DrawObject i, DetTop
                ElseIf ReportFile.RpControl(i).SecNo = 9 Then
                    DrawObject i, DetTop + PageFreeHt
                ElseIf ReportFile.RpControl(i).SecNo = 10 Then
                    DrawObject i, DetTop + ReportFile.DetHt
                End If
            Next i
        End With
    If GoPreview Then
        .Show
    Else
        .PrintPages
    End If
    End With

'destroy the preview object to free memory
    Set PP = Nothing
    Exit Sub

NoPreview:

    Set PP = Nothing
    MsgBox "Error in PreviewWithNoData : " & Err.Description

End Sub