frmsalarylistset.frm

金算盘软件代码

            If .TextMatrix(.Row, 2) = 1 Then
                ShowMsg Me.hwnd, "固定栏目不允许取消。", vbInformation, Me.Caption
                Exit Sub
            End If
        End With
        Call frmSalaryList.DbClickList(frmSalaryListSet.msgGrid(1), frmSalaryListSet.msgGrid(0), 0, 3, 0)
    Case 0
        Call frmSalaryList.DbClickList(frmSalaryListSet.msgGrid(0), frmSalaryListSet.msgGrid(1), 0, 3, 0)
    End Select
    With msgGrid(Index)
        If .TextMatrix(.Row, 1) = "" And .Rows > 1 Then
            .Rows = .Rows - 1
        End If
    End With
    Call InitCmdButton
End Sub
Private Sub msgGrid_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    With msgGrid(0)
        If Len(Trim(.TextMatrix(0, 1))) = 0 Then
            .HighLight = flexHighlightNever
        End If
    End With
End Sub

Private Sub msgGrid_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    With msgGrid(Index)
        If .RowSel <> .Row Then
            .RowSel = .Row
        End If
    End With
    With msgGrid(0)
        If Len(Trim(.TextMatrix(0, 1))) = 0 Then
            .HighLight = flexHighlightAlways
        End If
    End With
End Sub
'右移一个
Private Sub Right_One()
    Call frmSalaryList.DbClickList(frmSalaryListSet.msgGrid(0), frmSalaryListSet.msgGrid(1), 0, 3, 0)
    If msgGrid(0).Rows = 1 Then
        Call InitCmdButton
    End If
End Sub
'左移全部
Private Sub Left_All()
    Dim i As Integer
    With msgGrid(1)
        i = .Rows - 1
        Do While i > 0
            .Row = i
            If .TextMatrix(.Row, 2) = 0 Then
                Call frmSalaryList.DbClickList(frmSalaryListSet.msgGrid(1), frmSalaryListSet.msgGrid(0), 0, 3, 0)
            End If
            i = i - 1
        Loop
        .Row = 0
        If .TextMatrix(.Row, 2) = 0 Then
            Call cmdCheck_Click(2)
        End If
        .ColSel = 2
    End With
End Sub
'左移一个
Private Sub Left_One()
    With msgGrid(1)
        If .TextMatrix(.Row, 2) = 1 Then
            ShowMsg Me.hwnd, "固定栏目不允许取消。", vbInformation, Me.Caption
            Exit Sub
        End If
        Call frmSalaryList.DbClickList(frmSalaryListSet.msgGrid(1), frmSalaryListSet.msgGrid(0), 0, 3, 0)
        If .TextMatrix(.Row, 1) = "" And .Rows > 1 Then
            .Rows = .Rows - 1
        End If
    End With
End Sub
'右移全部
Private Sub Right_All()
    Dim i As Integer
    With msgGrid(0)
        i = .Rows
        Do While i > 0
            .Row = .Rows - 1
            Call frmSalaryList.DbClickList(frmSalaryListSet.msgGrid(0), frmSalaryListSet.msgGrid(1), 0, 3, 0)
            i = i - 1
        Loop
        .Row = 0
        Call cmdCheck_Click(0)
        .Rows = 1
        If .TextMatrix(.Row, 1) = "" And .Rows > 1 Then
            .Rows = .Rows - 1
        End If
    End With
End Sub
'设置按扭
Private Sub InitCmdButton()
    If msgGrid(0).Rows = 1 And Trim(msgGrid(0).TextMatrix(0, 0)) = "" Then
        cmdCheck(0).Enabled = False
        cmdCheck(1).Enabled = False
        msgGrid(0).ColSel = 0
    Else
        cmdCheck(0).Enabled = True
        cmdCheck(1).Enabled = True
        msgGrid(0).ColSel = 2
    End If
    If msgGrid(1).Row < 4 Then
        cmdCheck(2).Enabled = False
    Else
        cmdCheck(2).Enabled = True
    End If
    If msgGrid(1).Rows < 5 Then
        cmdCheck(3).Enabled = False
    Else
        cmdCheck(3).Enabled = True
    End If
    If msgGrid(1).Row = 0 Then
        cmdCheck(4).Enabled = False
    Else
        If msgGrid(1).Row = 4 Then
            cmdCheck(4).Enabled = False
        Else
            cmdCheck(4).Enabled = True
        End If
    End If
    If msgGrid(1).Row = msgGrid(1).Rows - 1 Then
        cmdCheck(5).Enabled = False
    Else
        If msgGrid(1).Row = 3 Then
            cmdCheck(5).Enabled = False
        Else
            cmdCheck(5).Enabled = True
        End If
    End If
    If Trim(cboInputItem.Text) = "所有栏目" Then
        cmdOK(2).Enabled = False
    Else
        cmdOK(2).Enabled = True
    End If
    
