frmsalarycardnew.frm

金算盘软件代码

                            txtCard(1).Text = .TextMatrix(.Row, 3)
                        '数据长度不变
                        ElseIf Val(txtCard(0).Text) = Val(.TextMatrix(.Row, 2)) Then
                            '小数位数不能改变
                            If Val(txtCard(1).Text) <> Val(.TextMatrix(.Row, 3)) Then
                                txtCard(1).Text = .TextMatrix(.Row, 3)
                            End If
                        '数据长度增大
                        Else
                            '小数位数不能减小
                            If Val(txtCard(1).Text) < Val(.TextMatrix(.Row, 3)) Then
                                txtCard(1).Text = .TextMatrix(.Row, 3)
                            '数据长度增大，小数位数不变
                            ElseIf Val(txtCard(1).Text) = Val(.TextMatrix(.Row, 3)) Then
                                Call EditType
                                SalaryItemEdit = True
                                gclsBase.BaseWorkSpace.CommitTrans
                                Exit Function
                            '小数位数增大
                            Else
                                '小数位数的增加位数不超出数据长度的增加位数
                                If Val(txtCard(1).Text) - Val(.TextMatrix(.Row, 3)) <= Val(txtCard(0).Text) - Val(.TextMatrix(.Row, 2)) Then
                                    Call EditType
                                    SalaryItemEdit = True
                                    gclsBase.BaseWorkSpace.CommitTrans
                                    Exit Function
                                Else
                                    txtCard(0).Text = .TextMatrix(.Row, 2)
                                    txtCard(1).Text = .TextMatrix(.Row, 3)
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End With
        '工资表的文本型字段(工资表有数据长度不能变小，工资表有数据长度可以改变，已经使用的长度不能变小）
        If cboEditItem(1).Text = "文本" And UCase(recRecordset!strTableName) = "SALARY" Then
            With frmSalaryListNewWizard.msgWizard(1)
                strSql = "Select LngSalaryListId From Salary "
                Set recZ = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                If recZ.EOF Then
                    Call FieldSize(strFieldName, Val(txtCard(0).Text), lngViewFieldID)
                Else
                    If txtCard(0).Text <= .TextMatrix(.Row, 2) Then
                        txtCard(0).Text = .TextMatrix(.Row, 2)
                    Else
                        Call FieldSize(strFieldName, Val(txtCard(0).Text), lngViewFieldID)
                    End If
                End If
                recZ.Close
                Set recZ = Nothing
            End With
        End If
        strSql = "UPDATE ViewField SET strViewFieldDesc='" & Trim(cboEditItem(0).Text) & "',strFieldType='" _
        & IIf((cboEditItem(1).Text = "文本"), "String", IIf(cboEditItem(1).Text = "日期", "Date", "Double")) _
        & "',bytFieldSize=" & txtCard(0).Text & ",bytFieldDec=" & txtCard(1).Text _
        & " WHERE lngViewFieldID=" & lngViewFieldID
        gclsBase.BaseDB.Execute strSql
        '修改筛选视图(视图ID为72)
        strSql = "UPDATE ViewField SET strViewFieldDesc='" & Trim(cboEditItem(0).Text) _
            & "' Where strFieldName='SalarySql.Sa" & lngViewFieldID & "'" & " AND lngViewID=72"
        gclsBase.BaseDB.Execute strSql
        With frmSalaryListNewWizard.msgWizard(1) '到发放列表
            .TextMatrix(.Row, 0) = cboEditItem(0).Text
            .TextMatrix(.Row, 1) = cboEditItem(1).Text
            .TextMatrix(.Row, 2) = txtCard(0).Text
            .TextMatrix(.Row, 3) = String(4 - Len(Trim(txtCard(1).Text)), " ") & Trim(txtCard(1).Text)
            .col = 0
            .ColSel = 4
        End With
        Salary.ResetSalaryQuery
        SalaryItemEdit = True
        gclsBase.BaseWorkSpace.CommitTrans
    End If
    recRecordset.Close
    Set recRecordset = Nothing
    Exit Function
Errorss:
    gclsBase.BaseWorkSpace.RollBacktrans
    ShowMsg Me.hWnd, "修改工资项目出错，不能修改工资项目。", vbInformation, Me.Caption
