frmsalaryfunction.frm

金算盘软件代码

         FocusRect       =   0
         GridLines       =   0
         GridLinesFixed  =   0
         ScrollBars      =   2
         SelectionMode   =   1
         Appearance      =   0
      End
      Begin VB.Label lblCaption 
         BackStyle       =   0  'Transparent
         Caption         =   "计算条件(&W)"
         Height          =   255
         Index           =   2
         Left            =   180
         TabIndex        =   8
         Top             =   225
         Width           =   1065
      End
      Begin VB.Label lblCaption 
         Caption         =   "项目值："
         Height          =   225
         Index           =   13
         Left            =   4140
         TabIndex        =   27
         Top             =   1380
         Width           =   1035
      End
      Begin VB.Label lblCaption 
         Caption         =   "项目："
         Height          =   255
         Index           =   7
         Left            =   1560
         TabIndex        =   25
         Top             =   1410
         Width           =   1095
      End
   End
End
Attribute VB_Name = "frmSalaryFunction"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'计算函数向导
'
'功能：生成求合计等函数
'
'作者：唐吉禹
'
'1998.11.16
'
Private mlngSalarylistID As Long           '工资目录表ID
Private WithEvents mclsDepoland As DepolandClass
Attribute mclsDepoland.VB_VarHelpID = -1
Private mblnFormulaOk As Boolean            '工资公式正确否
Private mstrFormularItemname As String       '工资公式项目名称
Private mstrFormula As String               '工资公式
Private mstrFormulaDesc As String           '工资公式说明
Private mstrFormulaWHERE As String          '工资条件
Private mblnOk As Boolean                   '确认否
Private Sub cmdButton_Click(Index As Integer)
    If Index = 0 Then '确定
        '校验条件
        If Not CheckFormula() Then
            Exit Sub
        End If
        mblnOk = True
    Else
       mblnOk = False
    End If
    Me.Hide
End Sub

Private Sub cmdOperator_Click(Index As Integer)
    Dim intThisSelStart As Long
    intThisSelStart = txtEdit.SelStart
    txtEdit.Text = frmSalaryList.select_text(txtEdit.SelText, txtEdit.SelStart, _
    txtEdit.SelLength, txtEdit.Text, cmdOperator(Index).Caption)
    txtEdit.SetFocus
    txtEdit.SelStart = intThisSelStart + Len(Trim(cmdOperator(Index).Caption)) + 2
End Sub

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
End Sub

Private Sub Form_Load()
    Me.Left = (Screen.width - Me.width) \ 2
    Me.top = (Screen.Height - Me.Height) \ 2
    Set cmdButton(0).Picture = Utility.GetFormResPicture(1001, 0)
    Set cmdButton(1).Picture = Utility.GetFormResPicture(1002, 0)
    Set Me.Icon = Utility.GetFormResPicture(139, vbResIcon)
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Utility.RemoveFormResPicture (1001)
    Utility.RemoveFormResPicture (1002)
    Utility.RemoveFormResPicture (139)
    Set frmSalaryFunction = Nothing
End Sub
'初始化工资表
Private Sub InitSalaryTable()
    Dim strSql As String
    Dim rec As rdoResultset
    
    'Strsql = "SELECT SalaryList.lngSalaryListID,IIf(lngSalarylistID=" & mlngSalarylistID _
        & ",'本次发放工资表',SalaryList.strSalaryListName) AS SalaryName " _
        & " FROM SalaryList WHERE SalaryList.lngSalarylistID" _
        & " ORDER BY SalaryList.strDate DESC"
    strSql = "SELECT SalaryList.lngSalaryListID,DECODE(lngSalarylistID," & mlngSalarylistID _
        & " ,'本次发放工资表',SalaryList.strSalaryListName) AS SalaryName " _
        & " FROM SalaryList " _
        & " ORDER BY SalaryList.strDate DESC"
    Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    litEdit(0).SeekCol = "1,2"
    litEdit(0).CodeSort = True
    Set litEdit(0).Recordset = rec
    litEdit(0).AddRefer ("上次发放工资表")
    If mlngSalarylistID = 0 Then
        litEdit(0).AddRefer ("本次发放工资表")
    End If
    litEdit(0).Text = "本次发放工资表"
    rec.Close
    Set rec = Nothing
