modpreviewdata.bas

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

    NumRecs = 0
    NumPages = 0

    For j = 0 To 2
        FieldNo(j) = -1
    Next j
'find and store which fields (by number) - if any - are used for sorting
    For j = 0 To 2
        If strSortField(j) > "" Then
            For i = 0 To rstData.Fields.count - 1
                If rstData.Fields(i).Name = ReportFile.SortField(j) Then
                    FieldNo(j) = i
                End If
            Next i
        End If
    Next j
    
'set up the report page scalemode, size, orientation
    rstData.MoveFirst
    PageNo = 0
    PP.Cls
    With PP.Pages
        .ScaleMode = vbInches
        If ReportFile.Orient = cPortrait Then
            .Landscape = False
        Else
            .Landscape = True
        End If
        .width = ReportFile.PageWd
        .Height = ReportFile.PageHt
        .Add
    End With
    PageNo = PageNo + 1
        
    With ReportFile
        PageFreeWd = .DesWd
'main loop for report
        Do While Not EndOfReport
'set up free space for first page
            If PageNo = 1 Then
                PageFreeHt = .PageHt - .TMarg - .BMarg - .HeaderHt(0) - .HeaderHt(1) - .FooterHt(1)
                If .SectColor(0) <> vbWhite Then
                    PP.Pages.ActivePage.DrawShape 0, .LMarg, .TMarg, PageFreeWd, .HeaderHt(0), -1, .SectColor(0)
                End If
                If .SectColor(1) <> vbWhite Then
                    PP.Pages.ActivePage.DrawShape 0, .LMarg, .TMarg + .HeaderHt(0), PageFreeWd, .HeaderHt(1), -1, .SectColor(1)
                End If
                If .SectColor(9) <> vbWhite Then
                    PP.Pages.ActivePage.DrawShape 0, .LMarg, .PageHt - .BMarg - .FooterHt(1), PageFreeWd, .FooterHt(1), -1, .SectColor(9)
                End If
                For i = 1 To UBound(.RpControl)
                    If ReportFile.RpControl(i).SecNo = 0 Then
                        DrawObject i, ReportFile.TMarg
                    ElseIf ReportFile.RpControl(i).SecNo = 1 Then
                        If i <> TotalPageControlNum Then
                            DrawObject i, .TMarg + .HeaderHt(0)
                        End If
                    ElseIf ReportFile.RpControl(i).SecNo = 9 Then
                        If i <> TotalPageControlNum Then
                            DrawObject i, .PageHt - .BMarg - .FooterHt(1)
                        End If
                    End If
                Next i
                TopOfFreeSpace = ReportFile.TMarg + .HeaderHt(0) + .HeaderHt(1)
'set up free space for all other pages
            Else
                PageFreeHt = .PageHt - .TMarg - .BMarg - .HeaderHt(1) - .FooterHt(1)
                If .SectColor(1) <> vbWhite Then
                    PP.Pages.ActivePage.DrawShape 0, .LMarg, .TMarg, PageFreeWd, .HeaderHt(1), -1, .SectColor(1)
                End If
                If .SectColor(9) <> vbWhite Then
                    PP.Pages.ActivePage.DrawShape 0, .LMarg, .PageHt - .BMarg - .FooterHt(1), PageFreeWd, .FooterHt(1), -1, .SectColor(9)
                End If
                For i = 1 To UBound(.RpControl)
                    If ReportFile.RpControl(i).SecNo = 1 Then
                        If i <> TotalPageControlNum Then
                            DrawObject i, .TMarg
                        End If
                    ElseIf ReportFile.RpControl(i).SecNo = 9 Then
                        If i <> TotalPageControlNum Then
                            DrawObject i, .PageHt - .BMarg - .FooterHt(1)
                        End If
                    End If
                Next i
                TopOfFreeSpace = ReportFile.TMarg + .HeaderHt(1)
            End If
            CurrPagePos = TopOfFreeSpace
            EndOfPage = False
            
'loop for each page
            Do While Not EndOfPage
' process group headers
                If Not rstData.EOF Then
                    For j = 0 To 2
                        If .HeaderVis(j + 2) Then
                            If rstData.Fields(FieldNo(j)) <> PrevValue(j) Then
                                If CurrPagePos + .HeaderHt(j + 2) < PageFreeHt + TopOfFreeSpace Then
                                    If .SectColor(j + 2) <> vbWhite Then
                                        PP.Pages.ActivePage.DrawShape 0, .LMarg, CurrPagePos, PageFreeWd, .HeaderHt(j + 2), -1, .SectColor(j + 2)
                                    End If
                                    For i = 1 To UBound(.RpControl)
                                        If .RpControl(i).SecNo = j + 2 Then
                                            DrawObject i, CurrPagePos
                                        End If
                                    Next i
                                    CurrPagePos = CurrPagePos + .HeaderHt(j + 2)
                                Else
                                    EndOfPage = True
                                End If
                            End If
                        End If
                    Next j
                Else
                    EndOfPage = True
                End If
'process detail section
                If Not rstData.EOF Then
                    If CurrPagePos + .DetHt < PageFreeHt + TopOfFreeSpace Then
                        For i = 1 To UBound(.RpControl)
                            If .RpControl(i).SecNo = 5 Then
                                DrawObject i, CurrPagePos
                            End If
                        Next i
                        CurrPagePos = CurrPagePos + .DetHt
                        For i = 0 To 2
                            If FieldNo(i) > -1 Then
                                PrevValue(i) = rstData.Fields(FieldNo(i)).value
                            End If
                        Next i
                        rstData.MoveNext
                    Else
                        EndOfPage = True
                    End If
                Else
                    EndOfPage = True
                End If
