frmoperator.frm

金算盘软件代码

    Dim edtErrReturn As ErrDealType
    
    On Error GoTo ErrHandle
    #If conVersionType = 1 Then
        SetForm 1
        mstrVersionNO = "1"
        mbytPreRight = 16
    #ElseIf conVersionType = 2 Then
        mstrVersionNO = "2"
    #ElseIf conversionno = "4" Then
        mstrVersionNO = "4"
    #ElseIf conVersionType = 8 Then
        SetForm 8
        mstrVersionNO = "8"
    #ElseIf conVersionType = 16 Then
        SetForm 16
        mstrVersionNO = "16"
    #End If
    mblnIsNext = False
    mstrVersionNO = mstrVersionNO & ","
    Utility.LoadFormResPicture Me
'    SendKeys "%{N}"
    Exit Sub
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload MsgForm
         Unload Me
    End If
End Sub

Private Sub Form_Paint()
    FrameBox hwnd, 120, 210, 120 + 6200, 210 + 1000
'    #If conVersionType = 8 Then
'        FrameBox hwnd, 3150, 1470, 3150 + 2955, 1470 + 2580
'    #ElseIf conVersionType = 16 Then
'        #If conPE = 1 Then
'            FrameBox hwnd, 3150, 1470, 3150 + 2955, 1470 + 3375
'        #Else
'            FrameBox hwnd, 3150, 1470, 3150 + 2955, 1470 + 3150
'        #End If
'    #Else
'        FrameBox hwnd, 3150, 1470, 3150 + 2955, 1470 + 4840
'    #End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If UnloadMode <> vbFormControlMenu Then Exit Sub
    If mblnIsChanged Then
        If mblnIsNew Then
            If ShowMsg(hwnd, "要保存新增的操作员吗？", vbQuestion + vbYesNo, Caption) = vbYes Then
                Cancel = Not SaveCard
            End If
        Else
            If ShowMsg(hwnd, "要保存对操作员的修改吗？", vbQuestion + vbYesNo, Caption) = vbYes Then
                Cancel = Not SaveCard
            End If
        End If
    End If
End Sub

Private Sub Form_Resize()
   On Error Resume Next
   'If Me.Height < intFormHeight Then Me.Height = intFormHeight
   'If Me.Width < intFormWidth Then Me.Width = intFormWidth
   'Frame1.Left = Me.ScaleLeft + 50
   'Frame1.Width = Me.ScaleWidth - 1215 - 75 - 100
  ' cmdOK(0).Left = Frame1.Width + Frame1.Left + 75
  ' cmdOK(1).Left = cmdOK(0).Left
  ' cmdOK(2).Left = cmdOK(0).Left
  ' chkStop.Left = cmdOK(0).Left
  ' msgAuth.Left = Frame1.Left
   'msgAuth.Width = 7 * Frame1.Width / 12
   'msgAuth.Top = Frame1.Top + Frame1.Height + 75
   'msgAuth.Height = Me.ScaleHeight - Frame1.Top - Frame1.Height - 150
   'msgAuth.ColWidth(1) = 1000
   'msgAuth.ColWidth(2) = msgAuth.Width - msgAuth.ColWidth(1)
   'Picture1.Top = msgAuth.Top + 30
   'Picture1.Left = msgAuth.Left + 1000
   'Picture1.Height = msgAuth.Height
   'cboRightGroup.Left = Picture1.Left + 30
   'cboRightGroup.Width = msgAuth.ColWidth(2) - 40
   'txtRight.Left = msgAuth.Left + msgAuth.Width + 75
   'txtRight.Top = msgAuth.Top
   'txtRight.Height = msgAuth.Height
   'txtRight.Width = Frame1.Width - msgAuth.Width - 75
   'chkStop.Top = Me.ScaleHeight - 75 - chkStop.Height
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Unload frmOperatorGrp
    Utility.UnLoadFormResPicture Me
    SetMenuRight
End Sub