End Sub
'校验函数
Public Function FunctionWizard(ByRef lngSalaryListID As Long, ByRef strFormula As _
    String, ByRef strFormulaDesc As String, ByRef strFormulaWhere As String) As Boolean
    '工资目录表ID，工资公式，工资公式说明，工资条件，计算项目ID
    mlngSalarylistID = lngSalaryListID
    '初始化工资表
    Call InitSalaryTable
    '初始化计算项目
    Call InitSalaryItem
    Me.Show vbModal
    FunctionWizard = mblnOk
    strFormula = mstrFormula
    strFormulaDesc = mstrFormulaDesc
    strFormulaWhere = mstrFormulaWHERE
    If litEdit(0).ID > 0 Then
        '本次发放的工资表
        If litEdit(0).ID = lngSalaryListID Then
            lngSalaryListID = 0
        Else
            lngSalaryListID = litEdit(0).ID
        End If
    Else
        If litEdit(0).Text = "上次发放工资表" Then
            lngSalaryListID = -1
        Else
            If litEdit(0).Text = "本次发放工资表" Then
                lngSalaryListID = 0
            End If
        End If
    End If
    Unload Me
End Function

Private Sub lstList_Click()
    Dim intThisSelStart As Integer
    intThisSelStart = txtEdit.SelStart
    txtEdit.Text = frmSalaryList.select_text(txtEdit.SelText, txtEdit.SelStart, _
        txtEdit.SelLength, txtEdit.Text, lstList.Text)
    txtEdit.SetFocus
    txtEdit.SelStart = intThisSelStart + Len(Trim(lstList.Text)) + 2
