frmsalarylist.frm

金算盘软件代码

    End If
    mclsGrid.ColSort(2) = True
    mclsGrid.ColSort(3) = True
    mclsGrid.ColSort(4) = True
    mclsGrid.ColSort(5) = True
    mclsGrid.Sort mlngSortCol, mintSortType
End Sub
'两个GRID之间的行抽出和加入
Public Sub DbClickList(objFromGrid As Object, objToGrid As Object, intIDCol As Integer, intCols As Integer, intStartRow As Integer) '双击列表处理
    '来源Grid，目的Grid，ID列，列数,起始行
    Dim i As Integer
    Dim strItemName As String
    Dim strItemType As String
    Dim strItemlong As String
    Dim strItemDec As String
    Dim lngItemID As Long
    Dim j As Integer
    Dim ItemText() As String
    ReDim ItemText(intCols)
    lngItemID = 0
    With objFromGrid '抽出可选项目列表中的数据行
        i = .Row
        For j = 0 To intCols - 1
            ItemText(j) = .TextMatrix(i, j)
        Next j
        If Trim(.TextMatrix(i, intIDCol)) <> "" Then
            lngItemID = .TextMatrix(i, intIDCol)
        End If
        Do While .Rows > i
            If i + 1 < .Rows Then
                For j = 0 To intCols - 1
                    .TextMatrix(i, j) = .TextMatrix(i + 1, j)
                Next j
            Else
                For j = 0 To intCols - 1
                    .TextMatrix(i, j) = ""
                Next j
                Exit Do
            End If
            i = i + 1
        Loop
        If .Rows > intStartRow + 1 Then
            .Rows = .Rows - 1
            .ColSel = .Cols - 1
        End If
    End With
    If lngItemID <> 0 Then  '添加到目的列表
        With objToGrid
            If .TextMatrix(.Rows - 1, 0) <> "" Then '新增一行
                .AddItem ("")
            End If
            i = .Rows - 1
            For j = 0 To intCols - 1
                .TextMatrix(i, j) = ItemText(j)
            Next j
            .Row = .Rows - 1
            .ColSel = .Cols - 1
        End With
    End If
End Sub
'一个GRID行之间的上下移动
Public Sub ChangList(bolIsNext As Boolean, objGrid As Object, intCols As Integer)
    '是否向下移动，目标Grid，总列数
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim lngItemID As Long
    ReDim strFieldName(intCols + 1) As String
    Dim bolCan As Boolean  '能否移动标志
    lngItemID = 0
    bolCan = False
    With objGrid
        i = .Row
        '判断是否属于移动范围
        If (i < .Rows - 1 And bolIsNext) Or (i > .FixedRows And i < .Rows And Not bolIsNext) Then
            If bolIsNext Then
                If Trim(.TextMatrix(i + 1, 0)) <> "" Then
                    bolCan = True
                End If
            End If
            If Not bolIsNext Then
                If Trim(.TextMatrix(i - 1, 0)) <> "" Then
                    bolCan = True
                End If
            End If
            If bolCan Then
                 For k = 0 To intCols Step 1
                     strFieldName(k) = .TextMatrix(i, k)
                 Next k
                 If bolIsNext = True Then
                     j = i + 1
                 Else
                     j = i - 1
                 End If
                 For k = 0 To intCols Step 1
                    .TextMatrix(i, k) = .TextMatrix(j, k)
                    .TextMatrix(j, k) = strFieldName(k)
                 Next k
                 .Row = j
                 If .Row < .TopRow Then
                    .TopRow = .Row
                 End If
                 If .Row > .TopRow + .Height / .RowHeight(0) - 1 Then
                    .TopRow = .TopRow + 1
                 End If
            End If
        End If
    End With
End Sub
Public Function select_text(ByVal txtSelText, ByVal lngSelStart, ByVal lngSelLength, txtText, _
 txtSelectCaption As String) As String '公式函数
    Dim txtTextCopy, txtTextLeft, txtTextRight As String
    Dim lngSelText As Long
    txtTextCopy = lngSelText
    txtTextLeft = Left(txtText, lngSelStart)
    txtTextRight = Right(txtText, Len(txtText) - lngSelStart - lngSelLength)
    select_text = txtTextLeft + " " + txtSelectCaption + " " + txtTextRight
