frmmain.frm

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

  .SetCellAlign 1, 11, 0, 2 + 32
  .SetCellInput 1, 11, 0, 5
  .SetCellFontStyle 1, 11, 0, 2
  
  .SetCellString 1, 12, 0, "用户邮箱："
  .SetCellAlign 1, 12, 0, 2 + 32
  .SetCellInput 1, 12, 0, 5
  .SetCellFontStyle 1, 12, 0, 2
  
  
  .SetCellString 1, 13, 0, "用户电话："
  .SetCellAlign 1, 13, 0, 2 + 32
  .SetCellInput 1, 13, 0, 5
  .SetCellFontStyle 1, 13, 0, 2
  
  .SetCellString 1, 14, 0, "用户网址："
  .SetCellAlign 1, 14, 0, 2 + 32
  .SetCellInput 1, 14, 0, 5
  .SetCellFontStyle 1, 14, 0, 2
  
  .SetCellString 1, 15, 0, "用户住址："
  .SetCellAlign 1, 15, 0, 2 + 32
  .SetCellInput 1, 15, 0, 5
  .SetCellFontStyle 1, 15, 0, 2
  
  .SetCellString 1, 16, 0, "用户邮编："
  .SetCellAlign 1, 16, 0, 2 + 32
  .SetCellInput 1, 16, 0, 5
  .SetCellFontStyle 1, 16, 0, 2
  
  For iLoop = 2 To 16
   .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 = 1000
  .col(2).Align = E_LDG_AlignLeft
  
  .col(3).Width = 2000
  .col(3).Align = E_LDG_AlignLeft
  
  .col(4).Width = 1500
  .col(4).Align = E_LDG_AlignLeft
  
  .col(5).Width = 1500
  .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 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
 '//
 getValue = Trim(frmCell.GetCellString2(2, 6, 0))
 If getValue = "" Then
  inMsg = "请选择用户登录方案"
  validateData = False
  Exit Function
 End If
 '//
 getValue = Trim(frmCell.GetCellString2(2, 10, 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_UserID = 0 Then
   .Js_UserID = meObj.BaseInfo.getItemID(12)
   .Js_UserNumber = "0x"
   .Js_UserName = Trim(frmCell.GetCellString(2, 3, 0))
   .Js_UserPass = meObj.BaseInfo.getMd5Pass(UserPass, 32)
   .Js_UserGroupList = .Js_UserGroupList
   .Js_LogonPreceptID = .Js_LogonPreceptID
   .Js_RightID = .Js_RightID
   .Js_Desc = Trim(frmCell.GetCellString(2, 9, 0))
   .Js_UseSign = Cn2Num(Trim(frmCell.GetCellString2(2, 10, 0)))
   .Js_HandsetCode = Trim(frmCell.GetCellString2(2, 11, 0))
   .Js_EMailAddr = Trim(frmCell.GetCellString2(2, 12, 0))
   .Js_PhoneCode = Trim(frmCell.GetCellString2(2, 13, 0))
   .Js_WebAddr = Trim(frmCell.GetCellString2(2, 14, 0))
   .Js_UserAdrr = Trim(frmCell.GetCellString2(2, 15, 0))
   .Js_MailCode = Trim(frmCell.GetCellString2(2, 16, 0))
   .Js_AddUserID = meObj.BaseInfo.getUserID
   .Js_AddDate = meObj.BaseInfo.getServerDate(1)
   .Js_AddTime = meObj.BaseInfo.getServerDate(2)
   .Js_RightList = .Js_RightList
  Else
   .Js_UserID = .Js_UserID
   .Js_UserNumber = "0x"
   .Js_UserName = Trim(frmCell.GetCellString(2, 3, 0))
   .Js_UserPass = meObj.BaseInfo.getMd5Pass(UserPass, 32)
   .Js_UserGroupList = .Js_UserGroupList
   .Js_LogonPreceptID = .Js_LogonPreceptID
   .Js_RightID = .Js_RightID
   .Js_Desc = Trim(frmCell.GetCellString(2, 9, 0))
   .Js_UseSign = Cn2Num(Trim(frmCell.GetCellString2(2, 10, 0)))
   .Js_HandsetCode = Trim(frmCell.GetCellString2(2, 11, 0))
   .Js_EMailAddr = Trim(frmCell.GetCellString2(2, 12, 0))
   .Js_PhoneCode = Trim(frmCell.GetCellString2(2, 13, 0))
   .Js_WebAddr = Trim(frmCell.GetCellString2(2, 14, 0))
   .Js_UserAdrr = Trim(frmCell.GetCellString2(2, 15, 0))
   .Js_MailCode = Trim(frmCell.GetCellString2(2, 16, 0))
   .Js_AddUserID = .Js_AddUserID
   .Js_AddDate = .Js_AddDate
   .Js_AddTime = .Js_AddTime
   .Js_RightList = .Js_RightList
  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 iMsgInfo As Long
 iMsgInfo = MsgBox("确认删除[" & Trim(frmRpt.Cell(frmRpt.Sel.row, 2).Text) & "]？", vbQuestion + vbYesNo + vbDefaultButton2, meObj.BaseInfo.getMsgInfo)
 If iMsgInfo <> 6 Then
  inMsg = "取消删除动作"
  Set daRs = Nothing
  Set daCn = Nothing
  DelCheck = False
  Exit Function
 End If
 '//
 daCn.ConnectionString = meObj.BaseInfo.getConStr
 daCn.Open
 Sql = "delete from Js_User where Js_UserID=" & 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_UserID = 0 '// As Long
  .Js_UserNumber = "" '// As String
  .Js_UserName = "" '// As String
  .Js_UserPass = "" '// As String
  .Js_UserGroupList = "" '// As String
  .Js_LogonPreceptID = 0 '// As Long
  .Js_RightID = 0 '// As Long
  .Js_Desc = "" '// As String
  .Js_UseSign = 0 '// As Long
  .Js_HandsetCode = "" '// As String
  .Js_EMailAddr = "" '// As String
  .Js_PhoneCode = "" '// As String
  .Js_WebAddr = "" '// As String
  .Js_UserAdrr = "" '// As String
  .Js_MailCode = "" '// As String
  .Js_AddUserID = 0 '// As Long
  .Js_AddDate = "" '// As String
  .Js_AddTime = "" '// As String
 End With
 SelItemID = 0
 With frmCell
  .SetCellString 2, 2, 0, ""
  .SetCellString 2, 3, 0, ""
  .SetCellString 2, 4, 0, ""
  .SetCellString 2, 5, 0, ""
  .SetCellString 2, 6, 0, ""
  .SetCellString 2, 7, 0, ""
  .SetCellString 2, 8, 0, ""
  .SetCellString 2, 9, 0, ""
  .SetCellString 2, 10, 0, ""
  .SetCellString 2, 11, 0, ""
  .SetCellString 2, 12, 0, ""
  .SetCellString 2, 13, 0, ""
  .SetCellString 2, 14, 0, ""
  .SetCellString 2, 15, 0, ""
  .SetCellString 2, 16, 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 4 '//密码
     frmPass.Show vbModal
     frmCell.SetCellString col, row, 0, "******"
    Case 5 '//组属
     SelUser.Show vbModal
     objEntry.Js_UserGroupList = SelUserIDList
     frmCell.SetCellString col, row, 0, SelUserNameList
     SelUserIDList = ""
     SelUserNameList = ""
    Case 6 '//登录方案
     Call SelLogon
    Case 7
     Call SelRight
   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 SelRight()
 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_RightID = objGetEntry.Js_RightID
   frmCell.SetCellString 2, 7, 0, objGetEntry.Js_RightName
  End With
 End If
 Set objGetEntry = Nothing
 Set objGlass = Nothing
End Sub

Private Sub SelLogon()
 Dim objGlass As Object
 Dim objGetEntry As Object
 Set objGlass = CreateObject("SelLogonPrecept.BaseCls")
 objGlass.setUserID = meObj.BaseInfo.getUserID
 objGlass.setClassID = meObj.BaseInfo.getClassID
 Call objGlass.mShow(1)
 Set objGetEntry = objGlass.getLogonPrecept
 If Not IsNull(objGetEntry) Then
  '//数据打包
  With objEntry
   .Js_LogonPreceptID = objGetEntry.Js_LogonPreceptID
   frmCell.SetCellString 2, 6, 0, objGetEntry.Js_LogonPreceptDesc
  End With
 End If
 Set objGetEntry = Nothing
 Set objGlass = Nothing
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
 Dim RStateStr As String
 If objEntry.Load(SelItemID, MsgInfo) = True Then
  If objEntry.Js_UseSign = 1 Then
   RStateStr = "启用"
  Else
   RStateStr = "禁止"
  End If
  With frmCell
   .SetCellString 2, 3, 0, Trim(frmRpt.Cell(frmRpt.Sel.row, 2).Text)
   .SetCellString 2, 4, 0, "******"
   .SetCellString 2, 5, 0, Trim(frmRpt.Cell(frmRpt.Sel.row, 3).Text)
   .SetCellString 2, 6, 0, meObj.BaseInfo.getItemName(7, objEntry.Js_LogonPreceptID)
   .SetCellString 2, 7, 0, meObj.BaseInfo.getItemName(8, objEntry.Js_RightID)
   .SetCellString 2, 9, 0, objEntry.Js_Desc
   .SetCellString 2, 10, 0, RStateStr
   .SetCellString 2, 11, 0, objEntry.Js_HandsetCode
   .SetCellString 2, 12, 0, objEntry.Js_EMailAddr
   .SetCellString 2, 13, 0, objEntry.Js_PhoneCode
   .SetCellString 2, 14, 0, objEntry.Js_WebAddr
   .SetCellString 2, 15, 0, objEntry.Js_UserAdrr
   .SetCellString 2, 16, 0, objEntry.Js_MailCode
  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