Private Sub InitGrid()
    Dim i As Integer, strSql As String
    
    msgAuth.Cols = 0
    strSql = "select distinct Module.lngModuleID,OperatorRight1.lngRightGroupID," _
        & "Module.strModuleName ""系统模块""," _
        & "OperatorRight1.strRightGroupName ""权限组""," _
        & "OperatorRight1.lngRightGroupID NewRightGroupID " _
        & "FROM Module,(SELECT RightGroup.* FROM RightGroup,OperatorRight" _
        & " Where RightGroup.lngRightGroupID = OperatorRight.lngRightGroupID And " _
        & "OperatorRight.lngOperatorID=" & mlngOpID & ") OperatorRight1 " _
        & "WHERE Module.lngModuleID = OperatorRight1.lngModuleID(+) AND " _
        & "(InStr(strNotVersionNO,'" & mstrVersionNO & "') = 0 OR strNotVersionNO IS NULL"
    If gclsBase.AccountSys = "1" And gclsBase.Trade = "邮电通信" Then
        strSql = strSql & " OR Module.lngModuleID=17 "
    End If
    strSql = strSql & ")"
    Set Data1.Resultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Data1.Resultset.Close
'    mintGridRow = 1
    msgAuth.FixedAlignment(2) = flexAlignCenterCenter
    msgAuth.FixedAlignment(3) = flexAlignCenterCenter
    msgAuth.ColWidth(0) = 0
    msgAuth.ColWidth(1) = 0
    msgAuth.ColWidth(4) = 0
    msgAuth.ColWidth(2) = msgAuth.width / 3
    msgAuth.ColWidth(3) = msgAuth.width / 3 * 2 - 60
    cboRightGroup.Left = msgAuth.Left + msgAuth.ColWidth(2)
    cboRightGroup.width = msgAuth.ColWidth(3)
'    For i = 1 To msgAuth.Rows - 1
'        msgAuth.RowHeight(i) = cboRightGroup.Height
'    Next i
'    mclsGrid.SetupStyle
End Sub

Private Sub InitRightGroupList()
    Dim recRG As rdoResultset, strSql As String
    
    cboRightGroup.Clear
    strSql = "SELECT lngRightGroupID,strRightGroupName FROM RightGroup WHERE " _
        & "lngModuleID=" & mlngModuleID
    Set recRG = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until recRG.EOF
        cboRightGroup.AddItem recRG!strRightGroupName
        cboRightGroup.ItemData(cboRightGroup.NewIndex) = recRG!lngRightGroupID
        recRG.MoveNext
    Loop
    recRG.Close
    cboRightGroup.AddItem "  "
    cboRightGroup.ItemData(cboRightGroup.NewIndex) = 0
End Sub

Private Sub InitRightTree()
    Dim i As Integer, lngRightGroupID As Long, NodX As msComctlLib.Node, recRight As rdoResultset
    Dim strRoot As String, strSql As String
    
    If Trim(cboRightGroup.Text) = "" Then
        If mlngModuleID = 17 Then
            strRoot = "在建工程权限组"
        Else
            #If conVersionType = 16 Then
                #If conHos = 1 Then
                    strRoot = Choose(mlngModuleID, "系统管理权限组", "编码维护权限组", _
                        "总分类帐权限组", "应收权限组", "应付权限组", "采购权限组", _
                        "销售权限组", "库存权限组", "现金银行权限组", _
                        "工资权限组", "固定资产权限组", "财务分析权限组", _
                        "领导查询权限组", "", "", "医疗保险权限组")
                #Else
                    strRoot = Choose(mlngModuleID, "系统管理权限组", "编码维护权限组", _
                        "总分类帐权限组", "应收权限组", "应付权限组", "采购权限组", _
                        "销售权限组", "库存权限组", "现金银行权限组", _
                        "工资权限组", "固定资产权限组", "财务分析权限组", "领导查询权限组")
                #End If
            #Else
                strRoot = Choose(mlngModuleID, "系统管理权限组", "编码维护权限组", _
                    "总分类帐权限组", "应收权限组", "应付权限组", "采购权限组", _
                    "销售权限组", "库存权限组", "现金银行权限组", _
                    "工资权限组", "固定资产权限组", "财务分析权限组", _
                    "领导查询权限组", "经营分析权限组", "委托加工权限组")
            #End If
        End If
    Else
        strRoot = cboRightGroup.Text
    End If
    tvwRight.Nodes.Clear
    lngRightGroupID = TxtToDouble(msgAuth.TextMatrix(msgAuth.Row, 4))
    tvwRight.Nodes.Add , , "Root", strRoot, "EMPTY"
