frmlist.frm

本系统是一个报表分析查询系统

VERSION 5.00
Object = "{4932CEF1-2CAA-11D2-A165-0060081C43D9}#2.0#0"; "Actbar2.OCX"
Object = "{709F7AE3-E049-11D2-9362-00403332E72F}#1.0#0"; "LEDGER50.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmList 
   Caption         =   "Form1"
   ClientHeight    =   7935
   ClientLeft      =   60
   ClientTop       =   465
   ClientWidth     =   10365
   LinkTopic       =   "Form1"
   ScaleHeight     =   7935
   ScaleWidth      =   10365
   StartUpPosition =   2  '屏幕中心
   Begin MSComDlg.CommonDialog frmSave 
      Left            =   4920
      Top             =   3720
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin LEDGER50Lib.Ledger50 frmRpt 
      Height          =   1935
      Left            =   2880
      TabIndex        =   2
      Top             =   1200
      Width           =   4455
      _Version        =   65536
      _ExtentX        =   7858
      _ExtentY        =   3413
      _StockProps     =   237
      ForeColor       =   0
      BackColor       =   16777215
   End
   Begin ActiveBar2LibraryCtl.ActiveBar2 SBar 
      Height          =   375
      Left            =   840
      TabIndex        =   1
      Top             =   7080
      Width           =   3975
      _LayoutVersion  =   1
      _ExtentX        =   7011
      _ExtentY        =   661
      _DataPath       =   ""
      Bands           =   "frmList.frx":0000
   End
   Begin ActiveBar2LibraryCtl.ActiveBar2 TBar 
      Height          =   375
      Left            =   360
      TabIndex        =   0
      Top             =   120
      Width           =   3735
      _LayoutVersion  =   1
      _ExtentX        =   6588
      _ExtentY        =   661
      _DataPath       =   ""
      Bands           =   "frmList.frx":01C8
   End
End
Attribute VB_Name = "frmList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private imgPath As String
Private imgStd As StdPicture
Private sBillNo As String
Dim frmCn As New ADODB.Connection
Dim frmRs As New ADODB.Recordset
Dim lSql As String

Private Sub LoadFrmMsg()
 With Me
  .Width = Screen.Width * 0.95
  .Height = Screen.Height * 0.9
  .Caption = meRpt.Js_RptName
 End With
 ExeSign = False
 CmdExeSign = False
 imgPath = App.Path & "\ResLib\"
 frmCn.ConnectionString = meObj.BaseInfo.getConStr
 frmCn.Open
End Sub

'//报表布局
Private Sub RptLayout()
 With TBar
  .Left = 0
  .Top = 0
  .Width = Me.ScaleWidth
  .Height = 720
 End With
 With SBar
  .Left = 0
  .Width = Me.ScaleWidth
  .Height = 350
  .Top = Me.ScaleHeight - .Height
 End With
 With frmRpt
  .Left = 0
  .Top = TBar.Top + TBar.Height
  .Width = Me.ScaleWidth
  .Height = SBar.Top - .Top
 End With
End Sub

'//初始化工具栏
Private Sub LoadTBar()
 TBar.UserDefinedCustomization = True
 '//
 Dim Tool As ActiveBar2LibraryCtl.Tool
 Dim Band As ActiveBar2LibraryCtl.Band
 '//
 Set imgStd = LoadPicture(imgPath & "TBarBk.jpg")
 With TBar
  .Picture = imgStd
 End With
 '//
 Set Band = TBar.Bands.Add("TTBar")
 With Band
  .Caption = "TTBar"
  .Type = ddBTNormal
  .DockingArea = ddDATop
  .GrabHandleStyle = ddGSIE
  .MouseTracking = ddTSColor
 End With
 '//
 Set Tool = Band.Tools.Add(1, "TFnd")
 With Tool
  .Caption = "过滤"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(imgPath & "Find.Ico"), &HFF8080
  .Visible = Cmd.FilCmd
  .ToolTipText = "搜索数据重新生成报表"
 End With
 '//
 Set Tool = Band.Tools.Add(2, "TExp")
 With Tool
  .Caption = "导出"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(imgPath & "Excel.Ico"), &HC0C0C0
  .Visible = Cmd.ExpCmd
  .ToolTipText = "将报表数据导出为Ms Excel文件"
 End With
 '//
 Set Tool = Band.Tools.Add(3, "TPrint")
 With Tool
  .Caption = "打印"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(imgPath & "Print.Ico"), &HC0C0C0
  .Visible = Cmd.PrtCmd
  .ToolTipText = "打印当前数据报表"
 End With
 '//
 Set Tool = Band.Tools.Add(4, "SplitTwo")
 With Tool
  .ControlType = ddTTSeparator
 End With
 '//
 Set Tool = Band.Tools.Add(5, "TExit")
 With Tool
  .Caption = "退出"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(imgPath & "Exit.Ico"), &HC0C0C0
  .ToolTipText = "退出报表管理"
 End With
 TBar.RecalcLayout
 TBar.Refresh
End Sub