End Function
Private Sub cboFind_Click()
    Dim i As Integer
    Dim intRow As Integer
    Dim intSortCol As Integer
    
    With msgSalaryList
    intRow = .Row
        For i = 0 To .Cols - 1 Step 1
            If InStr(Trim(.TextMatrix(0, i)), Trim(cboFind.Text)) = 1 Then
                mlngFindCol = i
                Exit For
            End If
        Next i
        If i = .Cols Then
            Exit Sub
        End If
        For i = 2 To .Cols - 1
            If Right(.TextMatrix(0, i), 1) = "↑" Or Right(.TextMatrix(0, i), 1) = "↓" Then
                intSortCol = i
                Exit For
            End If
        Next i
        If intSortCol = mlngFindCol Then
            If mclsGrid.SortedType = 1 Then
                mclsGrid.ColSort(mlngFindCol) = True
                mclsGrid.Sort mlngFindCol, 2
            Else
                mclsGrid.ColSort(mlngFindCol) = True
                mclsGrid.Sort mlngFindCol, 1
            End If
        Else
            mclsGrid.ColSort(mlngFindCol) = True
            mclsGrid.Sort mlngFindCol, 1   '升序
        End If
        If cboFind.ListIndex > -1 Then
            If .Rows > 1 Then
                txtFindValue.Text = .TextMatrix(.Row, mlngFindCol)
            Else
                txtFindValue.Text = ""
            End If
        End If
        .Row = intRow
    End With
End Sub
Private Sub cmdFind_Click()
    Dim i As Integer
    Dim strFindText As String
    Dim lngOldRow As Long
    If cboFind.ListIndex > -1 Then
        With msgSalaryList
            i = .Row
            lngOldRow = .Row
            '查找行
            If txtFindValue.SelLength > 0 Then
                strFindText = Left(txtFindValue.Text, txtFindValue.SelLength)
            Else
                strFindText = txtFindValue.Text
            End If
            If InStr(strFindText, mstrFindText) = 1 Then
                strFindText = mstrFindText
            End If
            Do While i < .Rows - 1
                i = i + 1
                If InStr(Trim(.TextMatrix(i, mlngFindCol)), strFindText) = 1 Then
                    .Row = i
                    .col = 0
                    .ColSel = 5
                    Exit Do
                End If
            Loop
            txtFindValue.SetFocus
            txtFindValue.SelStart = Len(strFindText)
            txtFindValue.SelLength = Len(txtFindValue.Text) - Len(strFindText)
            mstrFindText = strFindText
            '不能再找
            If .Row = lngOldRow Then
                cmdFind.Enabled = False
            Else
                cmdFind.Enabled = True
            End If
        End With
    End If
End Sub
Private Sub cmdWork_Click(Index As Integer)
    Dim x, y As Single
    '激活菜单
    x = cmdWork(Index).Left
    y = cmdWork(Index).top + cmdWork(Index).Height
    Call CreateMenu
    Call RefreshMenu
    Select Case Index
    Case 0
        PopupMenu frmMain.mnuListEdit, , x, y
    Case 1
        PopupMenu frmMain.mnuListReport, , x, y
    End Select
End Sub
Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
    If Me.Left + Me.width < 0 Or Me.Left > Screen.width Then
        Me.Left = 300
    End If
    gclsSys.CurrFormName = Me.hWnd
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyEscape Then
        If Me.SalaryInput = True Then
            ShowMsg Me.hWnd, "请先关闭工资表数据录入窗体。", vbInformation, Me.Caption
            frmSalaryEdit.ZOrder 0
            Exit Sub
        End If
        Unload Me
    End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim x As Long
    Dim y As Long
    
    If Not frmMain.ActiveForm Is Me Then Exit Sub
    If KeyCode = 93 Then
        '鼠标右键
        Call CreateMenu
        Call RefreshMenu
        With msgSalaryList
            x = .Left + .width \ 2
            y = .top + .Height \ 3
        End With
        If msgSalaryList.Rows > 1 Then
            If msgSalaryList.Row = 0 Then
                msgSalaryList.Row = 1
            End If
            msgSalaryList.RowSel = msgSalaryList.Row
        End If
        PopupMenu frmMain.mnuListEdit, , x, y
    End If
End Sub
Private Sub Form_Load()
    '打开上机日志
    Set grecLog = gclsBase.BaseDB.OpenResultset("SELECT * FROM Log", rdOpenDynamic, rdConcurValues)
    Set mSalaryListMenu = gclsSys.MainControls.Add(Me)
