modpreviewdata.bas

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

Attribute VB_Name = "mPreviewData"
'Report File Save Format
'=========================================================================

Public PageScaleUnits As Integer
Public PageNo As Integer
Public NumPages As Integer
Public PgHeadTop As Single
Public PgFootTop As Single
Public PageFreeHt As Single
Public PageFreeWd As Single
Public FirstPgFreeHt As Single
Public LastPgFreeHt As Single
Public DetTop As Single
Public NumRecs As Integer
Public NumRecsFirstPage As Integer
Public NumRecsBodyPage As Integer
Public NumRecsLastPage As Integer
Public SectionTop As Single

Public Type ControlInfo
    Name As String
    Index As Long
    Type As Integer
    SecNo As Integer
    X1 As Single
    Y1 As Single
    X2 As Single
    Y2 As Single
    Left As Single
    Top As Single
    width As Single
    Height As Single
    BdrWd As Integer
    BdrStl As Long
    BdrClr As Long
    BckStl As Integer
    BckClr As Long
    ForClr As Long
    FntNam As String
    FntSiz As Single
    FntBld As Boolean
    FntItl As Boolean
    FntUnd As Boolean
    Align As Long
    strText As String
    ImgData As String
    DisplayType As Integer
    Sunken As Boolean
    Fieldname As String
End Type

Public Type ReportStructure        'saved report file format
    DataBound As Boolean
    DBName As String
    DBSource As String
    HasPics As Boolean
    ImgPathTable As String
    ImgPathField As String
    ImageFolder As String
    SortField(2) As String
    SortDescending(2) As Boolean
    PageSclUnit As Integer
    PageSzNam As String
    PageWd As Single
    PageHt As Single
    Orient As Integer
    LMarg As Single
    RMarg As Single
    TMarg As Single
    BMarg As Single
    DesWd As Single
    HeaderVis(4) As Boolean
    FooterVis(4) As Boolean
    HeaderHt(4) As Single
    FooterHt(4) As Single
    DetHt As Single
    SectColor(10) As Long
    RpControl() As ControlInfo
End Type

'============ Control Type Constants ==========
Public intControlType As Integer       'type of control about to be placed
Public Const cNone = 0
Public Const cDataField = 1                'control type constants
Public Const cLabel = 2
Public Const cCheckBox = 3
Public Const cLine = 4
Public Const cBox = 5
Public Const cImage = 6
Public Const cBoundImage = 7
Public Const cDatePageField = 8
Public Const cCalcField = 9
Public Const cSumField = 10

'============= Page Scale Unit Constants ============
Public Const scEnglish = 0
Public Const scMetric = 1

Public ReportFile As ReportStructure       'for saving report file to disk
Public OpenFileName As String              'name/location of current report file

Private Type CalcInfo
    strFieldName As String
    strValue As String
End Type

Private SaveCalc() As CalcInfo
Private blnHasCalcDataFields As Boolean
Private CalcNum As Integer
Private TotalPageControlNum As Integer
Private TotPageControlSection As Integer

'=========== Preview ==============
Public PP As Preview

'============= ADO Connection ============
Public dbConn As ADODB.Connection
Public rstTables As ADODB.Recordset
Public rstData As ADODB.Recordset
Public strConnErrMsg As String
Public strDataFileName As String
Public strSortField(2) As String
Public blnSortDescending(2) As Boolean
Public strTableName As String
Public DataField() As String
Public FieldNo(2) As Integer


Public Sub UnloadPreview()

    Set PP = Nothing

End Sub

Public Function ConnectToDataFile() As Boolean
On Error GoTo ConnectError
Dim strCnn As String

    strCnn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDataFileName & ";Persist Security Info=False"
    Set dbConn = New ADODB.Connection
    dbConn.Open strCnn        'open connection to database file (MS Access)
    ConnectToDataFile = True
    Exit Function

ConnectError:
    MsgBox Err.Description, vbOKOnly, "Connection Error"
    ConnectToDataFile = False
    strDataFileName = ""
    strConnErrMsg = Err.Description

End Function

