frmsalarylisteditsome.frm

金算盘软件代码

    Dim intThisSelStart As Integer
    If mEditText = 1 Then
        intThisSelStart = txtEditSome(1).SelStart
        txtEditSome(1).Text = frmSalaryList.select_text(txtEditSome(1).SelText, txtEditSome(1).SelStart, _
        txtEditSome(1).SelLength, txtEditSome(1).Text, lstEditSome.Text)
        txtEditSome(1).SetFocus
        txtEditSome(1).SelStart = intThisSelStart + Len(Trim(lstEditSome.Text)) + 2
    End If
End Sub
Private Sub mclsDepoland_OnAccidenceParse(ByVal strToken As String, token As TokenClass, blnOK As Boolean)
    Dim i As Long
    Dim j As Long
    Dim strMsg As String
    Dim strString As String
    Dim strID As String
    Dim strTableName As String
    Dim strFieldName As String
    Dim strSql As String
    Dim recRecordset As rdoResultset
    Dim strFormula As String
    
    strToken = Trim(strToken)
    i = InStr(strToken, ".")
    '表名
    If i > 0 Then
        strTableName = Left(strToken, i - 1)
    End If
    '字段名称
    strFieldName = Right(strToken, Len(strToken) - i)
    i = 0
    strID = ""
    With msgEditSome
        Do While i < .Rows
            '计算公式中含有字符型字段
            If UCase(Trim(strFieldName)) = UCase(Trim(.TextMatrix(i, 0))) Then
                If mblnCond = False And .TextMatrix(i, 2) = "String" Then
                    Exit Do
                End If
                mstrFomularItemname = Trim(strFieldName)
                '带表名
                If Len(Trim(strTableName)) > 0 And strTableName <> "本表" Then
                    j = 0
                    Do While j < litSomeEdit(1).Referrows
                        If Trim(litSomeEdit(1).TextMatrix(j, 2)) = Trim(strTableName) Then
                            strID = litSomeEdit(1).TextMatrix(j, 1)
                            Exit Do
                        End If
                        j = j + 1
                    Loop
                Else
                    strID = mlngSalaryID
                End If
                If strID = "" Then
                    ShowMsg Me.hwnd, "不能识别表：" & strTableName & "。", vbInformation, Me.Caption
                    blnOK = False
                    Exit Sub
                End If
                '公式,去掉表名
                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
                '加上查询名称
                token.Value = "tab" & strID & "." & token.Value
                '公式查询串中不含当前查询
                If InStr(mstrTableWHERE, "tab" & strID & ".") = 0 Then
                    If Len(mstrTableSql) = 0 Then
                        'mstrTableSql = " SalaryData AS tab" & strID
                        mstrTableSql = " SalaryData tab" & strID
                        mstrTableWHERE = " WHERE tab" & strID & ".lngSalaryListID=" & strID
                    Else
                        'mstrTableSql = mstrTableSql & ",SalaryData AS tab" & strID
                        mstrTableSql = mstrTableSql & ",SalaryData tab" & strID
                        mstrTableWHERE = mstrTableWHERE & " AND tab" & strID _
                            & ".lngSalaryListID=" & strID & " AND tab" & mlngSalaryID _
                            & ".lngEmployeeID=tab" & strID & ".lngEmployeeID"
                    End If
                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) = "'" And mblnCond Then
            '查找项目值
            strSql = ""
            strFormula = strToken
            On Error GoTo Errors1
            Select Case mstrFomularItemname
            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, "工资发放"
                    blnOK = False
                    mblnFomulaOk = 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,'" & LTrim(RTrim(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 mstrFomularItemname = "性别" Then
                token.Value = IIf(strFormula = "'男'", True, False)
            Else
                token.Value = strFormula
            End If
            mstrFomularItemname = ""
            blnOK = True
        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
    mblnFomulaOk = blnOK
    Exit Sub
Errors1:
    ShowMsg Me.hwnd, "不能识别：'" & strFormula & "'。", vbInformation, Me.Caption
    blnOK = False
    mblnFomulaOk = blnOK
End Sub

Private Sub msgEditSome_Click()
    Call msgEditSome_RowColChange
End Sub

Private Sub msgEditSome_DblClick()
        Dim intThisSelStart As Integer
        Dim strSelect As String
        Select Case mEditText
        Case 0  '选择公式
            With msgEditSome
                If UCase(.TextMatrix(.Row, 2)) = "DOUBLE" Then
                    If Trim(litSomeEdit(1).TextMatrix(litSomeEdit(1).ReferRow, 2)) = "本表" Or Trim(litSomeEdit(1).TextMatrix(litSomeEdit(1).ReferRow, 2)) = "" Then
                        strSelect = .TextMatrix(.Row, 0)
                    Else
                        strSelect = litSomeEdit(1).TextMatrix(litSomeEdit(1).ReferRow, 2) _
                            & "." & .TextMatrix(.Row, 0)
                    End If
                    intThisSelStart = txtEditSome(0).SelStart
                    txtEditSome(0).Text = frmSalaryList.select_text(txtEditSome(0).SelText, txtEditSome(0).SelStart, _
                     txtEditSome(0).SelLength, txtEditSome(0).Text, strSelect)
                    txtEditSome(0).SetFocus
                    txtEditSome(0).SelStart = intThisSelStart + Len(Trim(strSelect)) + 2
                Else
                    txtEditSome(0).SetFocus
                End If
            End With
        Case 1  '选择条件
            With msgEditSome
                intThisSelStart = txtEditSome(1).SelStart
                txtEditSome(1).Text = frmSalaryList.select_text(txtEditSome(1).SelText, txtEditSome(1).SelStart, _
                txtEditSome(1).SelLength, txtEditSome(1).Text, .TextMatrix(.Row, 0))
                txtEditSome(1).SetFocus
                txtEditSome(1).SelStart = intThisSelStart + Len(Trim(.TextMatrix(.Row, 0))) + 2
            End With
        End Select
