frmmain.frm

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

  .ItemAdd 1, "报表设计", 0, 10
  .RaiseSubItemPrePaint = True
 End With
End Sub

Private Sub RptList()
 '//报表列表
 With HMenu
  .Clear
  .ItemAdd 1, "报表列表", 0, 11
  .RaiseSubItemPrePaint = True
 End With
End Sub

Private Sub EditData()
 With HMenu
  .Clear
  .ItemAdd 1, "数据编辑", 0, 12
  .RaiseSubItemPrePaint = True
 End With
End Sub

''//选择数据文件
'Private Function ExportDataFileName(ByRef outFileName As String, ByRef oMsgInfo As String) As Boolean
' frmSave.CancelError = True
' On Error GoTo ErrHandl
' frmSave.DialogTitle = "保存数据库"
' frmSave.Filter = "Microsoft Sql Data(*.Dat)|*.Dat"
' frmSave.ShowSave
' outFileName = frmSave.FileName
' frmSave.FilterIndex = 1
' ExportDataFileName = True
' Exit Function
'ErrHandl:
' oMsgInfo = "错误：" & Err.Description
' ExportDataFileName = False
'End Function
'
''//导出数据
'Private Function ExportData(ByRef oMsgInfo As String) As Boolean
' frmSave.CancelError = True
' On Error GoTo ErrHandle
' Dim oFileName As String
' Dim DaCn As New ADODB.Connection
' Dim Sql As String
' If ExportDataFileName(oFileName, oMsgInfo) = True Then
'  If Trim(oFileName) = "" Then
'   Set DaCn = Nothing
'   ExportData = False
'   Exit Function
'  End If
'  Sql = "BACKUP DATABASE DfpcoProducts TO DISK = '" & oFileName & "'"
'  DaCn.ConnectionString = obj.getRConStr
'  DaCn.Open
'  DaCn.Execute Sql
'  DaCn.Close
' End If
' Set DaCn = Nothing
' oMsgInfo = "导出数据成功"
' ExportData = True
' Exit Function
'ErrHandle:
' If DaCn.State = adStateOpen Then DaCn.Close
' Set DaCn = Nothing
' oMsgInfo = "错误：" & Err.Description
' ExportData = False
'End Function
'
''//选择数据文件
'Private Function ImportDataFileName(ByRef inFileName As String, ByRef oMsgInfo As String) As Boolean
' frmSave.CancelError = True
' On Error GoTo ErrHandle
' Dim SaveFileType As Integer '//导出文件的类型
' frmSave.DialogTitle = "选择导入的数据文件"
' frmSave.Filter = "Microsoft Sql Data(*.Dat)|*.Dat"
' frmSave.ShowOpen
' inFileName = frmSave.FileName
' SaveFileType = frmSave.FilterIndex
' ImportDataFileName = True
' Exit Function
'ErrHandle:
' oMsgInfo = "错误：" & Err.Description
' ImportDataFileName = False
'End Function
'
''//导入数据
'Private Function ImportData(ByRef oMsgInfo As String) As Boolean
' On Error GoTo ErrHandle
' Dim iFileName As String
' Dim DaCn As New ADODB.Connection
' Dim Sql As String
' If ImportDataFileName(iFileName, oMsgInfo) = True Then
'  Sql = "RESTORE DATABASE DfpcoProducts  FROM DISK = '" & iFileName & "'"
'  DaCn.ConnectionString = obj.getRConStr
'  DaCn.Open
'  DaCn.Execute Sql
'  DaCn.Close
' End If
' Set DaCn = Nothing
' oMsgInfo = "恢复数据成功"
' ImportData = True
' Exit Function
'ErrHandle:
' If DaCn.State = adStateOpen Then DaCn.Close
' Set DaCn = Nothing
' oMsgInfo = "错误：" & Err.Description
' ImportData = False
'End Function


Private Sub Form_Unload(Cancel As Integer)
 Dim myData As String
 Dim EObj As Object
 Set EObj = CreateObject("ABCCrypto2.Crypto")
 EObj.License = "131-598-271-072"
 EObj.Password = "FxGang_Soft"
 myData = EObj.Encrypt("Quit")
 If frmLink.State <> sckClosed And frmLink.State <> sckError And frmLink.State <> sckClosing Then
  frmLink.SendData myData
 End If
 Set EObj = Nothing
 Set obj = Nothing
 Set imgStd = Nothing
End Sub

