DataReport动态报表

Private Sub cmd_report_Click()
If lst_selected.ListCount <> 0 Then
    Call fieldwidth(lst_selected) '设置字段宽度
    Call setDatareport(lst_selected, Dtreport, Trim$(txt_caption))
    Dtreport.Show
Else
    MsgBox "请选择要输出的字段条目", vbOKOnly + vbInformation
End If
End Sub
'***********************************************************************************
'Section1,Section2的keeptogther=true时，如果某条记录处在一页最下面，但又不完全能打印出来时，可强制将此条记录换到下一页打印。
'Rpttextbox、Rptlable和RptFunction中Gangrow=true时当显示的内容超过控件的宽度是可以换行。
'打印报表字段宽度控制子程序
Private Sub fieldwidth(lst As ListBox)
Dim i As Integer
Const wordwidth As Integer = 201 '五号字的宽带是201缇
For i = 0 To lst.ListCount - 1
    Select Case lst.List(i)
        Case "编号"
            lst.ItemData(i) = wordwidth * 4
        Case "名称"
            lst.ItemData(i) = wordwidth * 12
        Case "款号"
            lst.ItemData(i) = wordwidth * 4
        Case "规格"
            lst.ItemData(i) = wordwidth * 3
        Case "件数"
            lst.ItemData(i) = wordwidth * 3
        Case "重量g"
            lst.ItemData(i) = wordwidth * 3
        Case "单价类型"
            lst.ItemData(i) = wordwidth * 4
        Case "单价"
            lst.ItemData(i) = wordwidth * 3
    End Select
Next i
End Sub
'***********************************************************************************
'***********************************************************************************
'设置报表窗体各种参数，控制输出格式
Private Sub setDatareport(lst As ListBox, dtr As DataReport, scaption As String)
Dim leftpos As Long 'leftpos为存放控件left属性的变量
Dim reportwidth As Long 'reportwidth为存放DataReport总宽度的变量
Dim i As Integer
Dim Rst1 As New ADODB.Recordset '定义一个数据库记录对象
Dim SqlDef As String '定义字符串变量
'求总宽度
For i = 0 To lst.ListCount - 1
    reportwidth = reportwidth + lst.ItemData(i)
Next i
'初始化
If VSFlexGrid1.Rows >= 1 Then dh1 = VSFlexGrid1.TextMatrix(VSFlexGrid1.RowSel, 1)
''''SqlDef = "select BH AS 编号,MC AS 名称,KH AS 款号,GG AS 规格,JS AS 件数,ZL AS 重量g,DJLX AS 单价类型," & _
''''     "DJ AS 单价,JE AS 金额,GFLX AS 工费类型,GF AS 工费,GFJE AS 工费金额,ZJE AS 总金额,SJ AS 售价,BZ AS 备注 from YSPF_ZC_PLRKDMX where DH='" & dh1 & "'"
SqlDef = "select BH AS 编号,MC AS 名称,KH AS 款号,GG AS 规格,JS AS 件数,ZL AS 重量g,DJLX AS 单价类型," & _
"DJ AS 单价 from YSPF_FD_RKDMX where DH='" & dh1 & "'"
Rst1.Open SqlDef, gConn, adOpenStatic, adLockReadOnly, -1 '进入数据库查询，并把查询结果赋值给rst记录对象
With dtr
    '设置数据源，页边距、标题、横向分割线,section1.2区第一条竖向分割线
    .LeftMargin = 1440
    .RightMargin = 1440
    .TopMargin = 1440
    .BottomMargin = 144
    '.reportwidth = Printer.With - 2880 - 20
    Set .DataSource = Rst1  'Rst1为数据源
    .Sections("Section4").Controls.Item("label1").Caption = scaption
    .Sections("Section4").Controls.Item("label1").Width = reportwidth
    .Sections("Section4").Controls.Item("label2").Width = reportwidth
    .Sections("Section2").Controls.Item("line2").Width = reportwidth
    .Sections("Section2").Controls.Item("line_2").Width = reportwidth
    .Sections("Section1").Controls.Item("line1").Width = reportwidth
    .Sections("Section2").Controls.Item("line20").Left = 0
    .Sections("Section1").Controls.Item("line10").Left = 0
