frmmain.frm

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

  .Width = Me.ScaleWidth - frmSptDesc.Width - frmRpt.Width - frmSplit.Width - frmTree.Width
  .Height = frmSptDesc.Height
 End With
End Sub

'//初始化工具条
Private Sub LoadTBar()
 With CmdState
  TBar.Buttons(1).Visible = .Exe_Cmd
  TBar.Buttons(3).Visible = .New_Cmd
  TBar.Buttons(4).Visible = .Edt_Cmd
  TBar.Buttons(5).Visible = .Del_Cmd
  TBar.Buttons(7).Visible = .Fnd_Cmd
 End With
End Sub

'//处理状态条
Private Sub LoadSBar()
 With SBar
  .Panels(1).Width = .Width * 0.15
  .Panels(2).Width = .Width * 0.15
  .Panels(3).Width = .Width * 0.4
  .Panels(4).Width = .Width * 0.15
  .Panels(4).Width = .Width * 0.15
  '//
  .Panels(2).Text = meObj.BaseInfo.getItemName(meObj.BaseInfo.getClassID, meObj.BaseInfo.getUserID)
  .Panels(5).Text = meObj.BaseInfo.getServerDate(1)
 End With
End Sub

'//装在顶级目录
Private Sub LoadTopTree()
 Dim DaCn As New ADODB.Connection
 Dim daRs As New ADODB.Recordset
 Dim Sql As String
 Dim NodeX As Node
 Dim FItemID As Long
 Dim FName As String
 Dim FNodeSign As String
 Dim iLoop As Long
 Sql = getClassSql(0)
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 daRs.CursorLocation = adUseClient
 daRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not daRs.EOF Then
  iLoop = 0
  While Not daRs.EOF
   If Not IsNull(daRs("FItemID")) Then FItemID = daRs("FItemID")
   If Not IsNull(daRs("FName")) Then FName = daRs("FName")
   iLoop = iLoop + 1
   ReDim Preserve SelItem(1 To iLoop)
   SelItem(iLoop) = FItemID
   FNodeSign = "Top" & FItemID
   Set NodeX = frmTree.Nodes.Add(, , FNodeSign, FName, 1, 2)
   daRs.MoveNext
  Wend
 End If
 daRs.Close
 DaCn.Close
 Set daRs = Nothing
 Set DaCn = Nothing
End Sub

'//装在顶级目录
Private Sub LoadNextTree(ByVal inParentID As Long)
 Dim DaCn As New ADODB.Connection
 Dim daRs As New ADODB.Recordset
 Dim Sql As String
 Dim NodeX As Node
 Dim FItemID As Long
 Dim FName As String
 Dim FNodeSign As String
 Dim iLoop As Long
 Sql = getClassSql(inParentID)
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 daRs.CursorLocation = adUseClient
 daRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not daRs.EOF Then
  iLoop = UBound(SelItem)
  While Not daRs.EOF
   If Not IsNull(daRs("FItemID")) Then FItemID = daRs("FItemID")
   If Not IsNull(daRs("FName")) Then FName = daRs("FName")
   iLoop = iLoop + 1
   ReDim Preserve SelItem(1 To iLoop)
   SelItem(iLoop) = FItemID
   FNodeSign = "Top" & FItemID
   Set NodeX = frmTree.Nodes.Add("Top" & inParentID, tvwChild, FNodeSign, FName, 1, 2)
   daRs.MoveNext
  Wend
 End If
 daRs.Close
 DaCn.Close
 Set daRs = Nothing
 Set DaCn = Nothing
End Sub

'//装在资料列表
Private Sub LoadRpt()
 With frmRpt
  .Face.Rows = 1
  .Face.FixedRows = 1
  .Face.Cols = 2
  .Col(1).Width = 0
  .Col(1).Switch(E_LDG_ColFlag_Hide) = True
  
  .Col(2).Width = frmRpt.Width * 0.8
 End With
 frmCn.ConnectionString = meObj.BaseInfo.getConStr
 frmCn.Open
 TxtSql = getListSql(0)
End Sub

Private Sub RefreshLdg()
 On Error GoTo Errhandler
 Dim Sql As String
 Sql = TxtSql & Query
 If frmRs.State = adStateOpen Then frmRs.Close
 frmRs.CursorLocation = adUseClient
 frmRs.Open Sql, frmCn, adOpenStatic, adLockReadOnly
 frmRpt.Merge.UnMergeAll
 frmRpt.Face.Rows = frmRs.RecordCount + frmRpt.Face.FixedRows
 frmRpt.Face.ForceRefresh
 SBar.Panels(3).Text = "共计找到[" & frmRs.RecordCount & "]张报表"
 Exit Sub
Errhandler:
 MsgBox "错误，编号：" & Err.Number & "-->信息：" & Err.Description, vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
End Sub

Private Sub Form_Load()
 Call InitRith
 Call LoadActiveX
 Call LoadTBar
 Call LoadSBar
 Call LoadTopTree
 Call LoadRpt
 Call RefreshLdg
End Sub

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

