frmmain.frm

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

  .SetCellFont 2, 1, 0, .FindFontIndex("黑体", 1)
  .SetCellFontSize 2, 1, 0, 11
  .SetCellAlign 2, 1, 0, 4 + 32
  .SetCellFontStyle 2, 1, 0, 2
  .SetCellInput 2, 1, 0, 5
  '//
  .SetCellString 2, 1, 0, "项目数据"
  .SetColWidth 0, .Width * 0.04, 1, 0
  .SetColWidth 0, .Width * 0.11, 2, 0
  '//显示上级分组
  .SetCellString 1, 2, 0, "上级分组："
  .SetCellAlign 1, 2, 0, 2 + 32
  .SetCellInput 1, 2, 0, 5
  .SetCellFontStyle 1, 2, 0, 2
  .SetCellInput 2, 2, 0, 5
  .SetCellBackColor 2, 2, 0, .FindColorIndex(RGB(&HFF, &HFF, &HFF), 1)
  
  
  .SetCellString 1, 3, 0, "组_名_称："
  .SetCellAlign 1, 3, 0, 2 + 32
  .SetCellInput 1, 3, 0, 5
  .SetCellFontStyle 1, 3, 0, 2
    
  .SetCellString 1, 4, 0, "启用标志："
  .SetCellAlign 1, 4, 0, 2 + 32
  .SetCellInput 1, 4, 0, 5
  .SetCellFontStyle 1, 4, 0, 2
  
  .SetDroplistCell 2, 4, 0, "启用" & vbCrLf & "禁止" & vbCrLf, 4

  .SetCellString 1, 5, 0, "组_描_述："
  .SetCellAlign 1, 5, 0, 2 + 32
  .SetCellInput 1, 5, 0, 5
  .SetCellFontStyle 1, 5, 0, 2
  
  For iLoop = 2 To 5
   .SetCellNumType 2, iLoop, 0, 7
  Next
 End With
End Sub

'//装载报表信息
Private Sub LoadRpt()
 Dim iLoop As Integer
 With frmRpt
  '//
  .Face.Rows = 2
  .Face.FixedRows = 1
  .Face.Cols = 5
  .col(1).Width = 0
  .col(1).Switch(E_LDG_ColFlag_Hide) = True
  
  .col(2).Width = 1500
  .col(2).Align = E_LDG_AlignLeft
  
  .col(3).Width = 1500
  .col(3).Align = E_LDG_AlignLeft
  
  .col(4).Width = 1000
  .col(4).Align = E_LDG_AlignLeft
  
  .col(5).Width = 1000
  .col(5).Align = E_LDG_AlignLeft
 End With
End Sub

Private Sub RefreshLdg()
 On Error GoTo Errhandler
 lSql = meCell.ListSql
 If daRs.State = adStateOpen Then daRs.Close
 daRs.CursorLocation = adUseClient
 daRs.Open lSql, daCn, adOpenStatic, adLockReadOnly
 frmRpt.Merge.UnMergeAll
 frmRpt.Face.Rows = daRs.RecordCount + frmRpt.Face.FixedRows
 frmRpt.Face.ForceRefresh
 Exit Sub
Errhandler:
 MsgBox "错误，编号：" & Err.Number & "-->信息：" & Err.Description, vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
End Sub

Private Sub SelData()
 Dim objGlass As Object
 Dim objGetEntry As Object
 Set objGlass = CreateObject("SelRptGroup.SelRptGroupCls")
 objGlass.setUserID = meObj.BaseInfo.getUserID
 objGlass.setClassID = meObj.BaseInfo.getClassID
 Call objGlass.mShow(1)
 Set objGetEntry = objGlass.getRptGroup
 If Not IsNull(objGetEntry) Then
  '//数据打包
  With objEntry
   .Js_ParentID = objGetEntry.Js_GroupID
   If .Js_GroupID = 0 Then
    .Js_Level = objGetEntry.Js_Level + 1
   End If
   frmCell.SetCellString 2, 2, 0, objGetEntry.Js_GroupName
  End With
 End If
 Set objGetEntry = Nothing
 Set objGlass = Nothing
End Sub