End With
'为section1,2区设置数据
leftpos = 0
    For i = 0 To lst.ListCount - 1
    dtr.Sections("Section2").Controls.Item("label1" & (i + 1)).Caption = lst.List(i)
    dtr.Sections("Section2").Controls.Item("label1" & (i + 1)).Width = lst.ItemData(i)
    dtr.Sections("Section2").Controls.Item("label1" & (i + 1)).Left = leftpos
    dtr.Sections("Section1").Controls.Item("text1" & (i + 1)).DataField = lst.List(i)
    dtr.Sections("Section1").Controls.Item("text1" & (i + 1)).Width = lst.ItemData(i)
    dtr.Sections("Section1").Controls.Item("text1" & (i + 1)).Left = leftpos
    dtr.Sections("Section1").Controls.Item("line1" & (i + 1)).Left = leftpos + lst.ItemData(i)
    dtr.Sections("Section2").Controls.Item("line2" & (i + 1)).Left = leftpos + lst.ItemData(i)
    leftpos = leftpos + lst.ItemData(i)
'特殊字体的格式特殊处理
    If lst.List(i) = "收盘价" Then
        dtr.Sections("Section1").Controls.Item("text1" & (i + 1)).DataFormat.Format = "#,##0"
    End If
Next i
'对不用的text控件必须设置datafield属性，如lst.list（0），否则出错，但一定让其不可见
'其他不用的lable，line控件同样均不可见
i = lst.ListCount
While i < (dtr.Sections("Section1").Controls.Count - 10)
'10 为Section1区域的非text控件的控件总数
    i = i + 1
    dtr.Sections("Section1").Controls.Item("text1" & i).DataField = lst.List(1)
    dtr.Sections("Section1").Controls.Item("text1" & i).Visible = False
    dtr.Sections("Section1").Controls.Item("line1" & i).Visible = False
    dtr.Sections("Section2").Controls.Item("line2" & i).Visible = False
    dtr.Sections("Section2").Controls.Item("label1" & i).Visible = False
Wend
End Sub
'***********************************************************************************
Private Sub Command20_Click()
If lst_candidate.ListCount = 0 Then
    Screen.MousePointer = 0
    Exit Sub
End If
'如果lst_candidate中没有列表项则退出
If lst_candidate.ListIndex = -1 Then
    lst_candidate.SetFocus
    lst_candidate.Selected(0) = True
End If
'如果lst_candidate中没有选中的列表项则选择第一个列表项
DoEvents
lst_selected.AddItem lst_candidate.Text
lst_candidate.RemoveItem lst_candidate.ListIndex
End Sub


Private Sub Command21_Click()
            If lst_selected.ListCount = 0 Then
                Screen.MousePointer = 0
                Exit Sub
            End If
            '如果lst_selected中没有列表项则退出
            If lst_selected.ListIndex = -1 Then
                lst_selected.SetFocus
                lst_selected.Selected(0) = True
            End If
            '如果lst_selected中没有选中的列表项则选择第一个列表项


            lst_candidate.AddItem lst_selected.Text
            lst_selected.RemoveItem lst_selected.ListIndex
            '将选择的列表项从lst_selected移到lst_candidate
End Sub


Private Sub Command22_Click()
            If lst_candidate.ListCount = 0 Then
                Screen.MousePointer = 0
                Exit Sub
            End If
            '如果lst_candidate中没有列表项则退出
            If lst_candidate.ListIndex = -1 Then
                lst_candidate.SetFocus
                lst_candidate.Selected(0) = True
            End If
            '如果lst_candidate中没有选中的列表项则选择第一个列表项
            DoEvents
            For i = (lst_candidate.ListCount - 1) To 0 Step -1
                lst_selected.AddItem lst_candidate.List(i)
                DoEvents
            Next i
            '将lst_candidate的所有列表项添加到lst_selected中
            lst_candidate.Clear
            '删除lst_candidate中的所有列表项
End Sub


Private Sub Command23_Click()
            If lst_selected.ListCount = 0 Then
                Screen.MousePointer = 0
                Exit Sub
            End If
            If lst_selected.ListCount = 0 Then Exit Sub
            If lst_selected.ListIndex = -1 Then
                lst_selected.SetFocus
                lst_selected.Selected(0) = True
            End If
            For i = (lst_selected.ListCount - 1) To 0 Step -1
                lst_candidate.AddItem lst_selected.List(i)
                DoEvents
            Next i
            lst_selected.Clear
End Sub