frmoperator.frm

金算盘软件代码

            If msgAuth.Row < msgAuth.Rows - 1 Then
                msgAuth.Row = msgAuth.Row + 1
            End If
        ElseIf Shift = 1 Then
            If msgAuth.Row > 1 Then
                msgAuth.Row = msgAuth.Row - 1
            End If
        End If
    End If
End Sub

Private Function CheckUserPass() As Boolean
    Dim recOperator As rdoResultset, strSql As String
    
    CheckUserPass = False
    
    If Trim$(txtUser(0).Text) = "" Then
        ShowMsg hwnd, "操作员名称不能为空！", vbExclamation, Me.Caption
        txtUser(0).SetFocus
        Exit Function
    End If
    
    If Trim$(refOperatorGroup.Text) = "" Then
        ShowMsg hwnd, "操作员“" & txtUser(0).Text & "”所属用户组不能为空！", _
            vbExclamation, Me.Caption
        refOperatorGroup.SetFocus
        Exit Function
    End If
    
    strSql = "SELECT * FROM Operator WHERE strOperatorName='" _
        & txtUser(0).Text & "' AND lngOperatorID<>" & mlngOpID
    Set recOperator = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recOperator.EOF Then
        ShowMsg Me.hwnd, "操作员名称不能为重复,请重新录入！", vbExclamation, Me.Caption
        txtUser(0).SetFocus
        txtUser(0).SelStart = 0
        txtUser(0).SelLength = Len(txtUser(0).Text)
        Exit Function
    End If
    
    If Not mblnIsNew Then
        If mstrPassword <> txtUser(1).Text Or mstrPassword <> txtUser(2).Text Then
            If gclsBase.OperatorID = 1 And mlngOpID <> 1 Then
                If txtUser(1).Text <> "" Or txtUser(2).Text <> "" Then
                    ShowMsg hwnd, gclsBase.OperatorName & "只能清除其它操作员的口令，" _
                    & "不能修改其它操作员的口令！", vbExclamation, Caption
                    txtUser(1).Text = mstrPassword
                    txtUser(2).Text = mstrPassword
                    txtUser(1).SetFocus
                    Exit Function
                End If
            End If
        End If
    End If
    
    If Trim$(txtUser(2).Text) <> Trim$(txtUser(1).Text) Then
        ShowMsg hwnd, "<口令>与<确认口令>不一致!", vbExclamation, Me.Caption
        txtUser(1).SetFocus
        txtUser(1).SelStart = 0
        txtUser(1).SelLength = Len(txtUser(1).Text)
        Exit Function
    End If
    CheckUserPass = True
End Function

Private Sub chkA_Click()
    Dim b As Byte
    
    If chkA.Value = Unchecked Then
        Label1(6).Enabled = True
        Label1(7).Enabled = True
        For b = 0 To 3
            cmdSel(b).Enabled = True
            If b < 2 Then lstA(b).Enabled = True
        Next b
    Else
        Label1(6).Enabled = False
        Label1(7).Enabled = False
        For b = 0 To 3
            cmdSel(b).Enabled = False
            If b < 2 Then lstA(b).Enabled = False
        Next b
        cmdSel_Click 3
    End If
    mblnIsChanged = True
End Sub

Private Sub chkStop_Click()
    
    If chkStop.Value = vbChecked Then
        If IsWorking(mlngOpID) Then
            If ShowMsg(hwnd, "操作员“" & txtUser(0).Text & "”正在上机，您确实要对他停用吗？", _
                vbQuestion + vbYesNo + vbDefaultButton2, Caption) = vbNo Then
                chkStop.Value = vbUnchecked
            End If
        End If
    End If
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Sub DeleteRightGroup()
    Dim lngGroupID As Long, strSql As String
    
    lngGroupID = msgAuth.TextMatrix(msgAuth.Row, 4)
    strSql = "DELETE FROM RightGroupDetail WHERE lngRightGroupID=" & lngGroupID
    gclsBase.ExecSQL strSql
    strSql = "DELETE FROM RightGroup WHERE lngRightGroupID=" & lngGroupID
    gclsBase.ExecSQL strSql
End Sub