End Function
'校验录入是否正确
Private Function CheckOK() As Boolean
    Dim strSql As String
    Dim recRecordset As rdoResultset
    Dim recZ As rdoResultset
    Dim lngViewFieldID As Long
    Dim strTmp As String
    
    '项目类型
    Dim strItemType As String
    cboEditItem(0).Text = Left(Trim(cboEditItem(0).Text), 28)
    If Val(txtCard(0).Text) > 250 Then
        txtCard(0).Text = 250
    End If
    CheckOK = False
    cboEditItem(0).Text = Salary.Change_Text("|", "", cboEditItem(0).Text)
    cboEditItem(0).Text = Salary.Change_Text(".", "", cboEditItem(0).Text)
    cboEditItem(0).Text = Salary.Change_Text("[", "", cboEditItem(0).Text)
    cboEditItem(0).Text = Salary.Change_Text("]", "", cboEditItem(0).Text)
    '校验录入名称是否正确
    If Trim(cboEditItem(0).Text) = "" Then
        ShowMsg Me.hWnd, "项目名称不能为空。", vbExclamation, Me.Caption
        cboEditItem(0).SetFocus
        Exit Function
    End If
    '校验字段名称是否为SQL保留字
    If Not Check_Name_Sql(cboEditItem(0).Text) Then
        ShowMsg Me.hWnd, "工资项目名称非法，请重新输入。", vbInformation, Me.Caption
        Exit Function
    End If
    '校验字段名称是否为日期保留字
    strTmp = UCase(Trim(cboEditItem(0).Text))
    If InStr(strTmp, "YEAR") > 0 Or InStr(strTmp, "MONTH") > 0 Or InStr(strTmp, "DAY") > 0 Then
        ShowMsg Me.hWnd, "工资项目名称非法，请重新输入。", vbInformation, Me.Caption
        Exit Function
    End If
    If IsNumeric(cboEditItem(0).Text) Then
        ShowMsg Me.hWnd, "项目名称不能为数字。", vbExclamation, Me.Caption
        cboEditItem(0).SetFocus
        Exit Function
    End If
    With frmSalaryListNewWizard.msgWizard(1)
        lngViewFieldID = Val(.TextMatrix(.Row, 4))
        strItemType = Trim(.TextMatrix(.Row, 1))
    End With
    '判断名称是否重复
    If mintEditItem = 0 Then   '修改时
        'Strsql = "SELECT lngViewID FROM ViewField WHERE lngViewID=" & mintSalaryViewID _
            & " AND lngViewFieldID<>" & lngViewFieldID & " AND Trim(strViewFieldDesc)" _
            & "='" & Trim(cboEditItem(0).Text) & "'"
        strSql = "SELECT lngViewID FROM ViewField WHERE lngViewID=" & mintSalaryViewID _
            & " AND lngViewFieldID<>" & lngViewFieldID & " AND LTRIM(RTrim(strViewFieldDesc))" _
            & "='" & Trim(cboEditItem(0).Text) & "'"
    Else
        'Strsql = "SELECT lngViewID FROM ViewField WHERE lngViewID=" & mintSalaryViewID _
            & " AND Trim(strViewFieldDesc)" & "='" & Trim(cboEditItem(0).Text) & "'"
        strSql = "SELECT lngViewID FROM ViewField WHERE lngViewID=" & mintSalaryViewID _
            & " AND LTRIM(RTrim(strViewFieldDesc))" & "='" & Trim(cboEditItem(0).Text) & "'"
    End If
    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recRecordset.EOF Then
        ShowMsg Me.hWnd, "项目名称不能重复！", vbExclamation, Me.Caption
        cboEditItem(0).SetFocus
        GoTo CheckClose
    End If
    '校验录入类型是否正确
    If Trim(cboEditItem(1).Text) <> "文本" And Trim(cboEditItem(1).Text) <> "数字" And _
        Trim(cboEditItem(1).Text) <> "日期" Then
        ShowMsg Me.hWnd, "项目类型只能为：文本、数字或日期！", vbExclamation, Me.Caption
        cboEditItem(1).Enabled = True
        cboEditItem(1).SetFocus
        GoTo CheckClose
    End If
    '校验录入长度是否正确
    If Val(txtCard(0).Text) = 0 Then
        ShowMsg Me.hWnd, "项目长度不能为零！", vbExclamation, Me.Caption
        txtCard(0).SetFocus
        GoTo CheckClose
    End If
    '校验录入小数是否正确
    If Val(txtCard(1).Text) > 0 Then
        If Val(txtCard(1).Text) > Val(txtCard(0).Text) - 2 Then
            ShowMsg Me.hWnd, "项目小数位数至少应比总长度小两位！", vbExclamation, Me.Caption
            txtCard(1).SetFocus
            GoTo CheckClose
        End If
    Else
        txtCard(1).Text = 0
    End If
    If mintEditItem = 0 Then
        With frmSalaryListNewWizard.msgWizard(1)
            strSql = "Select LngSalaryListId From Salary "
            Set recZ = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If Not recZ.EOF Then
                If strItemType <> Trim(cboEditItem(1).Text) Then
                    If cboEditItem(1).Enabled Then
                        ShowMsg Me.hWnd, "项目的类型不能更改！", vbExclamation, Me.Caption
                        cboEditItem(1).SetFocus
                    Else
                        ShowMsg Me.hWnd, "项目不能更改为职员卡片上的项目！", vbExclamation, Me.Caption
                        cboEditItem(0).SetFocus
                    End If
                    GoTo CheckClose
                End If
                If Trim(cboEditItem(1).Text) = "数字" Then
                    '数据长度不能减小
                    If Val(txtCard(0).Text) < Val(.TextMatrix(.Row, 2)) Then
                        ShowMsg Me.hWnd, "项目长度不能减小！", vbExclamation, Me.Caption
                        txtCard(0).SetFocus
                        GoTo CheckClose
                    '数据长度不变
                    ElseIf Val(txtCard(0).Text) = Val(.TextMatrix(.Row, 2)) Then
                        '小数位数不能改变
                        If Val(txtCard(1).Text) <> Val(.TextMatrix(.Row, 3)) Then
                            ShowMsg Me.hWnd, "项目长度不变，小数位数不能改变！", vbExclamation, Me.Caption
                            txtCard(1).SetFocus
                            GoTo CheckClose
                        End If
                    '数据长度增大
                    Else
                        '小数位数不能减小
                        If Val(txtCard(1).Text) < Val(.TextMatrix(.Row, 3)) Then
                            ShowMsg Me.hWnd, "小数位数不能减小！", vbExclamation, Me.Caption
                            txtCard(1).SetFocus
                            GoTo CheckClose
                        '数据长度增大，小数位数不变
                        ElseIf Val(txtCard(1).Text) = Val(.TextMatrix(.Row, 3)) Then
                        '小数位数增大
                        Else
                            '小数位数的增加位数不超出数据长度的增加位数
                            If Val(txtCard(1).Text) - Val(.TextMatrix(.Row, 3)) > Val(txtCard(0).Text) - Val(.TextMatrix(.Row, 2)) Then
                                ShowMsg Me.hWnd, "小数位数的增加数不超出数据长度的增加数！", vbExclamation, Me.Caption
                                txtCard(1).SetFocus
                                GoTo CheckClose
                            End If
                        End If
                    End If
                ElseIf Trim(cboEditItem(1).Text) = "文本" Then
                    If Val(txtCard(0).Text) < Val(.TextMatrix(.Row, 2)) Then
                        ShowMsg Me.hWnd, "文本项目长度不能减小！", vbExclamation, Me.Caption
                        txtCard(0).SetFocus
                        GoTo CheckClose
                    End If
                End If
            End If
        End With
    End If
    CheckOK = True