Private Function validateData(ByRef inMsg As String) As Boolean
 On Error GoTo ErrHandle
 Dim getValue As String
 '//getValue = Trim(frmCell.GetCellString2(2, 2, 0))
 '//If getValue = "" Then
  '//inMsg = "请选择资料位置"
  '//validateData = False
  '//Exit Function
 '//End If
 '//
 getValue = Trim(frmCell.GetCellString2(2, 3, 0))
 If getValue = "" Then
  inMsg = "请输入报表组的名称"
  validateData = False
  Exit Function
 End If
 '//
 getValue = Trim(frmCell.GetCellString2(2, 4, 0))
 If getValue = "" Then
  inMsg = "请选择报表组的状态"
  validateData = False
  Exit Function
 End If
 '//
 validateData = True
 Exit Function
ErrHandle:
 inMsg = Err.Description
 validateData = False
End Function

Private Function SaveData(ByRef inMsg As String) As Boolean
 On Error GoTo ErrHandle
 Dim SaveITemID As Long
 If validateData(inMsg) = False Then
  SaveData = False
  Exit Function
 End If
 '//开始打包数据
 With objEntry
  If .Js_GroupID = 0 Then
   .Js_GroupID = meObj.BaseInfo.getItemID(10)
   .Js_ParentID = .Js_ParentID
   .Js_Number = "0x"
   .Js_GroupName = Trim(frmCell.GetCellString2(2, 3, 0))
   .Js_RptList = .Js_RptList
   .Js_Desc = Trim(frmCell.GetCellString2(2, 5, 0))
   .Js_Level = .Js_Level
   .Js_Detail = 1
   .Js_UseSign = Cn2Num(Trim(frmCell.GetCellString2(2, 4, 0)))
   .Js_UserID = meObj.BaseInfo.getUserID
   .Js_Date = meObj.BaseInfo.getServerDate(1)
   .Js_Time = meObj.BaseInfo.getServerDate(2)
   .Js_Ico = ""
   .Js_Sel = ""
  Else
   .Js_GroupID = .Js_GroupID
   .Js_ParentID = .Js_ParentID
   .Js_Number = "0x"
   .Js_GroupName = Trim(frmCell.GetCellString(2, 3, 0))
   .Js_RptList = .Js_RptList
   .Js_Desc = Trim(frmCell.GetCellString(2, 5, 0))
   .Js_Level = .Js_Level
   .Js_Detail = .Js_Detail
   .Js_UseSign = Cn2Num(Trim(frmCell.GetCellString2(2, 4, 0)))
   .Js_UserID = .Js_UserID
   .Js_Date = .Js_Date
   .Js_Time = .Js_Time
   .Js_Ico = .Js_Ico
   .Js_Sel = .Js_Sel
  End If
  '//
  If .Save(inMsg) = False Then
   SaveData = False
   Exit Function
  Else
   inMsg = "保存资料成功"
   SaveData = True
   Exit Function
  End If
 End With
 SaveData = True
 Exit Function
ErrHandle:
 inMsg = Err.Description
 SaveData = False
End Function

Private Function DelCheck(ByRef inMsg As String) As Boolean
 On Error GoTo ErrHandle
 '//
 If SelItemID = 0 Then
  inMsg = "请选择要删除得条目"
  DelCheck = False
  Exit Function
 End If
 '//
 Dim daCn As New ADODB.Connection
 Dim daRs As New ADODB.Recordset
 Dim Sql As String
 Dim tCount As Integer
 Sql = "select count(*) as tcount from Js_RptGroup where Js_ParentID=" & SelItemID
 daCn.ConnectionString = meObj.BaseInfo.getConStr
 daCn.Open
 daRs.Open Sql, daCn, adOpenStatic, adLockReadOnly
 If Not daRs.EOF And Not IsNull(daRs("tcount")) Then
  tCount = daRs("tcount")
 Else
  tCount = 0
 End If
 daRs.Close
 Set daRs = Nothing
 If tCount <> 0 Then
  inMsg = "选择得组下存在子下级组"
  DelCheck = False
  Exit Function
 End If
 '//
 Dim iMsgInfo As Long
 iMsgInfo = MsgBox("确认删除[" & Trim(frmRpt.Cell(frmRpt.Sel.row, 2).Text) & "]？", vbQuestion + vbYesNo + vbDefaultButton2, meObj.BaseInfo.getMsgInfo)
 If iMsgInfo <> 6 Then
  inMsg = "取消删除动作"
  DelCheck = False
  Exit Function
 End If
 Sql = "delete from Js_RptGroup where Js_GroupID=" & SelItemID
 daCn.Execute Sql
 daCn.Close
 Set daCn = Nothing
 inMsg = "删除[" & Trim(frmRpt.Cell(frmRpt.Sel.row, 2).Text) & "]成功"
 DelCheck = True
 Exit Function