Private Sub cmdOK_Click(Index As Integer)
    Dim i As Integer, strGroupName As String
    
    If mblnIsExist Then Exit Sub
    Select Case Index
    Case 0
        If Not SaveCard Then
            Exit Sub
        Else
            Unload Me
        End If
    Case 1
        Unload Me
    Case 2
        If SaveCard Then
            mlngOpID = 0
            mblnIsNew = True
            mblnIsNext = True
            InitCard
'            SendKeys "%{N}"
        End If
    Case 3
        mblnSetActive = True
    Case 4
        strGroupName = Trim(cboRightGroup.Text)
        For i = 0 To cboRightGroup.ListCount - 1
            If cboRightGroup.list(i) = Trim(txtUser(3).Text) And cboRightGroup.list(i) <> strGroupName Then Exit For
        Next i
        If i < cboRightGroup.ListCount Then
            ShowMsg hwnd, "权限组名不允许重复！", vbExclamation, Caption
            txtUser(3).SetFocus
            txtUser(3).SelStart = 0
            txtUser(3).SelLength = Len(txtUser(3).Text)
            mblnGroupNameOK = False
        Else
            SaveRightGroup
            mblnGroupNameOK = True
            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
    Case 5
        If RightUsed(msgAuth.TextMatrix(msgAuth.Row, 4)) Then
            ShowMsg hwnd, "已经有其它操作员使用了权限组“" & Trim(txtUser(3).Text) _
                & "”，不能删除！", vbExclamation, Caption
            Exit Sub
        End If
        If ShowMsg(hwnd, "您确实要删除“" & cboRightGroup.Text & "”吗？", _
            vbQuestion + vbYesNo + vbDefaultButton2, Caption) = vbYes Then
            DeleteRightGroup
            InitRightGroupList
            InitRightTree
            cboRightGroup.Text = "  "
            txtUser(3).Text = ""
            cmdOK(5).Enabled = False
        End If
    End Select
End Sub

Private Function RightUsed(lngGroupID As Long) As Boolean
    Dim recRight As rdoResultset, strSql As String
    
    strSql = "SELECT * FROM OperatorRight WHERE lngRightGroupID=" & lngGroupID _
        & " AND lngOperatorID<>" & mlngOpID
    Set recRight = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    RightUsed = Not recRight.EOF
    recRight.Close
End Function

Private Sub InitList(ByVal lngOperatorID As Long)
    Dim recA As rdoResultset, strSql As String
    
    strSql = "SELECT lngAccountID,strAccountCode || ' ' || strAccountName AS strAccount FROM Account " _
        & "WHERE blnIsDetail=1 AND lngAccountID NOT IN (SELECT lngAccountID " _
        & "FROM OperatorAccount WHERE lngOperatorID=" & lngOperatorID & ") ORDER BY strAccountCode"
    Set recA = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    While Not recA.EOF
        lstA(0).AddItem recA("strAccount")
        lstA(0).ItemData(lstA(0).NewIndex) = recA("lngAccountID")
        recA.MoveNext
    Wend
    recA.Close
    
    strSql = "SELECT OperatorAccount.lngAccountID,Account.strAccountCode || ' ' " _
        & "|| Account.strAccountName AS strAccount FROM OperatorAccount,Account " _
        & "WHERE OperatorAccount.lngAccountID=Account.lngAccountID " _
        & "AND lngOperatorID=" & lngOperatorID & " ORDER BY strAccountCode"
    Set recA = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    While Not recA.EOF
        lstA(1).AddItem recA("strAccount")
        lstA(1).ItemData(lstA(1).NewIndex) = recA("lngAccountID")
        recA.MoveNext
    Wend
    recA.Close
End Sub