End Sub

Private Sub msgEditSome_RowColChange()
    Dim recItem As rdoResultset
    Dim strSql As String
    With msgEditSome
        '职员信息和代发银行帐号
        If UCase(Trim(.TextMatrix(.Row, 3))) <> "SALARY" Or UCase(Trim(.TextMatrix(.Row, 4))) = "SALARY.STRBANKCODE" Then '参照表
            lstEditSome.Clear
            strSql = "SELECT " & .TextMatrix(.Row, 4) & " AS Item FROM " & .TextMatrix(.Row, 3) & _
                     " GROUP BY " & .TextMatrix(.Row, 4)
            Set recItem = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            Do While Not recItem.EOF()
                If UCase(.TextMatrix(.Row, 2)) = "DOUBLE" Then
                    If Not IsNull(recItem!Item) Then
                        If Trim(str(recItem!Item)) <> "" Then
                            lstEditSome.AddItem (recItem!Item)
                        End If
                    End If
                Else
                    If Not IsNull(recItem!Item) Then
                        If Trim(recItem!Item) <> "" Then
                            lstEditSome.AddItem ("'" & recItem!Item & "'")
                        End If
                    End If
                End If
                recItem.MoveNext
            Loop
            recItem.Close
            Set recItem = Nothing
        Else
            lstEditSome.Clear
        End If
    End With
End Sub

Private Sub txtEditSome_GotFocus(Index As Integer)
    mEditText = Index
End Sub
Private Function Analysis(ByVal strFomular As String) As Boolean
    Set mclsDepoland = New DepolandClass
    Analysis = mclsDepoland.VerifyFomular(strFomular)
End Function

Private Sub EditCalc()
    Dim strSql As String
    Dim strLeft As String
    Dim strRight As String
    Dim strTmp As String
    Dim strDateFunTmp1 As String
    Dim strDateFunTmp2 As String
    
    With litSomeEdit(0)
    
        If InStr(Trim(mstrTableSql), ",") > 0 Then
        'strSql = "UPDATE " & mstrTableSql & " SET Tab" & mlngSalaryID & ".Sa" _
            & .TextMatrix(.ReferRow, 1) & "=" & mstrFormular & mstrTableWHERE
        strTmp = UCase(Trim(mstrTableSql))
        strLeft = Trim(Right(strTmp, Len(strTmp) - InStr(strTmp, ",")))
        strRight = Trim(Right(strLeft, Len(strLeft) - InStr(strLeft, " ")))
        strTmp = Right(strRight, Len(strRight) - 3)
        strSql = "UPDATE SalaryData Tab" & mlngSalaryID & " SET Tab" & mlngSalaryID & ".Sa" _
            & .TextMatrix(.ReferRow, 1) & "= (SELECT " & mstrFormular & " FROM " & strLeft & " WHERE " _
            & strRight & ".lngSalaryListID=" & strTmp _
            & " AND " & strRight & ".lngEmployeeID=Tab" & mlngSalaryID & ".lngEmployeeID) " _
            & " WHERE Tab" & mlngSalaryID & ".lngSalaryListID=" & mlngSalaryID _
            & " And Tab" & mlngSalaryID & ".lngEmployeeID In (Select lngEmployeeID FROM Salary  WHERE " _
            & " Salary.lngSalaryListID=" & strTmp & ")"
        Else
            strSql = "UPDATE " & mstrTableSql & " SET Tab" & mlngSalaryID & ".Sa" _
                & .TextMatrix(.ReferRow, 1) & "=" & mstrFormular & mstrTableWHERE
        End If
        If Len(Trim(mstrFormularWHERE)) > 0 Then
            strDateFunTmp1 = ""
            strDateFunTmp2 = ""
            strDateFunTmp1 = Salary.GetOraDateFunnctionCalc(mstrFormularWHERE, strDateFunTmp2)
            strSql = strSql & " AND " & strDateFunTmp1
            If strDateFunTmp2 <> "" Then
                strSql = strSql & " AND " & strDateFunTmp2
            End If
        End If
        gclsBase.BaseDB.Execute strSql
    End With
End Sub
Private Sub txtEditSome_KeyPress(Index As Integer, KeyAscii As Integer)
    If KeyAscii = 124 Then
        SendKeys "{BACKSPACE}"
    End If
End Sub

Public Function ShowSalaryListEditSome() As Boolean
    frmSalaryListEditSome.Show vbModal
    ShowSalaryListEditSome = mblnIsOK
End Function