'    strSql = "SELECT lngRightID,strRightName FROM [Right] WHERE lngModuleID=" _
        & mlngModuleID & " AND (ISNULL(Right.strNotVersionNO) OR " _
        & "INSTR(1,Right.strNotVersionNO,'" & mstrVersionNO & "')=0)"
    strSql = "SELECT lngRightID,strRightName FROM Right WHERE lngModuleID=" _
        & mlngModuleID
    If mlngModuleID <> 17 Then
        strSql = strSql & " AND (Right.strNotVersionNO IS  NULL OR " _
            & "INSTR(Right.strNotVersionNO,'" & mstrVersionNO & "')=0)"
    End If
    Set recRight = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until recRight.EOF
        Set NodX = tvwRight.Nodes.Add("Root", tvwChild, "R" & recRight!lngRightID, recRight!strRightName, "EMPTY")
        NodX.EnsureVisible
        recRight.MoveNext
    Loop
    recRight.Close
    If lngRightGroupID > "0" Then
        For Each NodX In tvwRight.Nodes
            If NodX.Key <> "Root" Then
                If RightIsSelected(lngRightGroupID, Mid(NodX.Key, 2)) Then
                    NodX.iMage = "FULL"
                    i = i + 1
                End If
            End If
        Next NodX
        If i = tvwRight.Nodes.Count - 1 Then
            tvwRight.Nodes("Root").iMage = "FULL"
        ElseIf i = 0 Then
            tvwRight.Nodes("Root").iMage = "EMPTY"
        Else
            tvwRight.Nodes("Root").iMage = "HALF"
        End If
    End If
    tvwRight.Nodes("Root").EnsureVisible
End Sub

Private Function RightIsSelected(lngGroupID As Long, lngRightID As Long) As Boolean
    Dim recRight As rdoResultset, strSql As String
    
    strSql = "SELECT * FROM RightGroupDetail Where " _
        & "lngRightGroupID=" & lngGroupID & " AND lngRightID=" & lngRightID
    Set recRight = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    RightIsSelected = Not recRight.EOF
    recRight.Close
End Function

Private Sub Paste()
    With msgAuth
    If .Row > 0 Then
        mlngModuleID = .TextMatrix(.Row, 0)
        InitRightGroupList
        cboRightGroup.width = msgAuth.ColWidth(3)
        cboRightGroup.Left = msgAuth.Left + msgAuth.ColWidth(2) + 30
        If cboRightGroup.Enabled Then cboRightGroup.Visible = True
        cboRightGroup.top = .top + .CellTop
        If .TextMatrix(.Row, 3) = "" Then
            cboRightGroup.Text = "  "
        Else
            cboRightGroup.Text = .TextMatrix(.Row, 3)
        End If
        If cboRightGroup.Visible Then
            cboRightGroup.SetFocus
        End If
        txtUser(3).Text = Trim(cboRightGroup.Text)
        cmdOK(4).Enabled = False
        If TxtToDouble(msgAuth.TextMatrix(msgAuth.Row, 4)) < mbytPreRight And _
            TxtToDouble(msgAuth.TextMatrix(msgAuth.Row, 4)) >= 0 Then
            cmdOK(5).Enabled = False
        Else
            cmdOK(5).Enabled = True
        End If
    End If
    End With
End Sub


