frmsalarylisteditsome.frm

金算盘软件代码

      Left            =   5880
      Style           =   1  'Graphical
      TabIndex        =   26
      Top             =   120
      UseMaskColor    =   -1  'True
      Width           =   1210
   End
End
Attribute VB_Name = "frmSalaryListEditSome"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'批量修改
'
'功能: 定义公式和计算范围对工资表数据进行计算
'
'读取工资列表中的 SalaryID      '工资表ID
'读取工资列表中的 SalaryViewID  '工资表视图ID
'
'作者: 唐吉禹
'
'1998-6-20
Option Explicit '
Private mEditText As Integer  '0表示录入为公式，1表示录入为条件
Private mintSalaryViewID As Integer '工资表视图ID
Private mlngSalaryID As Long  '工资表ID
Private WithEvents mclsDepoland As DepolandClass
Attribute mclsDepoland.VB_VarHelpID = -1
Private mblnFomulaOk As Boolean  '公式校验通过标志
Private mblnCond As Boolean
Private mstrTableSql As String    '查询表SQL
Private mstrTableWHERE As String    '查询表WHERE
Private mstrFormular As String      '公式Sql
Private mstrFormularWHERE As String '公式WHERE
Private mblnCheck As Boolean        '校验公式否
Private mstrFomularItemname As String   '工资公式项目名称
Private mblnIsOK As Boolean         '是否为确定退出
Private Function CheckFormula() As Boolean
    Dim strFomular As String       '公式
    Dim strCond As String          '条件
    Dim strSql As String
    Dim blnIsError  As Boolean     '出错否
    Dim recSalaryTry As rdoResultset  '测试公式Rec
    Dim mstrSalarySQL As String
    Dim strDateFunTmp1 As String
    Dim strDateFunTmp2 As String
    
    'mstrTableSql = "SalaryData AS tab" & mlngSalaryID
    mstrTableSql = "SalaryData tab" & mlngSalaryID
    mstrTableWHERE = " WHERE tab" & mlngSalaryID & ".lngSalaryListID=" & mlngSalaryID
    CheckFormula = False
    If Val(litSomeEdit(0).TextMatrix(litSomeEdit(0).ReferRow, 1)) = 0 Then
        ShowMsg Me.hwnd, "被修改项目不能为空。", vbInformation, "工资发放"
        mblnFomulaOk = False
        Exit Function
    End If
    txtEditSome(0).Text = Salary.Change_Text("|", "", txtEditSome(0).Text)
    If Len(Trim(txtEditSome(0).Text)) = 0 Then
        ShowMsg Me.hwnd, "修改公式不能为空。", vbInformation, "工资发放"
        mblnFomulaOk = False
        Exit Function
    End If
    mstrSalarySQL = frmSalaryList.Salary_SQL
    '调用公式校验
    mblnCond = False
    mblnFomulaOk = True
    '判断不存在关系运算符
    If InStr(txtEditSome(0).Text, "=") > 0 Or InStr(txtEditSome(0).Text, ">") > 0 Or _
        InStr(txtEditSome(0).Text, "<") > 0 Or InStr(txtEditSome(0).Text, "<>") > 0 Or _
        mblnFomulaOk = False Or InStr(txtEditSome(0).Text, " 并且 ") > 0 Or _
        InStr(txtEditSome(0).Text, " 或者 ") > 0 Or InStr(txtEditSome(0).Text, " 且 ") > 0 _
        Or InStr(txtEditSome(0).Text, " 或 ") > 0 Then
        ShowMsg Me.hwnd, "计算公式不能含有：'=','>','<','<>','并且','或者','且','或'。", _
            vbInformation, Me.Caption
    End If
    If mblnFomulaOk = True Then
        '替换运算符
        strFomular = Trim(txtEditSome(0).Text)
        '替换回车
        strFomular = Salary.Change_Text(Chr(13), " ", strFomular)
        strFomular = Salary.Change_Text(Chr(10), " ", strFomular)
        '替换Ctrl+I
        strFomular = Salary.Change_Text(Chr(9), " ", strFomular)
        '替换除号
        strFomular = Salary.Change_Text("÷", "/", strFomular)
        '替换乘号
        strFomular = Salary.Change_Text("×", "*", strFomular)
        Analysis strFomular
        '通过校验
        If mblnFomulaOk Then
            '取出公式
            mclsDepoland.GetFomular strFomular
        End If
        '校验条件
        If Len(Trim(txtEditSome(1).Text)) > 0 Then
            mblnCond = True
            '替换运算符
            strCond = txtEditSome(1).Text
            '替换回车
            strCond = Salary.Change_Text(Chr(13), " ", strCond)
            strCond = Salary.Change_Text(Chr(10), " ", strCond)
            '替换Ctrl+I
            strCond = Salary.Change_Text(Chr(9), " ", strCond)
            '替换除号
            strCond = Salary.Change_Text("÷", "/", strCond)
            '替换乘号
            strCond = Salary.Change_Text("×", "*", strCond)
            '替换等号
            strCond = Salary.Change_Text("＝", "=", strCond)
            Analysis strCond
            '通过校验
            If mblnFomulaOk Then
                '取出公式
                mclsDepoland.GetFomular strCond
                '根据关键字IN删除等号，如：部门名称='生产部'而'生产部'为非末级部门时，先在
                'mclsDepoland_OnAccidenceParse中将'生产部'替换为：IN('一车间','二车间')。(其中'一车间'
                ','二车间'为'生产部'的下级明细部门)则公式变为：部门名称=IN('一车间','二车间')，
                '多出一个等号。ChangIN的功能是将多出的等号删除。计算条件中包含"IN('"系统认为可能多出一个等号
                '将紧靠前的"="删除
                Call Salary.ChangeIN(strCond)
            End If
        End If
        If mblnFomulaOk Then
            '写回英文公式
            strSql = "SELECT " & strFomular & " AS dblValue" & " FROM " & mstrTableSql _
                & mstrTableWHERE
            If Len(Trim(strCond)) > 0 Then
                strDateFunTmp1 = ""
                strDateFunTmp2 = ""
                strDateFunTmp1 = Salary.GetOraDateFunnctionCalc(strCond, strDateFunTmp2)
                strSql = strSql & " AND " & strDateFunTmp1
                If strDateFunTmp2 <> "" Then
                    strSql = strSql & " AND " & strDateFunTmp2
                End If
            End If
            On Error GoTo Errors1
            Set recSalaryTry = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            recSalaryTry.Close
            Set recSalaryTry = Nothing
            CheckFormula = True
            mstrFormular = strFomular
            mstrFormularWHERE = strCond
        End If
    End If
    Exit Function