Private Sub frmRpt_Click()
 Dim MsgInfo As String
 JsRptID = Val(frmRpt.Cell(frmRpt.Sel.Row, 1).Text)
 If objRpt.Load(JsRptID, MsgInfo) = False Then
  MsgBox MsgInfo, vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
  Set objRpt = Nothing
  Exit Sub
 End If
 frmDesc.Text = objRpt.Js_RptDesc
End Sub


Private Sub frmRpt_DblClick()
 Call Exec_Rpt
End Sub

Private Sub frmRpt_FillRow(ByVal lRow As Long, strRowData As String, clrBack As stdole.OLE_COLOR, clrFore As stdole.OLE_COLOR)
 Dim iLoop As Integer
 If lRow = 1 Then
  strRowData = getListTitle()
  Exit Sub
 End If
 frmRs.AbsolutePosition = lRow - frmRpt.Face.FixedRows
 For iLoop = 0 To frmRpt.Face.Cols - 1
  strRowData = strRowData & frmRs(iLoop) & "|"
 Next
End Sub

Private Sub frmSplit_EndMoving()
 frmTree.Width = frmSplit.Left - frmTree.Left
 frmRpt.Left = frmSplit.Left + frmSplit.Width
 frmRpt.Width = Me.ScaleWidth - frmDesc.Width - frmSptDesc.Width - frmSplit.Width - frmTree.Width
End Sub

Private Sub frmSptDesc_EndMoving()
 frmRpt.Width = frmSptDesc.Left - frmSplit.Left - frmSplit.Width
 frmDesc.Left = frmSptDesc.Left + frmSptDesc.Width
 frmDesc.Width = Me.ScaleWidth - frmTree.Width - frmSplit.Width - frmRpt.Width - frmSptDesc.Width
End Sub

Private Sub frmTree_NodeClick(ByVal Node As MSComctlLib.Node)
 Dim ChildSign As Integer
 '/
 frmDesc.Text = ""
 '/
 ChildSign = Node.Children
 SelItemID = SelItem(Node.Index)
 If ChildSign = 0 Then
  Call LoadNextTree(SelItemID)
 End If
 TxtSql = getListSql(SelItemID)
 Call RefreshLdg
 '//
 SBar.Panels(3).Text = "选择报表目录[" & Node.Text & "] 报表目录内码[" & SelItemID & "]"
End Sub

Private Sub Exec_Rpt()
 If JsRptID = 0 Then
  MsgBox "请选择要执行的报表", vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
  Exit Sub
 End If
 Dim objGlass As Object
 Set objGlass = CreateObject("RptData.RptDataCls")
 objGlass.setUserID = meObj.BaseInfo.getUserID
 objGlass.setRptID = JsRptID
 Call objGlass.mShow(1)
 Set objGlass = Nothing
End Sub

Private Sub New_Rpt()
 Dim objGlass As Object
 Set objGlass = CreateObject("Rpt.RptCls")
 objGlass.setUserID = meObj.BaseInfo.getUserID
 objGlass.setRptID = 0
 Call objGlass.mShow(1)
 Set objGlass = Nothing
End Sub

Private Sub Edit_Rpt()
 If JsRptID = 0 Then
  MsgBox "请选择要修改的报表", vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
  Exit Sub
 End If
 Dim objGlass As Object
 Set objGlass = CreateObject("Rpt.RptCls")
 objGlass.setUserID = meObj.BaseInfo.getUserID
 objGlass.setRptID = JsRptID
 Call objGlass.mShow(1)
 Set objGlass = Nothing
End Sub

Private Sub Del_Rpt()
 If JsRptID = 0 Then
  MsgBox "请选择要删除的报表", vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
  Exit Sub
 End If
 Dim RetInt As Long
 RetInt = MsgBox("删除报表[" & Trim(frmRpt.Cell(frmRpt.Sel.Row, 2).Text) & "]？", vbQuestion + vbYesNo + vbDefaultButton2, meObj.BaseInfo.getMsgInfo)
 If RetInt <> 6 Then
  Exit Sub
 End If
 '//
 Dim DaCn As New ADODB.Connection
 Dim Sql As String
 Sql = "delete from js_rpt where js_rptid=" & JsRptID
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 DaCn.Execute Sql
 DaCn.Close
 Set DaCn = Nothing
 MsgBox "删除报表[" & Trim(frmRpt.Cell(frmRpt.Sel.Row, 2).Text) & "]成功", vbInformation + vbOKOnly, meObj.BaseInfo.getMsgInfo
End Sub

Private Sub Find_Rpt()
 Dim JsRptName As String
 Query = ""
 JsRptName = InputBox("输入报表名称关键字", "搜索报表", frmRpt.Cell(frmRpt.Sel.Row, 2).Text)
 If Trim(JsRptName) = "" Then Exit Sub
 Query = " and a.js_rptname like '%" & JsRptName & "%'"
End Sub

Private Sub TBar_ButtonClick(ByVal Button As MSComctlLib.Button)
 Select Case Button.Caption
  Case "执行"
   Call Exec_Rpt
  Case "新建"
   Call New_Rpt
   Call RefreshLdg
  Case "编辑"
   Call Edit_Rpt
   Call RefreshLdg
  Case "删除"
   Call Del_Rpt
   Call RefreshLdg
  Case "搜索"
   Call Find_Rpt
   Call RefreshLdg
  Case "关闭"
   Unload Me
 End Select
End Sub