CheckClose:
    If Not recZ Is Nothing Then
        recZ.Close
        Set recZ = Nothing
    End If
    If Not recRecordset Is Nothing Then
        recRecordset.Close
        Set recRecordset = Nothing
    End If
End Function
Private Sub txtCard_Change(Index As Integer)
    If Len(Trim(txtCard(Index).Text)) = 0 Then
        txtCard(Index).Text = 0
    End If
End Sub
Private Sub txtCard_KeyPress(Index As Integer, KeyAscii As Integer)
    If KeyAscii > 47 And KeyAscii < 58 Or KeyAscii = vbKeyBack Or KeyAscii = 13 Then
        If KeyAscii = 13 Then
            If Index = 1 Then
                If mintEditItem Then
                    cmdAddItem(2).SetFocus
                Else
                    cmdAddItem(0).SetFocus
                End If
            Else
                If txtCard(1).Enabled = True Then
                    txtCard(1).SetFocus
                Else
                    If mintEditItem Then
                        cmdAddItem(2).SetFocus
                    Else
                        cmdAddItem(0).SetFocus
                    End If
                End If
            End If
        End If
    Else
        SendKeys "{BS}"
    End If
End Sub
'校验字段名称是否为SQL保留字
Function Check_Name_Sql(ByVal strName As String) As Boolean
    Dim strSql As String
    Dim recRecordset As rdoResultset
    
    'strName = "SELECT lngSalaryListID AS " & strName & " FROM Salary"
    strSql = "SELECT lngSalaryListID AS " & strName & " FROM Salary"
    On Error GoTo Errors1
    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    recRecordset.Close
    Set recRecordset = Nothing
    Check_Name_Sql = True
    Exit Function
Errors1:
    Check_Name_Sql = False
    If Not recRecordset Is Nothing Then
        recRecordset.Close
        Set recRecordset = Nothing
    End If
End Function
'字段变长
Private Sub FieldSize(ByVal strFieldName As String, ByVal intSize As Integer, ByVal lngViewFieldID As Long)
    '表名、字段长度，字段对应视图项目ID
    'Dim fidField As New Field
    Dim strSql As String
    On Error GoTo Errors1
    gclsBase.BaseWorkSpace.BeginTrans
    'Set fidField = gclsBase.BaseDB.TableDefs("Salary").CreateField("SaField", dbText, intSize)