Errors1:
    CheckFormula = False
    ShowMsg Me.hwnd, "批量修改公式有误。", vbInformation, Me.Caption
End Function
Private Sub cmdEditSome_Click(Index As Integer)
    Dim intThisSelStart As Long
    If mEditText >= 0 Then
        If Index = 0 Or Index = 1 Or Index = 2 Or Index = 3 Or Index = 7 Or Index = 11 Or mEditText = 1 Then
            intThisSelStart = txtEditSome(mEditText).SelStart
            txtEditSome(mEditText).Text = frmSalaryList.select_text(txtEditSome(mEditText).SelText, txtEditSome(mEditText).SelStart, _
            txtEditSome(mEditText).SelLength, txtEditSome(mEditText).Text, cmdEditSome(Index).Caption)
            txtEditSome(mEditText).SetFocus
            txtEditSome(mEditText).SelStart = intThisSelStart + Len(Trim(cmdEditSome(Index).Caption)) + 2
        Else
            txtEditSome(0).SetFocus
        End If
    End If
End Sub

Private Sub cmdOK_Click(Index As Integer)
    Dim strSql As String
    Dim strCalc As String
    Dim strCond As String
    Select Case Index
    Case 1
        mblnIsOK = False
        Unload Me
    Case 0   '确定
        mblnIsOK = True
        '已结帐期间的数据不允许修改
        If frmSalaryEdit.IsPostDate Then
            Unload Me
            Exit Sub
        End If
        '校验公式
        mblnCheck = False
        If Not CheckFormula() Then
            Exit Sub
        End If
        With litSomeEdit(0)
            If Val(.TextMatrix(.ReferRow, 1)) = 0 Then
                ShowMsg Me.hwnd, "被修改项目不能为空。", vbInformation, Me.Caption
                litSomeEdit(0).SetFocus
                Exit Sub
            End If
        End With
        Call EditCalc
        '计算工资表
        frmSalaryEdit.Calc = True
        Unload Me
    Case 2    '校验
        mblnCheck = True
        If CheckFormula() Then
            ShowMsg Me.hwnd, "公式通过校验。", vbInformation, Me.Caption
        End If
    End Select
End Sub

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
End Sub