End Sub
Private Sub mclsDepoland_OnAccidenceParse(ByVal strToken As String, token As TokenClass, blnOK As Boolean)
    Dim i As Integer
    Dim strMsg As String
    Dim strString As String
    Dim strSql As String
    Dim recRecordset As rdoResultset
    Dim strFormula As String
    i = 0
    strToken = Trim(strToken)
    With msgGrid
        '查找项目
        Do While i < .Rows
            If UCase(Trim(strToken)) = UCase(Trim(.TextMatrix(i, 0))) Then
                mstrFormularItemname = strToken
                If strToken = "性别" Then
                    token.Value = "blnIsMale"
                Else
                    token.Value = Right(.TextMatrix(i, 4), Len(Trim(.TextMatrix(i, 4))) - Len(Trim(.TextMatrix(i, 3))) - 1)
                End If
                blnOK = True
                Exit Do
            End If
           i = i + 1
        Loop
    End With
    If blnOK = False Then
        '若为字符串
        If Left(Trim(strToken), 1) = "'" And Right(Trim(strToken), 1) = "'" Then
            '查找项目值
            strSql = ""
            strFormula = strToken
            On Error GoTo Errors1
            Select Case mstrFormularItemname
            Case "部门名称"
                '判断是否为非明细
                'Strsql = "SELECT blnIsDetail,strDepartmentCode From DepartMent WHERE " _
                    & "TRIM(strDepartmentName)=" & strFormula
                strSql = "SELECT blnIsDetail,strDepartmentCode From DepartMent WHERE " _
                    & "Upper(LTRIM(RTRIM(strDepartmentName)))=" & UCase(strFormula)
                Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                If recRecordset.EOF Then
                    ShowMsg Me.hwnd, "部门：" & strFormula & "不存在。", vbInformation, Me.Caption
                    blnOK = False
                    mblnFormulaOk = blnOK
                    Exit Sub
                End If
                'If Not recRecordset!blnIsDetail Then
                If recRecordset!blnIsDetail = 0 Then
                    'Strsql = "SELECT strDepartmentName From DepartMent WHERE blnIsDetail=True AND InStr" _
                        & "(strDepartmentCode,'" & Trim(recRecordset!strDepartmentCode) & "-')=1"
                    strSql = "SELECT strDepartmentName From DepartMent WHERE blnIsDetail=1 " & _
                             " AND InStr(strDepartmentCode,'" & _
                             Trim(recRecordset!strDepartmentCode) & "-')=1"
                    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                    '查找下级明细
                    If Not recRecordset.EOF Then
                        recRecordset.MoveLast
                        recRecordset.MoveFirst
                        strFormula = " IN("
                        Do While Not recRecordset.EOF
                            strFormula = strFormula & "'" & recRecordset!strDepartmentName & "',"
                            recRecordset.MoveNext
                        Loop
                        strFormula = Left(strFormula, Len(strFormula) - 1)
                        strFormula = strFormula & ")"
                    End If
                End If
            Case "职员类别"
                'Strsql = "SELECT blnIsDetail,strEmployeeTypeCode From EmployeeType WHERE TRIM(strEmployeeTypeName)=" _
                    & strFormula
                strSql = "SELECT blnIsDetail,strEmployeeTypeCode From EmployeeType " & _
                         " WHERE Upper(LTRIM(RTRIM(strEmployeeTypeName)))=" & UCase(strFormula)
                Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                If recRecordset.EOF Then
                    ShowMsg Me.hwnd, "职员类别：" & strFormula & "不存在。", vbInformation, "工资发放"
                    Exit Sub
                End If
                'If Not recRecordset!blnIsDetail Then
                If recRecordset!blnIsDetail = 0 Then
                    'Strsql = "SELECT strEmployeeTypeName From EmployeeType WHERE blnIsDetail=True AND InStr" _
                        & "(strEmployeeTypeCode,'" & Trim(recRecordset!strEmployeeTypeCode) & "-')=1"
                    strSql = "SELECT strEmployeeTypeName From EmployeeType WHERE blnIsDetail=1 " & _
                             " AND InStr(strEmployeeTypeCode,'" & _
                             Trim(recRecordset!strEmployeeTypeCode) & "-')=1"
                    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                    '查找下级明细
                    If Not recRecordset.EOF Then
                        recRecordset.MoveLast
                        recRecordset.MoveFirst
                        strFormula = " IN("
                        Do While Not recRecordset.EOF
                            strFormula = strFormula & "'" & recRecordset!strEmployeeTypeName & "',"
                            recRecordset.MoveNext
                        Loop
                        strFormula = Left(strFormula, Len(strFormula) - 1)
                        strFormula = strFormula & ")"
                    End If
                End If
            End Select
            If mstrFormularItemname = "性别" Then
                token.Value = IIf(strFormula = "'男'", 1, 0)
            Else
                token.Value = strFormula
            End If
            blnOK = True
            mstrFormularItemname = ""
        End If
    End If
    If blnOK = False Then
        If Len(Trim(strToken)) > 30 Then
            strString = Left(Trim(strToken), 24) & "......"
        Else
            strString = Trim(strToken)
        End If
        ShowMsg Me.hwnd, "不能识别：'" & strString & "'。", vbInformation, Me.Caption
    End If
    mblnFormulaOk = blnOK
    bOk = blnOK
    Exit Sub
Errors1:
    ShowMsg Me.hwnd, "不能识别：'" & strFormula & "'。", vbInformation, Me.Caption
    blnOK = False
    mblnFormulaOk = blnOK
End Sub
Private Sub msgGrid_Click()
    Call msgGrid_RowColChange
End Sub

Private Sub msgGrid_DblClick()
    Dim intThisSelStart
    Dim strSelect As String
    With msgGrid
        intThisSelStart = txtEdit.SelStart
        txtEdit.Text = frmSalaryList.select_text(txtEdit.SelText, txtEdit.SelStart, _
            txtEdit.SelLength, txtEdit.Text, .TextMatrix(.Row, 0))
        txtEdit.SetFocus
        txtEdit.SelStart = intThisSelStart + Len(Trim(.TextMatrix(.Row, 0))) + 2
    End With
End Sub
Private Sub msgGrid_RowColChange()
    Dim recItem As rdoResultset
    Dim strSql As String
    With msgGrid
        '职员信息和代发银行帐号
        If UCase(Trim(.TextMatrix(.Row, 3))) <> "SALARY" Or UCase(Trim(.TextMatrix(.Row, 4))) = "SALARY.STRBANKCODE" Then '参照表