水晶报表开发实例!C/S结构

1.水晶报表查看组件及使用(VB源码)

Option Explicit

Dim mReport As CRAXDRT.Report

Public Sub Show(Rs As ADODB.Recordset, FileName As String, ReportName As String)
Dim tmpObj As New Acon.Icon, gCn As New ADODB.Connection
Dim tmpApp As New CRAXDRT.Application
Dim obj As New frmReport, strFileName As String

On Error GoTo Err

    Screen.MousePointer = vbHourglass
    strFileName = App.Path & IIf(Right(App.Path, 1) = "/", "", "/") & FileName
   
    '连接数据源
    Set tmpObj = CreateObject("Acon.CAdoConSql")
    Set gCn = tmpObj.Connect("Ferp")
    gCn.CursorLocation = adUseClient

    '加载报表文件
    Set mReport = tmpApp.OpenReport(strFileName)
   
    '连接数据源到报表中
    With mReport
        .Database.SetDataSource Rs
        .Database.Verify
    End With

    '显示报表
    If Not mReport Is Nothing Then
        With obj
            .CRViewer91.ReportSource = mReport
            .Caption = obj.Tag & " - " & ReportName
            .CRViewer91.Zoom 100
            .CRViewer91.ViewReport
            Screen.MousePointer = vbDefault
            .Show vbModal
        End With
    End If
   
    Set obj = Nothing
    Set tmpApp = Nothing
    Set gCn = Nothing
    Set tmpObj = Nothing
    Set mReport = Nothing

    Screen.MousePointer = vbDefault
    Exit Sub
   
Err:
    Set obj = Nothing
    Set tmpApp = Nothing
    Set gCn = Nothing
    Set tmpObj = Nothing
    Screen.MousePointer = vbDefault
    MsgBox "初始化报表错误:" & Err.Number & "  " & Err.Description, vbExclamation, "限额领料报表"
End Sub

使用方法如下:

'打印派工单
Private Sub mun_PrintSend_Click()
Dim tmprs As ADODB.Recordset, tmpObj As Object
Dim objbus As CCFitPlan.IFitPlan                       '装配计划业务对象
    If m_strFitPlanID = "" Then Exit Sub
    If Not pAccRight.blInsert Then
        MsgBox "对不起,您没有相应的权限！(新增权限)", vbExclamation, Me.Caption
        Exit Sub
    End If
    Set objbus = New CCFitPlan.CFitPlan
    Set tmprs = objbus.RetrieveBySql("sp_RptGetFitPlanSend '" & m_strFitPlanID & "'")
    If Not tmprs.EOF Then
        Me.MousePointer = vbHourglass
        Set tmpObj = CreateObject("CryReportView.ReportView")
        Call tmpObj.Show(tmprs, "装配派工单.rpt", "装配派工单")
        Me.MousePointer = vbDefault
    End If
End Sub

 

2.一个在运行时动态加载报表列的显示(VB源码)

Public Sub Show()
Dim obj As New frmReport

On Error GoTo Err

    Screen.MousePointer = vbHourglass
    strFileName = App.Path & IIf(Right(App.Path, 1) = "/", "", "/") & FileName
    Call InitReport(mPlanID, strFileName)
   
    If Not mReport Is Nothing Then
        With obj
            .CRViewer91.ReportSource = mReport
            .Caption = obj.Tag & " - 限额领料报表"
            .CRViewer91.Zoom 100
            .CRViewer91.ViewReport
            .Show 'vbModal
        End With
    End If
   
    Set obj = Nothing
    Screen.MousePointer = vbDefault
    Exit Sub
   
Err:
    Screen.MousePointer = vbDefault
    MsgBox "初始化报表错误:" & Err.Number & "  " & Err.Description, vbExclamation, "限额领料报表"
End Sub