Private Sub lstA_Click(Index As Integer)
    RefreshButton
End Sub

Private Sub lstA_DblClick(Index As Integer)
    If Index = 0 Then
        cmdSel_Click 0
    Else
        cmdSel_Click 2
    End If
End Sub

Private Sub msgAuth_EnterCell()
    If msgAuth.Row = 0 Then Exit Sub
    Paste
    InitRightTree
End Sub

Private Sub refOperatorGroup_AddNew()
    Dim lngID As Long
    
    lngID = frmOperatorGrp.AddCard(, True)
    If lngID <> 0 Then mlngOperatorGroupID = lngID
    setlistbox refOperatorGroup, 29, mlngOperatorGroupID
    mblnIsChanged = True
End Sub

Private Sub refOperatorGroup_Change()
    If ContainErrorChar(refOperatorGroup.Text, "`~!@#$%^&*=+'"";:,./?|\") Then BKKEY refOperatorGroup.hwnd
End Sub

Private Sub refOperatorGroup_Choose()
    mlngOperatorGroupID = refOperatorGroup.ID
    mstrOperatorGroupName = refOperatorGroup.TextMatrix(refOperatorGroup.ReferRow, 2)
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Sub refOperatorGroup_Delete()
    Dim recOperator As rdoResultset, strSql As String

    If Trim(mstrOperatorGroupName) = "" Then
        ShowMsg hwnd, "请先选择一个操作员组!", vbExclamation, "删除操作员组"
        Exit Sub
    End If

    If mstrOperatorGroupName = "系统用户组" Then
        ShowMsg hwnd, "系统用户组不能删除!", vbExclamation, "删除操作员组"
        Exit Sub
    End If
    
    strSql = "SELECT * FROM Operator WHERE lngOperatorGroupID=" _
        & mlngOperatorGroupID
    Set recOperator = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recOperator.EOF Then
        ShowMsg hwnd, "操作员组“" & mstrOperatorGroupName & "”中还有操作员,不能删除！", _
        vbExclamation, "删除操作员组"
        Exit Sub
    End If
    
    If ShowMsg(hwnd, "您确实要删除“" & mstrOperatorGroupName & "”操作员组吗？", _
        vbQuestion + vbYesNo + vbDefaultButton2, "删除操作员组") = vbNo Then
        Exit Sub
    End If
    strSql = "DELETE FROM OperatorGroup WHERE lngOperatorGroupID=" _
        & mlngOperatorGroupID
    gclsBase.BaseDB.Execute strSql
    setlistbox refOperatorGroup, 29, 1
    mstrOperatorGroupName = "系统用户组"
    mblnIsChanged = True
End Sub

Private Sub refOperatorGroup_Edit()

    If mstrOperatorGroupName <> "系统用户组" Then
        frmOperatorGrp.EditCard mlngOperatorGroupID, mstrOperatorGroupName
    Else
        ShowMsg Me.hwnd, "系统用户组不能改名", vbExclamation, Me.Caption
        refOperatorGroup.Text = "系统用户组"
        Exit Sub
    End If
    setlistbox refOperatorGroup, 29, mlngOperatorGroupID
    mblnIsChanged = True
End Sub

Private Sub refOperatorGroup_ItemNotExist()
    Dim iResponse As Integer, lngID As Long
    Dim strSql As String
    
    On Error Resume Next
    If Trim(refOperatorGroup.Text) = "" Or Not refOperatorGroup.Enabled Then Exit Sub
    mblnIsExist = True
    iResponse = frmMsgQuickAdd.MsgAddShow(Caption, "操作员组中没有" & refOperatorGroup.Text)
    If iResponse = vbOK Then
        lngID = frmOperatorGrp.AddCard(refOperatorGroup.Text, True)
    ElseIf iResponse = 0 Then
        lngID = GetNewID("OperatorGroup")
        strSql = "INSERT INTO OperatorGroup(lngOperatorGroupID,strOperatorGroupName) VALUES (" _