Private Sub Form_Load()
    Dim recSalaryFieldID As rdoResultset
    Dim recViewField As rdoResultset
    Dim recSalaryList As rdoResultset
    Dim strSql As String
    Dim i As Integer
    Dim strName As String
    Me.Left = (Screen.width - Me.width) / 2
    Me.top = (Screen.Height - Me.Height) / 2
    mEditText = -1
    '工资视图表ID
    mintSalaryViewID = frmSalaryList.SalaryViewID
    '工资列表ID
    mlngSalaryID = frmSalaryList.SalaryID
    '选择项目列表初始化
    strSql = "SELECT * FROM ViewField WHERE lngViewID=" & mintSalaryViewID
    Set recViewField = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With msgEditSome
        .Rows = 1
        .Clear
        .Cols = 5
        .ColWidth(0) = 2700
        .ColWidth(1) = 0
        .ColWidth(2) = 0
        .ColWidth(3) = 0
        .ColWidth(4) = 0
        .ColAlignment(0) = 0
        i = 0
        Do While Not recViewField.EOF()
            If Trim(.TextMatrix(0, 0)) <> "" Then
                .AddItem ("")
            End If
            .TextMatrix(i, 0) = recViewField!strViewFieldDesc
            .TextMatrix(i, 1) = recViewField!lngViewFieldID
            .TextMatrix(i, 2) = recViewField!strFieldType
            .TextMatrix(i, 3) = recViewField!strTableName
            .TextMatrix(i, 4) = recViewField!strFieldName
            recViewField.MoveNext
            i = i + 1
        Loop
        .Row = 0
        For i = 0 To .Rows - 1
            .RowHeight(i) = 215
        Next
    End With
    recViewField.Close
    Set recViewField = Nothing
    '修改项目初始化
    'strSql = "SELECT ViewField.lngViewFieldID,ViewField.strViewFieldDesc FROM " _
        & "SalaryField INNER JOIN ViewField ON SalaryField.lngViewFieldID " _
        & "= ViewField.lngViewFieldID WHERE SalaryField.lngSalaryListID=" _
        & mlngSalaryID & " AND ViewField.strTableName='Salary' AND " _
        & "ViewField.strFieldType='Double' AND Trim(ViewField.strFieldName)<>" _
        & "'Salary.dblNowTax' AND Trim(ViewField.strFieldName)<>'Salary.dblNowZero'" _
        & " AND strFieldName <> 'Salary.dblLastZero'"
    strSql = "SELECT ViewField.lngViewFieldID,ViewField.strViewFieldDesc " _
        & " FROM SalaryField,ViewField " _
        & " WHERE SalaryField.lngViewFieldID = ViewField.lngViewFieldID " _
        & " AND SalaryField.lngSalaryListID=" & mlngSalaryID & "AND UPPER(ViewField.strTableName)='SALARY' " _
        & " AND UPPER(ViewField.strFieldType)='DOUBLE' AND UPPER(LTrim(RTRIM(ViewField.strFieldName)))<>" _
        & " 'SALARY.DBLNOWTAX' AND UPPER(LTrim(RTRIM(ViewField.strFieldName)))<>'SALARY.DBLNOWZERO'" _
        & " AND UPPER(LTrim(RTRIM(ViewField.strFieldName))) <> 'SALARY.DBLLASTZERO'" _
        & " AND UPPER(LTrim(RTRIM(ViewField.strFieldName))) <> 'SALARY.SA18660'"
    Set recSalaryFieldID = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    i = 0
    litSomeEdit(0).SeekCol = "1,2"
    litSomeEdit(0).CodeSort = True
    If Not recSalaryFieldID.EOF() Then
        recSalaryFieldID.MoveLast
        recSalaryFieldID.MoveFirst
    End If
    litSomeEdit(0).SQL = strSql
    Set litSomeEdit(0).Recordset = recSalaryFieldID
    recSalaryFieldID.Close
    Set recSalaryFieldID = Nothing
    '其他工资表初始化
    strSql = "Select lngSalaryListID,strSalaryListName From SalaryList WHERE lngSalaryListID<>" & mlngSalaryID
    Set recSalaryList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recSalaryList.EOF Then
        recSalaryList.MoveLast
        recSalaryList.MoveFirst
    End If
    litSomeEdit(1).ClearRefer
    litSomeEdit(1).SeekCol = "1,2"
    litSomeEdit(1).SQL = strSql
    litSomeEdit(1).CodeSort = True
    Set litSomeEdit(1).Recordset = recSalaryList
    'Set litSomeEdit(1).Resultset = recSalaryList
    recSalaryList.Close
    Set recSalaryList = Nothing
    litSomeEdit(1).AddRefer "本表" & vbTab & "本表"
    Set cmdOk(0).Picture = Utility.GetFormResPicture(1001, 0)
    Set cmdOk(1).Picture = Utility.GetFormResPicture(1002, 0)
    Set Me.Icon = Utility.GetFormResPicture(139, vbResIcon)
    mblnIsOK = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Utility.RemoveFormResPicture (1001)
    Utility.RemoveFormResPicture (1002)
    Utility.RemoveFormResPicture (139)
    Set frmSalaryListEditSome = Nothing
End Sub

Private Sub lstEditSome_Click()