ErrHandle:
 inMsg = "发生错误：" & Err.Description
 DelCheck = False
End Function


'//
Private Function NewData(ByRef inMsg As String) As Boolean
 On Error GoTo ErrHandle
 With objEntry
  .Js_GroupID = 0
  .Js_ParentID = 0
  .Js_Number = ""
  .Js_GroupName = ""
  .Js_RptList = ""
  .Js_Desc = ""
  .Js_Level = 0
  .Js_Detail = 0
  .Js_UseSign = 0
  .Js_UserID = 0
  .Js_Date = ""
  .Js_Time = ""
  .Js_Ico = ""
  .Js_Sel = ""
 End With
 SelItemID = 0
 With frmCell
  .SetCellString 2, 2, 0, ""
  .SetCellString 2, 3, 0, ""
  .SetCellString 2, 4, 0, ""
  .SetCellString 2, 5, 0, ""
 End With
 NewData = True
 Exit Function
ErrHandle:
 inMsg = "未知错误：" & Err.Description
 NewData = False
End Function



Private Sub Form_Load()
 Call formInit
 Call LoadTBar
 Call LoadSBar
 Call LoadCell
 Call LoadRpt
 Call RefreshLdg
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Set ImgStd = Nothing
  If daCn.State = adStateOpen Then daCn.Close
  If daRs.State = adStateOpen Then daRs.Close
  Set daCn = Nothing
  Set daRs = Nothing
  Set objEntry = Nothing
End Sub

Private Sub frmCell_MouseDClick(ByVal col As Long, ByVal row As Long)
 Select Case col
  Case 2
   Select Case row
    Case 2
     Call SelData
   End Select
 End Select
End Sub

Private Sub PrintData()
 Dim lngRet As Long
 lngRet = MsgboxEx(hWnd, "选择打印对象", vbQuestion + vbAbortRetryIgnore, "打印选择")
 Select Case lngRet
  Case 3
   frmRpt.Printer.Preview
  Case 4
   frmCell.PrintPreview 100, 0
  Case 5
   Exit Sub
 End Select
End Sub

Private Sub frmRpt_Click()
 SelItemID = Val(frmRpt.Cell(frmRpt.Sel.row, 1).Text)
End Sub

Private Sub frmRpt_DblClick()
 Dim MsgInfo As String
 If objEntry.Load(SelItemID, MsgInfo) = True Then
  With frmCell
   .SetCellString 2, 2, 0, Trim(frmRpt.Cell(frmRpt.Sel.row, 3).Text)
   .SetCellString 2, 3, 0, Trim(frmRpt.Cell(frmRpt.Sel.row, 2).Text)
   .SetCellString 2, 4, 0, Trim(frmRpt.Cell(frmRpt.Sel.row, 5).Text)
   .SetCellString 2, 5, 0, objEntry.Js_Desc
  End With
 End If
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 = "组内码|组名称|上级名称|组类型|启动标志|"
  Exit Sub
 End If
 daRs.AbsolutePosition = lRow - frmRpt.Face.FixedRows
 strRowData = daRs(0) & "|" & daRs(1) & "|" & daRs(2) & "|" & daRs(3) & "|" & daRs(4) & "|"
End Sub

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

Private Sub TBar_ToolClick(ByVal Tool As ActiveBar2LibraryCtl.Tool)
 Dim MsgInfo As String
 Select Case Tool.Name
  Case "TNew"
   If NewData(MsgInfo) = False Then
    MsgBox MsgInfo, vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
   End If
  Case "TEdit"
   Call frmRpt_DblClick
  Case "TDel"
   If DelCheck(MsgInfo) = True Then
    MsgBox MsgInfo, vbInformation + vbOKOnly, meObj.BaseInfo.getMsgInfo
    Call RefreshLdg
   Else
    MsgBox MsgInfo, vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
   End If
  Case "TSave"
   If SaveData(MsgInfo) = True Then
    MsgBox MsgInfo, vbInformation + vbOKOnly, meObj.BaseInfo.getMsgInfo
    Call RefreshLdg
   Else
    MsgBox MsgInfo, vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
   End If
  Case "TFind"
   MsgBox "本版本中不提供此功能,联系[0813-5515190]", vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
  Case "TPrint"
   Call PrintData
  Case "TExit"
   Unload Me
 End Select
End Sub