'    Me.width = 7650
'    Me.Height = 4500
    mlngSalaryID = 0
    mintSalaryListViewID = 62  '工资目录表ID
    mintSalaryViewID = 63  '工资表视图号
    Set mclsGrid = New Grid
    Set mclsGrid.Grid = msgSalaryList
     '判断操作员权限
    SetOpertarRight
    'Salary.WriteSalaryLogRecordset
'    mclsGrid.ListSet.ViewId = mintSalaryListViewID
'    Call JionGrid
'    mclsGrid.Sort 2, 1  '排序
'    If msgSalaryList.Rows > 1 Then
'        msgSalaryList.Row = 1
'        cmdFind.Visible = True
'    End If
'    Call CreateMenu
'    cboFind.Text = "工资表名称"
'    mlngFindCol = 2
'    If msgSalaryList.Rows > 1 Then
'        txtFindValue.Text = msgSalaryList.TextMatrix(1, 2)
'    Else
'        txtFindValue.Text = ""
'    End If
'
'    If msgSalaryList.Rows > 1 Then
'        msgSalaryList.ColSel = msgSalaryList.Cols - 1
'    End If
'    cmdFind.Enabled = True
    mblnSalaryInput = False
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If UnloadMode = vbFormControlMenu Then
        If Me.SalaryInput = True Then
            ShowMsg Me.hWnd, "请先关闭工资表数据录入窗体。", vbInformation, Me.Caption
            Cancel = 1
            frmSalaryEdit.ZOrder 0
            Exit Sub
        End If
    End If
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    If Me.WindowState <> 1 Then
        If Me.Height < 3000 Then
            Me.Height = 3000
            msgSalaryList.Height = 1500
        End If
        msgSalaryList.Height = Me.Height - 1500
        cmdWork(0).top = Me.Height - 800
        cmdWork(1).top = Me.Height - 800
        If Me.width < 6350 Then
            Me.width = 6350
        End If
        msgSalaryList.width = Me.width - 250
        txtFindValue.width = Me.width - 3865
        cmdFind.Left = Me.width - cmdFind.width - 200
    End If
End Sub
Private Sub mnuDel()
    Dim intMsg As Integer
    Dim strMsg As String
    Dim strSql As String
    Dim i As Integer
    Dim lngSalaryListID As Long
    Dim lngListID  As Long
    Dim recRecordset As rdoResultset
    Dim recListSet As rdoResultset
    Dim recZ As rdoResultset
    
    If Not Salary.VolidSalaryOpIsEnable(4) Then Exit Sub
    With msgSalaryList
        If .TextMatrix(.Row, 0) <> "" And .Rows > 1 Then
            strMsg = Trim(msgSalaryList.TextMatrix(msgSalaryList.Row, 2))
            strMsg = "真的要删除" + strMsg + "的数据？"
            intMsg = ShowMsg(Me.hWnd, strMsg, vbOKCancel + vbQuestion + vbDefaultButton2, Me.Caption)
            If intMsg = 1 Then
                strMsg = Trim(msgSalaryList.TextMatrix(msgSalaryList.Row, 2))
                strMsg = strMsg + "的数据将永久性丢失！"
                intMsg = ShowMsg(Me.hWnd, strMsg, vbOKCancel + vbQuestion + vbDefaultButton2, "工资发放")
                If intMsg = 1 Then
                    'zj
                    
                    On Error GoTo Errors1
                    Me.MousePointer = vbHourglass
                    gclsBase.BaseWorkSpace.BeginTrans
                    '删除工资数据
                    strSql = "DELETE FROM Salary WHERE lngSalaryListID=" & .TextMatrix(.Row, 0)
                    gclsBase.BaseDB.Execute strSql
                    '删除工资目录表
                    strSql = "DELETE FROM SalaryList WHERE lngSalaryListID=" & .TextMatrix(.Row, 0)
                    gclsBase.BaseDB.Execute strSql
                    '删除工资项目表
                    strSql = "DELETE FROM SalaryField WHERE lngSalaryListID=" & .TextMatrix(.Row, 0)
                    gclsBase.BaseDB.Execute strSql
                    '删除工资公式表
                    strSql = "DELETE FROM SalaryFormula WHERE lngSalaryListID=" & .TextMatrix(.Row, 0)
                    gclsBase.BaseDB.Execute strSql
                    gclsBase.BaseWorkSpace.CommitTrans