End Sub
Private Sub msgGrid_RowColChange(Index As Integer)
    Call InitCmdButton
    If msgGrid(Index).CellTop + msgGrid(Index).RowHeight(0) + 50 > msgGrid(Index).Height Then
        msgGrid(Index).TopRow = msgGrid(Index).TopRow + 1
    End If
    If msgGrid(Index).TopRow > msgGrid(Index).Row Then
        msgGrid(Index).TopRow = msgGrid(Index).Row
    End If
End Sub
'根据名称取得listID
Private Function GetItemListIndex(ByVal strName As String, ByRef lngListID As Long) As Long
    Dim i As Long
    Dim strSql As String
    Dim recList As rdoResultset
    GetItemListIndex = 0
    With cboInputItem
        For i = 0 To .ListCount - 1
            If .list(i) = strName Then
                GetItemListIndex = i
                Exit For
            End If
        Next i
    End With
    If GetItemListIndex > 0 Then
        strSql = "SELECT lngListID FROM List WHERE lngViewID=" & mintSalaryViewID _
            & " AND strListName = '" & strName & "'"
        Set recList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recList.EOF Then
            lngListID = recList!lngListID
        Else
            lngListID = 0
        End If
        recList.Close
        Set recList = Nothing
    End If
End Function
'删除设置
Private Sub DelListSet(ByRef lngListID As Long)
    Dim strSql As String
    Dim recList As rdoResultset
    
    If Trim(cboInputItem.Text) = Trim(mstrListName) Then
        frmSalaryEdit.ListName = ""
    End If
    cboInputItem.ListIndex = 0
    On Error GoTo Errors
    gclsBase.BaseWorkSpace.BeginTrans
    strSql = "SELECT SalaryListSet.lngSalaryListID, SalaryListSet.lngListID FROM SalaryListSet " & _
             " WHERE SalaryListSet.lngListID = " & lngListID
    Set recList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recList.EOF Then
        recList.MoveLast
        recList.MoveFirst
        If recList.RowCount > 1 Then
            'strSql = "DELETE SalaryListSet.* FROM SalaryListSet WHERE SalaryListSet.lngListID = " & lngListID & _
                     " AND SalaryListSet.lngSalaryListID = " & mlngSalarylistID
            strSql = "DELETE  FROM SalaryListSet WHERE SalaryListSet.lngListID = " & lngListID & _
                     " AND SalaryListSet.lngSalaryListID = " & mlngSalarylistID
            gclsBase.BaseDB.Execute strSql
            lngListID = 0
        Else
            'strSql = "DELETE SalaryListSet.* FROM SalaryListSet WHERE SalaryListSet.lngListID = " & lngListID & _
                     " AND SalaryListSet.lngSalaryListID = " & mlngSalarylistID
            strSql = "DELETE FROM SalaryListSet WHERE SalaryListSet.lngListID = " & lngListID & _
                     " AND SalaryListSet.lngSalaryListID = " & mlngSalarylistID
            gclsBase.BaseDB.Execute strSql
            'strSql = "DELETE List.* FROM List WHERE lngListID=" & lngListID
            strSql = "DELETE FROM List WHERE lngListID=" & lngListID
            gclsBase.BaseDB.Execute strSql
            'strSql = "DELETE ListField.* FROM ListField WHERE ListField.lngListID=" & lngListID
            strSql = "DELETE FROM ListField WHERE ListField.lngListID=" & lngListID
            gclsBase.BaseDB.Execute strSql
            lngListID = 0
        End If
    Else
        'strSql = "DELETE List.* FROM List WHERE lngListID=" & lngListID
        strSql = "DELETE FROM List WHERE lngListID=" & lngListID
        gclsBase.BaseDB.Execute strSql
        'strSql = "DELETE ListField.* FROM ListField WHERE ListField.lngListID=" & lngListID
        strSql = "DELETE FROM ListField WHERE ListField.lngListID=" & lngListID
        gclsBase.BaseDB.Execute strSql
        lngListID = 0
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    Exit Sub
Errors:
    gclsBase.BaseWorkSpace.RollBacktrans
