frmmain.frm

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

  .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
  .SetCellInput 2, 4, 0, 5
  .SetCellBackColor 2, 4, 0, .FindColorIndex(RGB(&HFF, &HFF, &HFF), 1)
  
  .SetCellString 1, 5, 0, "启用标志："
  .SetCellAlign 1, 5, 0, 2 + 32
  .SetCellInput 1, 5, 0, 5
  .SetCellFontStyle 1, 5, 0, 2
  
  .SetDroplistCell 2, 5, 0, "启用" & vbCrLf & "禁止" & vbCrLf, 4

  
  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 = 9
  '//.Printer.Header(0).Text = "当前&[页]/共计&[总页]页"
  .col(1).Width = 0
  .col(1).Switch(E_LDG_ColFlag_Hide) = True
  
  .col(2).Width = 1000
  .col(2).Align = E_LDG_AlignLeft
  
  .col(3).Width = 1000
  .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
  
  .col(6).Width = 1000
  .col(6).Align = E_LDG_AlignLeft
  
  .col(7).Width = 1000
  .col(7).Align = E_LDG_AlignLeft
  
  .col(8).Width = 1000
  .col(8).Align = E_LDG_AlignLeft
  
  .col(9).Width = 1000
  .col(9).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("SelRight.SelRightCls")
 objGlass.setUserID = meObj.BaseInfo.getUserID
 objGlass.setClassID = meObj.BaseInfo.getClassID
 Call objGlass.mShow(1)
 Set objGetEntry = objGlass.getRight
 If Not IsNull(objGetEntry) Then
  '//数据打包
  With objEntry
   .Js_RightParentID = objGetEntry.Js_RightID
   If .Js_RightID = 0 Then
    .Js_RightLevel = objGetEntry.Js_RightLevel + 1
   End If
   frmCell.SetCellString 2, 2, 0, objGetEntry.Js_RightName
  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
 '//
 getValue = Trim(frmCell.GetCellString2(2, 5, 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_RightID = 0 Then
   .Js_RightID = meObj.BaseInfo.getItemID(8)
   .Js_RightParentID = .Js_RightParentID
   .Js_RightNumber = "0x"
   .Js_RightName = Trim(frmCell.GetCellString(2, 3, 0))
   .Js_RightDesc = .Js_RightDesc '// Trim(frmCell.GetCellString2(2, 4, 0))
   .Js_RightLevel = .Js_RightLevel
   .Js_RightDetail = 1
   .Js_RightUseSign = Cn2Num(Trim(frmCell.GetCellString2(2, 5, 0)))
   .Js_RightUserID = meObj.BaseInfo.getUserID
   .Js_RightDate = meObj.BaseInfo.getServerDate(1)
   .Js_RightTime = meObj.BaseInfo.getServerDate(2)
  Else
   .Js_RightID = .Js_RightID
   .Js_RightParentID = .Js_RightParentID
   .Js_RightNumber = "0x"
   .Js_RightName = Trim(frmCell.GetCellString(2, 3, 0))
   .Js_RightDesc = .Js_RightDesc '//Trim(frmCell.GetCellString2(2, 4, 0))
   .Js_RightLevel = .Js_RightLevel
   .Js_RightDetail = .Js_RightDetail
   .Js_RightUseSign = Cn2Num(Trim(frmCell.GetCellString2(2, 5, 0)))
   .Js_RightUserID = .Js_RightUserID
   .Js_RightDate = .Js_RightDate
   .Js_RightTime = .Js_RightTime
  End If
  '//
  If .Save(inMsg) = False Then
   SaveData = False
   Exit Function
  Else
   inMsg = "保存资料成功"
   SaveData = True
   SaveITemID = .Js_RightID
   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_Right where Js_RightParentID=" & 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, 3).Text) & "]？", vbQuestion + vbYesNo + vbDefaultButton2, meObj.BaseInfo.getMsgInfo)
 If iMsgInfo <> 6 Then
  inMsg = "取消删除动作"
  DelCheck = False
  Exit Function
 End If
 Sql = "delete from Js_Right where Js_RightID=" & SelItemID
 daCn.Execute Sql
 daCn.Close
 Set daCn = Nothing
 inMsg = "删除[" & Trim(frmRpt.Cell(frmRpt.Sel.row, 3).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_RightID = 0
  .Js_RightParentID = 0
  .Js_RightNumber = ""
  .Js_RightName = ""
  .Js_RightDesc = ""
  .Js_RightLevel = 0
  .Js_RightDetail = 0
  .Js_RightUseSign = 0
  .Js_RightUserID = 0
  .Js_RightDate = ""
  .Js_RightTime = ""
 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 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 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
    Case 4
     SelUser.Show vbModal
     objEntry.Js_RightDesc = SelUserIDList
     frmCell.SetCellString col, row, 0, SelUserNameList
     SelUserIDList = ""
     SelUserNameList = ""
   End Select
 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, 2).Text)
   .SetCellString 2, 3, 0, Trim(frmRpt.Cell(frmRpt.Sel.row, 3).Text)
   .SetCellString 2, 4, 0, Trim(frmRpt.Cell(frmRpt.Sel.row, 4).Text)
   .SetCellString 2, 5, 0, Trim(frmRpt.Cell(frmRpt.Sel.row, 6).Text)
  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
 'For iLoop = 0 To frmRpt.Face.Cols - 1
 strRowData = daRs(0) & "|" & daRs(1) & "|" & daRs(2) & "|" & daRs(3) & "|" & daRs(4) & "|" & daRs(5) & "|" & daRs(6) & "|" & daRs(7) & "|" & daRs(8) & "|"
 'Next
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 "本版本中不提供此功能,联系[13990029080]", vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
  Case "TPrint"
   Call PrintData
  Case "TExit"
   Unload Me
 End Select
End Sub