Private Sub SetForm(ByVal intVersion As Integer)
    Dim lngRowheight As Long
    If intVersion = 1 Then
        Me.Height = 7152
        msgAuth.Height = 4665
        tvwRight.Height = 3696
        sstRight.Height = 5244
        cmdOK(4).top = 4728
        cmdOK(5).top = 4728
        chkStop.top = 6420
        cmdOK(3).Visible = False
        cmdOK(3).TabStop = False
        Frame1.Height = 4632
        lstA(0).Height = 3828
        lstA(1).Height = 3828
        cmdSel(0).top = 1740
        cmdSel(1).top = 2112
        cmdSel(2).top = 2484
        cmdSel(3).top = 2856
    ElseIf intVersion = 8 Then
        Me.Height = 4596
        msgAuth.Height = 2660
        tvwRight.Height = 1485
        cmdOK(4).top = 3630
        cmdOK(5).top = 3630
        chkStop.top = 3870
        cmdOK(3).Visible = False
        cmdOK(3).TabStop = False
    ElseIf intVersion = 16 Then
        cmdOK(3).Visible = False
        cmdOK(3).TabStop = False
        #If conHos = 1 Then
            Me.Height = 5715
            msgAuth.Height = 3225
            tvwRight.Height = 2325
            cmdOK(4).top = 3330
            cmdOK(5).top = 3330
            chkStop.top = 4710
            sstRight.Height = 3825
            If gclsBase.Trade = "基本医疗保险基金" Then
                lngRowheight = msgAuth.RowHeight(1)
            End If
        #End If
    End If
    
    If gclsBase.AccountSys = "1" And gclsBase.Trade = "邮电通信" Then
        lngRowheight = msgAuth.RowHeight(1)
    End If
    If lngRowheight > 0 Then
        Me.Height = Me.Height + lngRowheight
        sstRight.Height = sstRight.Height + lngRowheight
        msgAuth.Height = msgAuth.Height + lngRowheight
        tvwRight.Height = tvwRight.Height + lngRowheight
        chkStop.top = chkStop.top + lngRowheight
        cmdOK(4).top = cmdOK(4).top + lngRowheight
        cmdOK(5).top = cmdOK(5).top + lngRowheight
    End If
End Sub

Private Sub cmdSel_Click(Index As Integer)
    Dim i As Integer
    Dim list As Integer
    
    Select Case Index
    Case 0
        i = lstA(0).ListIndex
        If i = -1 Then Exit Sub
        lstA(1).AddItem lstA(0).list(i)
        lstA(1).ItemData(lstA(1).NewIndex) = lstA(0).ItemData(i)
        lstA(0).RemoveItem i
        mblnIsChanged = True
        lstA(1).ListIndex = lstA(1).NewIndex
        mblnIsChanged = False
        If lstA(0).ListCount > 0 Then
           mblnIsChanged = True
           If i < lstA(0).ListCount Then
                lstA(0).ListIndex = i
            Else
                lstA(0).ListIndex = lstA(0).ListCount - 1
            End If
           mblnIsChanged = False
        Else
           lstA(1).SetFocus
        End If
    Case 1
        For i = 0 To lstA(0).ListCount - 1
            lstA(1).AddItem lstA(0).list(i)
            lstA(1).ItemData(lstA(1).NewIndex) = lstA(0).ItemData(i)
        Next
        lstA(0).Clear
        mblnIsChanged = True
        lstA(1).ListIndex = 0
        mblnIsChanged = False
    Case 2
        i = lstA(1).ListIndex
        If i = -1 Then Exit Sub
        If lstA(1).ListCount < 1 Then Exit Sub
        lstA(0).AddItem lstA(1).list(i)
        lstA(0).ItemData(lstA(0).NewIndex) = lstA(1).ItemData(i)
        lstA(1).RemoveItem i
        If lstA(1).ListCount > 0 Then
            mblnIsChanged = True
           If i < lstA(1).ListCount Then
                lstA(1).ListIndex = i
            Else
                lstA(1).ListIndex = lstA(1).ListCount - 1
            End If
            mblnIsChanged = False
        End If
        mblnIsChanged = True
        lstA(0).ListIndex = lstA(0).NewIndex
        mblnIsChanged = False
    Case 3
        list = lstA(1).ListCount
        For i = (list - 1) To 0 Step -1
            lstA(0).AddItem lstA(1).list(i)
            lstA(0).ItemData(lstA(0).NewIndex) = lstA(1).ItemData(i)
            lstA(1).RemoveItem i
        Next
    End Select
    RefreshButton
End Sub

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyEscape Or KeyCode = vbKeyReturn Then
        mblnIsRefer = refOperatorGroup.ReferVisible
    End If
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn And Me.ActiveControl.Name <> "cboRightGroup" Then
        If Not mblnIsRefer Then
            BKKEY Me.ActiveControl.hwnd, vbKeyTab
        End If
    ElseIf KeyAscii = vbKeyEscape Then
        cmdOK(1).Value = Not mblnIsRefer
    End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn And Shift = 2 Then
        cmdOK(0).Value = True
    End If
End Sub

Private Sub Form_Load()