'process group footers
                If Not rstData.EOF Then
                    For j = 2 To 0 Step -1
                        If .FooterVis(j + 2) Then
                            If rstData.Fields(FieldNo(j)) <> PrevValue(j) Then
                                If CurrPagePos + .FooterHt(j + 2) < PageFreeHt + TopOfFreeSpace Then
                                    If Not rstData.BOF Then rstData.MovePrevious
                                    For i = 1 To UBound(.RpControl)
                                        If .RpControl(i).SecNo = 8 - j Then
                                            DrawObject i, CurrPagePos
                                        End If
                                    Next i
                                    CurrPagePos = CurrPagePos + .FooterHt(j + 2)
                                    rstData.MoveNext
                                Else
                                    EndOfPage = True
                                End If
                            End If
                        End If
                    Next j
'if at the end of data, do last set of group footers
                Else
                    rstData.MovePrevious
                    For j = 2 To 0 Step -1
                        If .FooterVis(j + 2) Then
                            If CurrPagePos + .FooterHt(j + 2) < PageFreeHt + TopOfFreeSpace Then
                                For i = 1 To UBound(.RpControl)
                                    If .RpControl(i).SecNo = 8 - j Then
                                        DrawObject i, CurrPagePos
                                    End If
                                Next i
                                CurrPagePos = CurrPagePos + .FooterHt(j + 2)
                            Else
                                EndOfPage = True
                            End If
                        End If
                    Next j
                    EndOfPage = True
                    rstData.MoveNext
                End If
                
            Loop
            
'if not at the end of data, add another page
            If Not rstData.EOF Then
                PP.Pages.Add
                PageNo = PageNo + 1
'if at the end of data do report footer
            Else
'if it fits put it in
                If CurrPagePos + .FooterHt(0) < PageFreeHt + TopOfFreeSpace Then
                    For i = 1 To UBound(.RpControl)
                        If ReportFile.RpControl(i).SecNo = 10 Then
                            DrawObject i, CurrPagePos
                        End If
                    Next i
'otherwise add another page and put it in
                Else
                    PP.Pages.Add
                    PageNo = PageNo + 1
                    PageFreeHt = .PageHt - .TMarg - .BMarg - .HeaderHt(1) - .FooterHt(1)
                    For i = 1 To UBound(.RpControl)
                        If ReportFile.RpControl(i).SecNo = 1 Then
                            If i <> TotalPageControlNum Then
                                DrawObject i, .TMarg
                            End If
                        ElseIf ReportFile.RpControl(i).SecNo = 9 Then
                            If i <> TotalPageControlNum Then
                                DrawObject i, .PageHt - .BMarg - .FooterHt(1)
                            End If
                        End If
                    Next i
                    CurrPagePos = ReportFile.TMarg + .HeaderHt(1)
                    For i = 1 To UBound(.RpControl)
                        If ReportFile.RpControl(i).SecNo = 10 Then
                            DrawObject i, CurrPagePos
                        End If
                    Next i
                End If
                EndOfReport = True
            End If
            
        Loop
        
        NumPages = PageNo
        If TotalPageControlNum > -1 Then
            For i = 1 To NumPages
                PageNo = i
                If TotPageControlSection = 9 Then
                    CurrPagePos = .BMarg - .FooterHt(1)
                ElseIf i = 1 Then
                    CurrPagePos = .TMarg + .HeaderHt(0)
                Else
                    CurrPagePos = .TMarg
                End If
                PP.Pages.SelectPage CLng(i)
                DrawObject TotalPageControlNum, CurrPagePos
            Next i
        End If
    
    End With
    
    Exit Sub


NoGenerate:

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

End Sub

Public Sub DrawObject(Index As Integer, TopOffset As Single)
On Error GoTo NoDraw
Dim i As Integer, j As Integer
Dim strFieldName As String
Dim strFValue As String
Dim bkcolor As Long
Dim bdrcolor As Long
Dim GetPic As StdPicture
Dim strGetFormat As String
Dim AggFunc As String
Dim ctlwidth As Single
Dim ctlheight As Single

With ReportFile.RpControl(Index)

    If .BdrStl = 0 Then
        bdrcolor = -1
    Else
        bdrcolor = .BdrClr
    End If
    
    If .BckStl = 0 Then
        bkcolor = -1
    Else
        bkcolor = .BckClr
    End If
    
    ctlwidth = .width
    ctlheight = .Height
    
    If .Type = cLine Then
        PP.Pages.ActivePage.DrawLine ReportFile.LMarg + .X1, TopOffset + .Y1, _
        ReportFile.LMarg + .X2, TopOffset + .Y2, .BdrClr, .BdrWd, .BdrStl - 1
    ElseIf .Type = cBox Then
        PP.Pages.ActivePage.DrawShape .DisplayType, ReportFile.LMarg + .Left, TopOffset + .Top, _
        ctlwidth, ctlheight, bdrcolor, bkcolor, .BdrWd, .BdrStl - 1
    ElseIf .Type = cLabel Then       'label control used for labels and fields on the report
        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 .strText, ReportFile.LMarg + .Left + 0.01, TopOffset + .Top + 0.01, _
        ctlwidth - 0.02, ctlheight - 0.02, .ForClr, bkcolor, .Align
        
'check for either a database field or a special field with date, page no., etc.
    ElseIf .Type = cDataField Or .Type = cDatePageField Or .Type = cCalcField Or .Type = cSumField Then
        strFValue = "Error!"
        If .Type = cDatePageField Then
            If InStr(1, .strText, "=[Date") > 0 Then
                strFValue = Trim(.strText)
                strFValue = Mid(strFValue, 8, Len(strFValue) - 8)
                If Left(strFValue, 4) = "wwww" Then