End Sub
'录入栏目设置被始化
Private Sub InitInputItem()
    Dim strSql As String
    'Dim recList As Recordset
    Dim recList As rdoResultset
    Dim i As Integer
    Dim strListName As String
    
    cboInputItem.Clear
    cboInputItem.AddItem ("所有栏目")
    '对固定栏目的初始化
    'strSql = "UPDATE  ListField INNER JOIN ViewField ON ListField.lngViewFieldID = ViewField.lngViewFieldID " & _
             " SET  ListField.blnIsChoosed =True " & _
             " WHere ViewField.lngViewID= 63 And ViewField.blnIsFixed=true "
    strSql = "UPDATE  ListField SET  ListField.blnIsChoosed =1 " & _
             " WHERE  ListField.lngViewFieldID IN (SELECT ViewField.lngViewFieldID " & _
             " FROM ViewField WHERE ViewField.lngViewID= 63 And ViewField.blnIsFixed=1) "
    gclsBase.BaseDB.Execute strSql
    'strSql = "SELECT SalaryListSet.lngSalaryListID, List.lngListID,List.lngOperatorID, " & _
             " List.strListName, List.lngViewID " & _
             " FROM List INNER JOIN SalaryListSet ON List.lngListID = SalaryListSet.lngListID " & _
             " WHERE List.lngViewID = " & mintSalaryViewID & " AND List.lngOperatorID=0 " & _
             " AND SalaryListSet.lngSalaryListID = " & mlngSalarylistID
    'Set recList = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
    strSql = "SELECT SalaryListSet.lngSalaryListID, List.lngListID,List.lngOperatorID, " & _
             " List.strListName, List.lngViewID FROM List,SalaryListSet " & _
             " WHERE List.lngListID = SalaryListSet.lngListID " & _
             " AND List.lngViewID = " & mintSalaryViewID & " AND List.lngOperatorID=0 " & _
             " AND SalaryListSet.lngSalaryListID = " & mlngSalarylistID
    Set recList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With recList
        If Not .EOF Then
            .MoveLast
            .MoveFirst
            For i = 0 To .RowCount - 1
                strListName = !strListName
                If Trim(strListName) <> "" Then
                    Salary.CboAddSubjectItem cboInputItem, strListName
                End If
                .MoveNext
            Next
        End If
    End With
    cboInputItem.ListIndex = GetItemListIndex(frmSalaryEdit.ListName, mlngListID)
    If mlngListID <> 0 Then
        txtListName.Text = frmSalaryEdit.ListName
        cmdOK(2).Enabled = True
    Else
        txtListName.Text = ""
        cmdOK(2).Enabled = False
    End If
    recList.Close
    Set recList = Nothing
End Sub
'保存设置
Private Sub SaveListSet()
    '校验栏目名称
    Dim strSql As String
    Dim recList As rdoResultset
    Dim strMsg As String
    
    With msgGrid(1)
        If .Rows < 5 Then
            ShowMsg Me.hwnd, "录入栏目至少为1个。", vbInformation, Me.Caption
            Exit Sub
        End If
    End With
    If Trim(txtListName.Text) = "" Then
        ShowMsg Me.hwnd, "栏目名称不能为空。", vbInformation, Me.Caption
        txtListName.SetFocus
        Exit Sub
    End If
    If ContainErrorChar(txtListName.Text, """") Or ContainErrorChar(txtListName.Text, "'") Or ContainErrorChar(txtListName.Text, "|") Then
        ShowMsg Me.hwnd, "栏目名称不能包含：“" & """" & ",',|”", vbInformation, Me.Caption
        txtListName.SetFocus
        Exit Sub
    End If
    If Trim(txtListName.Text) = "所有栏目" Then
        ShowMsg Me.hwnd, "栏目名称不能为所有栏目。", vbInformation, Me.Caption
        txtListName.SetFocus
        Exit Sub
    End If
    If StrLen(Trim(txtListName.Text)) > 30 Then
        ShowMsg Me.hwnd, "栏目名称不能超过30个字符。", vbInformation, Me.Caption
        txtListName.SetFocus
        Exit Sub
    End If
    '取出工资表的List
    '判断是否重名
    'strSql = "SELECT SalaryListSet.lngSalaryListID, List.lngListID, List.lngOperatorID, " & _
             " List.strListName, List.lngViewID,  SalaryList.strSalaryListName " & _
             " FROM (List INNER JOIN SalaryListSet ON List.lngListID = SalaryListSet.lngListID) " & _
             " INNER JOIN SalaryList ON SalaryListSet.lngSalaryListID = SalaryList.lngSalaryListID " & _
             " WHERE List.lngViewID = " & mintSalaryViewID & _
             " AND List.strListName ='" & Trim(txtListName.Text) & "'"
    strSql = "SELECT SalaryListSet.lngSalaryListID, List.lngListID, List.lngOperatorID, " & _
             " List.strListName, List.lngViewID,  SalaryList.strSalaryListName " & _
             " FROM List,SalaryListSet,SalaryList " & _
             " WHERE List.lngListID = SalaryListSet.lngListID " & _
             " AND SalaryListSet.lngSalaryListID = SalaryList.lngSalaryListID " & _
             " AND List.lngViewID = " & mintSalaryViewID & _
             " AND List.strListName ='" & Trim(txtListName.Text) & "'"
    Set recList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recList.EOF Then
        mlngListID = frmSalaryEdit.ListID
    End If
    FinishSet (False)
    recList.Close
    Set recList = Nothing
End Sub
Public Function ShowSalarylistset() As Boolean
    Me.Hide
    '栏目设置初始化
    Call InitInputItem
    '设置按钮
    Call InitCmdButton
    Me.Show vbModal
    ShowSalarylistset = mblnOk
End Function