Private Sub InitReport(strPlanID As String, strFile As String)
Dim tmpApp As New CRAXDRT.Application, crSection As CRAXDRT.Section, crSectionEx As CRAXDRT.Section
Dim crFieldObject As CRAXDRT.FieldObject, tmpFieldObj As CRAXDRT.FieldObject
Dim crTextObject As CRAXDRT.TextObject, tmpTextObj As CRAXDRT.TextObject
Dim rs As ADODB.Recordset, tmpRs As ADODB.Recordset, j As Long
Dim tmpObj As New Acon.Icon, gCn As New ADODB.Connection
Dim strTableName As String, i As Long, mFixLeft As Long, mFixWidth As Long
Dim tmpLineObj As CRAXDRT.LineObject

    '连接数据源
    Set tmpObj = CreateObject("Acon.CAdoConSql")
    Set gCn = tmpObj.Connect("Ferp")
    gCn.CursorLocation = adUseClient
   
    '取工号
    Set rs = gCn.Execute("Select DISTINCT InsideConID  From P_ProductPartsLimitPlan Where LimitPlanID='" & strPlanID & "'")
    If rs.RecordCount = 0 Then
        MsgBox "没有找到指定单据的工号的数据!", vbExclamation, App.EXEName
        Exit Sub
    End If
    '取数据
    Set tmpRs = gCn.Execute("sp_RptGetLimitPlan '" & strPlanID & "'")
    If tmpRs.EOF Then
        MsgBox "没有找到指定单据的领料的数据!", vbExclamation, App.EXEName
        Exit Sub
    End If
    '加载报表文件
    Set mReport = tmpApp.OpenReport(strFile)
   
    '连接数据源到报表中
    With mReport
        .Database.SetDataSource tmpRs
        .Database.Verify
        Set crSection = .Sections("D")
        Set crSectionEx = .Sections("PH")
       
        strTableName = .Database.Tables(1).Name
    End With
   
    rs.Sort = rs.Fields(0).Name
    Set tmpFieldObj = crSection.ReportObjects(crSection.ReportObjects.Count - 1)
    Set tmpTextObj = crSectionEx.ReportObjects(crSection.ReportObjects.Count - 1)
    mFixLeft = tmpFieldObj.Left + tmpFieldObj.Width + 200
    mFixWidth = tmpFieldObj.Width
    '加载明细数据,动态列
    With crSection
        Do While Not rs.EOF
            i = i + 1
            '数据列
            Set crFieldObject = crSection.AddFieldObject("{" & strTableName & ".UnNum" & i & "}", mFixLeft + ((mFixWidth + ColFix) * (i - 1)), tmpFieldObj.Top)
            crFieldObject.Width = mFixWidth
            crFieldObject.Height = tmpFieldObj.Height
            crFieldObject.HorAlignment = crRightAlign
            Set crFieldObject.Font = tmpFieldObj.Font
            crFieldObject.ZeroValueString = ""
            '表头列
            Set crTextObject = crSectionEx.AddTextObject(rs(0), crFieldObject.Left + crFieldObject.Width - tmpTextObj.Width, tmpTextObj.Top)
            crTextObject.Width = tmpTextObj.Width
            crTextObject.Height = tmpTextObj.Height
            crTextObject.HorAlignment = crRightAlign
            Set crTextObject.Font = tmpTextObj.Font
           
            rs.MoveNext
        Loop
    End With
   
    '设置表头
    Set crSection = mReport.Sections("RH")
    Set tmpTextObj = crSection.ReportObjects(crSection.ReportObjects.Count)
    tmpTextObj.SetText " 限额领料报表 - " & strPlanID
    tmpTextObj.Width = tmpTextObj.Width * 3
   
    '设置线的长度(所有节)
    For j = 1 To mReport.Sections.Count
        Set crSectionEx = mReport.Sections(j)
        With crSectionEx.ReportObjects
            For i = 1 To .Count
               If .Item(i).Kind = crLineObject Then
                    Set tmpLineObj = .Item(i)
                    tmpLineObj.Right = mFixLeft + ((mFixWidth + ColFix) * rs.RecordCount)
               End If
            Next
        End With
    Next
   
   
    Set tmpFieldObj = Nothing
    Set tmpTextObj = Nothing
    Set crFieldObject = Nothing
    Set crTextObject = Nothing
    Set crSection = Nothing
    Set crSectionEx = Nothing
    Set tmpApp = Nothing

    Set gCn = Nothing
    Set tmpObj = Nothing
   
    Exit Sub
Err:

End Sub

有关源码,可直接到http://www.winu.cn/20383上下载!