Public Function GetTables() As Boolean
On Error GoTo NoTables

    Set rstTables = dbConn.OpenSchema(adSchemaTables)
    GetTables = True
    Exit Function

NoTables:
    GetTables = False
    strConnErrMsg = Err.Description
    MsgBox Err.Description, vbOKOnly, "Connection Error"

End Function

Public Sub OpenData(strTableName As String, Optional GetSort As String)
On Error GoTo NoOpenData
Dim i As Integer

    Set rstData = New ADODB.Recordset
    rstData.Open "Select * from [" & strTableName & "] " & GetSort, dbConn, adOpenStatic, adLockOptimistic, adCmdText

    rstData.MoveLast
    rstData.MoveFirst
    
    ReDim DataField(rstData.Fields.count, 1)
    For i = 0 To UBound(DataField) - 1
        DataField(i, 0) = rstData.Fields(i).Name
        DataField(i, 1) = rstData.Fields(i).Type
    Next i
    
    Exit Sub

NoOpenData:
    MsgBox "Error in OpenData : " & Err.Description

End Sub

Public Sub PreviewReport(GoPreview As Boolean, Optional strFilePath As String = "%Current%", Optional HostWnd As Long)
On Error GoTo NoPreview
Dim i As Integer
Dim Counter As Integer

    If strFilePath <> "%Current%" Then
        If GetReportFile(strFilePath) = False Then
            MsgBox "Could not open '" & strFilePath & "'", vbOKOnly + vbInformation
            Exit Sub
        End If
    End If
        
    If ReportFile.DataBound = False Then
        PreviewWithNoData GoPreview
        Exit Sub
    End If

    With ReportFile
        For i = 0 To UBound(.RpControl)
            If .RpControl(i).Type = cCalcField Then
                Counter = Counter + 1
            ElseIf .RpControl(i).Type = cDatePageField Then
                If InStr(1, .RpControl(i).strText, "[NumPages]") > 0 Then
                    TotalPageControlNum = i
                    TotalPageControlsection = .RpControl(i).SecNo
                End If
            End If
        Next i
    End With
    If Counter > 0 Then
        blnHasCalcDataFields = True
        ReDim SaveCalc((Counter) * rstData.RecordCount)
    End If
    CalcNum = 0

    Set PP = New Preview
    If Not IsNull(HostWnd) Then PP.Container = HostWnd
    GenerateReport

    If GoPreview Then
        PP.Show
    Else
        PP.PrintPages
    End If

'destroy the preview object to free memory
    If IsNull(HostWnd) Then Set PP = Nothing
    Exit Sub

NoPreview:

    MsgBox "Error in PreviewReport : " & Err.Description

End Sub

Public Function GetReportFile(strGetFilePath As String) As Boolean
On Error GoTo NoOpen

Dim FileNum As Long
Dim GetNum As Integer

    If Dir(strGetFilePath) = "" Then
        MsgBox "Could not find specified file : '" & strGetFilePath & "'", vbOKOnly + vbInformation
        Exit Function
    End If

    FileNum = FreeFile()
    

    Open strGetFilePath For Binary Access Read Lock Write As FileNum
    Get FileNum, , GetNum
    ReDim ReportFile.RpControl(GetNum)
    Get FileNum, , ReportFile
    Close FileNum
    
    strDataFileName = ReportFile.DBName
    strTableName = ReportFile.DBSource
    
    If strDataFileName = "" Then
        MsgBox "No data file loaded.  Report cannot be previewed.", vbOKOnly + vbInformation
        GetReportFile = False
        Exit Function
    End If
    
    If ConnectToDataFile Then
        GetTables
        OpenData strTableName
    Else
        GetReportFile = False
        Exit Function
    End If
    
    GetReportFile = True
    Exit Function

NoOpen:

    GetReportFile = False
    MsgBox "Error in GetReportFile : " & Err.Description

End Function

Public Sub GenerateReport()
On Error GoTo NoGenerate

Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim PrevValue(2) As Variant
Dim TopOfFreeSpace As Single
Dim CurrPagePos As Single
Dim EndOfPage As Boolean
Dim EndOfReport As Boolean