Private Sub HMenu_DblClick()
Dim MsgInfo As String
Dim objGlass As Object
 Select Case RmID
  Case 1 '//系统设置
   Select Case SmID
    Case 1 '//基础资料设置
     Select Case SmItemID
      Case 0 '//密码修改
       If obj.getUserRight(UserID, 2, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       ChangePass.Show vbModal
      Case 1 '//用户组
       If obj.getUserRight(UserID, 3, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       Set objGlass = CreateObject("UserGroup.UserGroupCls")
       objGlass.setUserID = UserID
       Call objGlass.mShow(1)
      Case 2 '//用户
       If obj.getUserRight(UserID, 4, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       Set objGlass = CreateObject("User.UserCls")
       objGlass.setUserID = UserID
       Call objGlass.mShow(1)
      Case 3 '//用户导入
       If obj.getUserRight(UserID, 5, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       Set objGlass = CreateObject("StdRptBase.User")
       If objGlass.UserImport(MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
       Else
        MsgBox MsgInfo, vbInformation + vbOKOnly, obj.getMsgInfo
       End If
      Case 4 '//报表组
       If obj.getUserRight(UserID, 6, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       Set objGlass = CreateObject("RptGroup.RptGroupCls")
       objGlass.setUserID = UserID
       Call objGlass.mShow(1)
      Case 5 '//登录方案
       If obj.getUserRight(UserID, 7, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       Set objGlass = CreateObject("LogonPrecept.BaseCls")
       objGlass.setUserID = UserID
       Call objGlass.mShow(1)
      Case 6 '//权限方案
       If obj.getUserRight(UserID, 8, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       Set objGlass = CreateObject("Right.RightCls")
       objGlass.setUserID = UserID
       Call objGlass.mShow(1)
      Case 7 '//权限设置
       If obj.getUserRight(UserID, 9, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       Set objGlass = CreateObject("gdRight.gdRightCls")
       objGlass.setUserID = UserID
       Call objGlass.mShow
      Case 8 '//数据库备份
       If obj.getUserRight(UserID, 10, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       MsgBox "预留功能", vbCritical + vbOKOnly, obj.getMsgInfo
      Case 9 '//数据库恢复
       If obj.getUserRight(UserID, 11, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       MsgBox "预留功能", vbCritical + vbOKOnly, obj.getMsgInfo
      Case 10 '//数据升级
       If obj.getUserRight(UserID, 12, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       Call DataUpdat
     End Select
    End Select
  Case 2 '//报表设计
   Select Case SmID
    Case 1 '//设计报表
     Select Case SmItemID
      Case 0
       If obj.getUserRight(UserID, 13, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       Set objGlass = CreateObject("Rpt.RptCls")
       objGlass.setUserID = UserID
       objGlass.setRptID = 0
       Call objGlass.mShow(1)
     End Select
    Case 2 '//报表列表
     Select Case SmItemID
      Case 0
       If obj.getUserRight(UserID, 14, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       Set objGlass = CreateObject("RptList.RptListCls")
       objGlass.setUserID = UserID
       objGlass.setClassID = obj.getClassId
       Call objGlass.mShow(1)
     End Select
   End Select
  Case 3 '//数据编辑
   Select Case SmID
    Case 1 '// 数据编辑
     Select Case SmItemID
      Case 0 '//数据编辑
       If obj.getUserRight(UserID, 15, MsgInfo) = False Then
        MsgBox MsgInfo, vbCritical + vbOKOnly, obj.getMsgInfo
        Exit Sub
       End If
       Set objGlass = CreateObject("EditTable.EditTableCls")
       objGlass.setUserID = UserID
       objGlass.setClassID = obj.getClassId
       Call objGlass.mShow(1)
     End Select
   End Select
 End Select
 Set objGlass = Nothing
End Sub

Private Sub HMenu_ItemClick(Item As Integer)
  SmItemID = Item
End Sub

Private Sub TBar_MenuClick(ByVal ID As String, ByVal Caption As String)
 Select Case ID
  Case "001"
   Unload Me
   End
 End Select
End Sub

Private Sub VMenu_SubItemClick(ByVal Index As Integer, ByVal SubItemIndex As Integer)
 RmID = Index
 SmID = SubItemIndex
 '//MsgBox Index & "->" & SubItemIndex
 Select Case Index
  Case 1
   '//系统设置
   Select Case SubItemIndex
    Case 1
     '//系统设置
     Call SysCfg
   End Select
  Case 2
   '//报表设计
   Select Case SubItemIndex
    Case 1
     '//报表设计
     Call NewRpt
    Case 2
     '//报表列表
     Call RptList
   End Select
  Case 3
   Select Case SubItemIndex
    Case 1
     '//数据编辑
     Call EditData
   End Select
 End Select
End Sub