Private Sub LoadSBar()
 Dim Tool As ActiveBar2LibraryCtl.Tool
 Dim Band As ActiveBar2LibraryCtl.Band
 '//初始化状态条
 With SBar
  .Picture = LoadPicture(imgPath & "SBarBack.Gif")
 End With
 '//添加用户图标
 Set Tool = SBar.Tools.Add(1, "UserImg")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterTop
  .ControlType = ddTTButton
  .SetPicture ddITNormal, LoadPicture(imgPath & "User.Ico")
  .Style = ddSIcon
 End With
 '//添加用户名称
 Set Tool = SBar.Tools.Add(2, "UserName")
 With Tool
  .Height = SBar.Height
  .Alignment = ddALeftCenter
  .Caption = meObj.BaseInfo.getItemName(12, meObj.BaseInfo.getUserID)
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSNormal
  .Width = SBar.Width * 0.1
 End With
 '//添加主信息
 Set Tool = SBar.Tools.Add(3, "MainMsg")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterCenter
  .Caption = "准备就绪"
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSNormal
  .Width = SBar.Width * 0.5
 End With
 '//添加时间图形
 Set Tool = SBar.Tools.Add(4, "DateImg")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterTop
  .ControlType = ddTTButton
  .SetPicture ddITNormal, LoadPicture(imgPath & "Timer.Ico")
  .Style = ddSIcon
 End With
 '//添加时间值
 Set Tool = SBar.Tools.Add(5, "DateVal")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterCenter
  .Caption = meObj.BaseInfo.getServerDate(1)
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSNormal
  .Width = SBar.Width * 0.1
 End With
 '//
 Set Tool = SBar.Tools.Add(6, "Inst")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterCenter
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSInsert
 End With
 Set Band = SBar.Bands.Add("TSBar"): Band.Type = ddBTStatusBar
 With Band.Tools
  .Insert .Count, SBar.Tools("UserImg")
  .Insert .Count, SBar.Tools("UserName")
  .Insert .Count, SBar.Tools("MainMsg")
  .Insert .Count, SBar.Tools("DateImg")
  .Insert .Count, SBar.Tools("DateVal")
  .Insert .Count, SBar.Tools("Inst")
 End With
 SBar.RecalcLayout
 SBar.Refresh
End Sub

'//装载报表信息
Private Sub LoadRpt()
 Dim hPos As Integer '//页眉
 Dim fPos As Integer '//页脚
 Dim iLoop As Integer '//计数器
 With frmRpt
  '//输出页眉页脚
  If meRpt.hBill.Count > 0 Then
   For iLoop = 1 To meRpt.hBill.Count
    Select Case meRpt.hBill.Item(iLoop).Js_hfTypeID
     Case 1 '//页眉输出
      .Printer.Header(hPos).Text = meRpt.hBill.Item(iLoop).Js_hfText
      .Printer.Header(hPos).Font.Name = meRpt.hBill.Item(iLoop).Js_hfFontName
      .Printer.Header(hPos).Font.Size = meRpt.hBill.Item(iLoop).Js_hfFontSize
      .Printer.Header(hPos).Font.Bold = meRpt.hBill.Item(iLoop).Js_hfFontBold
      .Printer.Header(hPos).Font.Italic = meRpt.hBill.Item(iLoop).Js_hfFontItalic
      .Printer.Header(hPos).Font.Underline = meRpt.hBill.Item(iLoop).Js_hfFontUnderline
      hPos = hPos + 1
     Case 2 '//页脚输出
      .Printer.Footer(fPos).Text = meRpt.hBill.Item(iLoop).Js_hfText
      .Printer.Footer(fPos).Font.Name = meRpt.hBill.Item(iLoop).Js_hfFontName
      .Printer.Footer(fPos).Font.Size = meRpt.hBill.Item(iLoop).Js_hfFontSize
      .Printer.Footer(fPos).Font.Bold = meRpt.hBill.Item(iLoop).Js_hfFontBold
      .Printer.Footer(fPos).Font.Italic = meRpt.hBill.Item(iLoop).Js_hfFontItalic
      .Printer.Footer(fPos).Font.Underline = meRpt.hBill.Item(iLoop).Js_hfFontUnderline
      fPos = fPos + 1
    End Select
   Next
  End If
  .Face.Rows = Crp.FixRows + 1
  .Face.FixedRows = Crp.FixRows
  .Face.Cols = Crp.MaxCols
  '//布局报表标题行极其宽度
  If meRpt.fBill.Count > 0 Then
   For iLoop = 1 To meRpt.fBill.Count
    .col(iLoop).Align = meRpt.fBill.Item(iLoop).Js_FieldAlign
    .col(iLoop).Switch(E_LDG_ColFlag_Hide) = meRpt.fBill.Item(iLoop).Js_FieldShowSign
    .col(iLoop).Width = meRpt.fBill.Item(iLoop).Js_FieldWidth
   Next
  End If
 End With
End Sub

'//刷新列表框
Private Sub RefreshLdg()
 On Error GoTo Errhandler
 Dim iLoop As Integer
 lSql = Crp.ExecSql
 If Trim(lSql) = "" Then
  lSql = "exec " & meRpt.Js_RptCallName
 End If
 '//MsgBox lSql
 If frmRs.State = adStateOpen Then frmRs.Close
 frmRs.CursorLocation = adUseClient
 frmRs.Open lSql, frmCn, adOpenStatic, adLockReadOnly
 frmRpt.Merge.UnMergeAll
 frmRpt.Face.Rows = frmRs.RecordCount + frmRpt.Face.FixedRows
 frmRpt.Face.ForceRefresh
 '//报表标题内容输出
  If meRpt.tBill.Count > 0 Then
   For iLoop = 1 To meRpt.tBill.Count
    '//判断标题是否需要合并
    If meRpt.tBill.Item(iLoop).Js_SRow = meRpt.tBill.Item(iLoop).Js_ERow And meRpt.tBill.Item(iLoop).Js_SCol = meRpt.tBill.Item(iLoop).Js_ECol Then
     '//不需要合并
    Else
     '//需要合并
     frmRpt.Merge.MergeCell meRpt.tBill.Item(iLoop).Js_SRow - 1, meRpt.tBill.Item(iLoop).Js_SCol, meRpt.tBill.Item(iLoop).Js_ERow - 1, meRpt.tBill.Item(iLoop).Js_ECol
    End If
   Next
  End If
 Exit Sub
Errhandler:
 MsgBox "错误：" & Err.Description, vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
End Sub


Private Sub Form_Load()
 Call LoadFrmMsg
 Call LoadTBar
 Call LoadSBar
 Call LoadRpt
 Call RefreshLdg
End Sub

Private Sub Form_Resize()
 Call RptLayout
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Set imgStd = Nothing
  If frmCn.State = adStateOpen Then frmCn.Close
  If frmRs.State = adStateOpen Then frmRs.Close
  Set frmCn = Nothing
  Set frmRs = Nothing
End Sub

Private Sub frmRpt_FillRow(ByVal lRow As Long, strRowData As String, clrBack As stdole.OLE_COLOR, clrFore As stdole.OLE_COLOR)
 Dim hVal As Variant '//每列的值
 If lRow <= Crp.FixRows Then
  strRowData = Crp.TitleStr(lRow)
  Exit Sub
 End If
 '//
 frmRs.AbsolutePosition = lRow - frmRpt.Face.FixedRows
 For iLoop = 0 To Crp.MaxCols - 1
  If getRightSign(meRpt.fBill.Item(iLoop + 1).Js_RightID) = True Then
   Select Case meRpt.fBill.Item(iLoop + 1).Js_FieldDsecID
    Case 3, 4, 5, 6, 11, 17, 20, 128, 131, 204
     hVal = Format(frmRs(iLoop), meObj.BaseInfo.getDigit(meRpt.fBill.Item(iLoop + 1).Js_FieldOrderSign))
    Case Else
     hVal = frmRs(iLoop)
   End Select
  Else
   hVal = ""
  End If
  strRowData = strRowData & hVal & "|"
 Next
End Sub

Private Sub frmRpt_ExtEvents(ByVal lLocaleID As LEDGER50Lib.E_LDG_ExtEvents_LocaleID, ByVal var1 As Variant, ByVal var2 As Variant, ByVal var3 As Variant, rvarRet As Variant)
 Select Case lLocaleID
  Case 1
   '//拖动结束
   Call SaveColWidth
  Case Else
 End Select
End Sub

Private Sub TBar_ToolClick(ByVal Tool As ActiveBar2LibraryCtl.Tool)
 Select Case Tool.Name
  Case "TFnd"
   '//搜索报表
   FiltrateFrm.Show vbModal
   '//
   If ExeSign = False Then
    Exit Sub
   End If
   Call RefreshLdg
  Case "TExp"
   '//导出报表
   Call Exp2Excel
  Case "TPrint"
   '//打印报表
   frmRpt.Printer.Preview
  Case "TExit"
   '//退出报表
   Unload Me
 End Select
End Sub

'//导出数据到EXCEL
Private Sub Exp2Excel()
 Dim MsgInfo As String
 Dim TsObj As Object
 Set TsObj = CreateObject("Ledger2Excel.L2ECell")
 TsObj.setUserID = meObj.BaseInfo.getUserID
 TsObj.setRptID = RptID
 TsObj.getRpt = frmRpt
 TsObj.setConnStr = meObj.BaseInfo.getConStr
 If TsObj.TransmissionData(MsgInfo) = False Then
  MsgBox MsgInfo, vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
 Else
  MsgBox MsgInfo, vbInformation + vbOKOnly, meObj.BaseInfo.getMsgInfo
 End If
 Set TsObj = Nothing
End Sub

'//保存列宽
Private Sub SaveColWidth()
 Dim DaCn As New ADODB.Connection
 Dim iLoop As Integer
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 For iLoop = 1 To Crp.MaxCols
  Sql = "update Js_FieldControl set Js_FieldWidth=" & frmRpt.col(iLoop).Width & " where Js_FieldOrderID=" & iLoop
  DaCn.Execute Sql
 Next
 DaCn.Close
 Set DaCn = Nothing
End Sub