frmfieldset.frm

金算盘软件代码

        Exit Sub
    End If
    If mintIndex = -1 Then
    '新增
        strSql = "SELECT lngReportID From ReportField Where lngReportID=" & mvarReportID & " And lngViewFieldID=0 And LTrim(strFomular)<>'' "
        Set rstField = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If rstField.RowCount >= 5 Then
            Utility.ShowMsg Me.hWnd, "此报表已有5个自定义项目了!", vbOKOnly + vbInformation, App.title
            Unload Me
            Exit Sub
        End If
        intCount = Utility.ShowMsg(Me.hWnd, "你确定要做永久性的增加吗?", vbQuestion + vbYesNo, App.title)
        If intCount = 6 Then
            For intCount = 0 To UBound(marrFields)
                If marrFields(intCount, 6) = 0 Then
                    strSql = Trim(marrFields(intCount, 4))
                    If strSql = "" Or strSql = "0" Then
                        mintIndex = intCount
                        Exit For
                    End If
                End If
            Next intCount
            
            On Error GoTo ErrHandle
            gclsBase.BaseDB.BeginTrans
            strSql = "Alter Table ReportField Disable All Triggers "
            gclsBase.BaseDB.Execute (strSql)
            
            lngFieldID = BillPublic.GetNewID("ReportField")
            strSql = "Select * From ReportField"
            Set rstField = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
            With rstField
'                .MoveLast
                .AddNew
                !lngReportID = mvarReportID
                !lngReportFieldID = lngFieldID
                !lngViewFieldID = 0
                !strReportFieldDesc = Trim(txtName.Text)
                !blnIsChoosed = False
                !intShowNO = 100 + mintIndex
                !strFomular = mstrFormula
                .Update
            End With
            strSql = "Alter Table ReportField Enable All Triggers"
            gclsBase.BaseDB.Execute (strSql)
            gclsBase.BaseDB.CommitTrans
            
            marrFields(mintIndex, 1) = lngFieldID
            marrFields(intCount, 0) = Trim(txtName.Text) & Space(100) & CStr(intCount)
            marrFields(intCount, 2) = "Double"
            marrFields(intCount, 3) = mstrSelect
            marrFields(intCount, 4) = mstrFormula
            mblnOk = True
        Else
            mblnOk = False
        End If
    Else
    '修改
        intCount = Utility.ShowMsg(Me.hWnd, "你确定要做永久性的修改吗?", vbQuestion + vbYesNo, App.title)
        If intCount = 6 Then
            strSql = "UPDATE ReportField Set strReportFieldDesc='" & Trim(txtName.Text) & "',strFomular='" & mstrFormula _
                   & "' Where lngReportFieldID=" & marrFields(mintIndex, 1)
            blnOK = gclsBase.ExecSQL(strSql)
            If Not blnOK Then
                Utility.ShowMsg Me.hWnd, "修改失败,请稍后重新操作!", vbInformation + vbOKOnly, App.title
                Exit Sub
            End If
            
            marrFields(mintIndex, 3) = mstrSelect
            marrFields(mintIndex, 4) = mstrFormula
            mblnOk = True
        Else
            mblnOk = False
        End If
    End If
    
    Unload Me
    Exit Sub
ErrHandle:
    gclsBase.BaseDB.RollBacktrans
    Utility.ShowMsg Me.hWnd, "新增失败：[" & Err.Description & "]", vbInformation + vbOKOnly, App.title
End Sub

Private Sub CmdCancel_Click()
    mblnOk = False
    Unload Me
End Sub

Private Sub cmdClear_Click()
    txtFormula.Text = ""
    mstrSelect = ""
    cmdAffirm.Enabled = False
End Sub

Private Sub cmdOperate_Click(Index As Integer)
    txtFormula.SelText = cmdOperate(Index).Caption
    cmdAffirm.Enabled = False
End Sub


Private Sub Form_Activate()
    Utility.SetHelpID Me.HelpContextID
End Sub

Private Sub Form_Load()

    cmdCancel.Picture = Utility.GetFormResPicture(1002, vbResBitmap)
    cmdAffirm.Picture = Utility.GetFormResPicture(1001, vbResBitmap)
    cmdAffirm.Enabled = False
    Me.HelpContextID = 10002
    Set Me.Icon = Utility.GetFormResPicture(139, vbResIcon)
End Sub

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

Private Sub lstField_Click()
Dim strSel As String
    If lstField.ListIndex <> -1 Then
        strSel = lstField.list(lstField.ListIndex)
        lstField.ToolTipText = GetNoXString(strSel, 1, Space(100))
    End If
End Sub

Private Sub lstField_DblClick()
Dim strSel As String
    If lstField.ListIndex <> -1 Then
        strSel = GetNoXString(lstField.list(lstField.ListIndex), 1, Space(100))
        txtFormula.SelText = strSel
        cmdAffirm.Enabled = False
    End If
End Sub
Private Sub mclsFormula_OnAccidenceParse(ByVal strToken As String, token As TokenClass, bOk As Boolean)
Dim intReturn As Integer
On Error Resume Next
    
    intReturn = -1
    intReturn = mcolName(strToken)
    If intReturn >= 0 Then
        token.Value = marrFields(intReturn, 3)
        bOk = True
    Else
        bOk = False
    End If
End Sub
Private Sub txtFormula_Change()
    cmdAffirm.Enabled = False
End Sub



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                   私有过程
''初始化设置
'Private Sub InitField()
'
'
'End Sub

'在指定字符串里寻找数字
Private Sub MeFind(strSel As String, intLoc As Integer)
    Dim str As String
    str = Trim(GetNoXString(strSel, 2, Space(100)))
    str = IIf(str = "", "0", str)
    intLoc = CInt(str)            '为"0"一般表示没找到
End Sub
'检查栏目名称
Private Function CheckName() As Boolean
Dim strName As String, strSel As String
Dim intCount As Integer
    strName = Trim(txtName.Text)
    For intCount = 0 To UBound(marrFields)
        If (intCount <> mintIndex) And (marrFields(intCount, 6) > 0 Or marrFields(intCount, 4) <> "") Then
            strSel = GetNoXString(marrFields(intCount, 0), 1, Space(100))
            If strSel = strName Then
                CheckName = True
                Exit Function
            End If
        End If
    Next intCount
    CheckName = False
End Function
'根据公式得到显示文本
Private Sub FormulaToText(ByVal strFormula As String, strText As String)
Dim i As Integer, intField As Integer, intLoc As Integer
Dim intStart As Integer, intEnd As Integer
Dim strSql As String, strReturn As String, strFieldID As String
    On Error Resume Next
    
    i = 1
    strReturn = strFormula
    intStart = 0
    intLoc = -1
    
    Do Until intLoc = 0
        intLoc = InStr(i, strFormula, "$")
        If intLoc = 0 Then
            
        ElseIf intStart = 0 Then
            intStart = intLoc
        Else
            strFieldID = Mid(strFormula, intStart + 1, intLoc - intStart - 1)
            intField = -1
            intField = mcolFieldID(strFieldID)
            If intField >= 0 Then
                strFieldID = Mid(strFormula, intStart, intLoc - intStart + 1)
                strSql = GetNoXString(marrFields(intField, 0), 1, Space(100))
                strReturn = strReplace(strReturn, strFieldID, strSql)
            End If
            intStart = 0
        End If
        i = intLoc + 1
    Loop
    strText = strReturn
End Sub

'根据显示文本得到公式
Private Sub TextToFormula()
Dim i As Integer, intName As Integer, intLoc As Integer
Dim intStart As Integer, intEnd As Integer
Dim strTemp As String, strSql As String, strName As String, strFormula As String
Dim strText As String, strNumber As String
    
    On Error Resume Next
    i = 1
    strText = Trim(txtFormula.Text)
    strSql = ""
    strFormula = ""
    intStart = 1
    
    For i = 1 To Len(strText)
        strTemp = Trim(Mid(strText, i, 1))
        Select Case strTemp
        Case "(", ")", "+", "-", "*", "/"
            strName = Trim(Mid(strText, intStart, i - intStart))
            intName = -1
            intName = mcolName(strName)
            If intName >= 0 Then
                strSql = strSql & "(" & marrFields(intName, 3) & ")" & strTemp
                strFormula = strFormula & "$" & marrFields(intName, 6) & "$" & strTemp
            Else
                strNumber = Mid(strText, intStart, i - intStart)
                strSql = strSql & strNumber & strTemp
                strFormula = strFormula & strNumber & strTemp
            End If
            intStart = i + 1
        Case Else
        End Select
    Next i
    If intStart <= Len(strText) Then
        strName = Trim(Mid(strText, intStart, i - intStart))
        intName = -1
        intName = mcolName(strName)
        If intName >= 0 Then
'            strSql = Mid(strFormula, intStart, i - intStart)
            strSql = strSql & "(" & marrFields(intName, 3) & ")"
            strFormula = strFormula & "$" & marrFields(intName, 6) & "$"
        Else
            strNumber = Mid(strText, intStart, i - intStart)
            strSql = strSql & strNumber
            strFormula = strFormula & strNumber
        End If
    End If
    mstrSelect = strSql
    mstrFormula = strFormula
End Sub

'修改公式strSql
Private Sub EditSql(strSel As String)
Dim strSql As String, strTemp As String
    
    strSql = "SELECT " & mstrSelect & "," & mstrAdd & Space(1) & mstrFrom & mstrWhere
    
    Select Case mvarViewID
    Case 667                             '固定资产折旧计算表
        strSql = strReplace(strSql, "BENY", "1999")
        strSql = strReplace(strSql, "BENQI", "12")
        strSql = strReplace(strSql, "LASTY", "1999")
        strSql = strReplace(strSql, "LASTQI", "11")
        strSql = strReplace(strSql, "YEARPERIOD", "199912")
    Case 755, 773 '固定资产汇总表
         strSql = strReplace(strSql, "KJQJS", "12")
    Case 651, 1117          '注册日期
        strSql = strReplace(strSql, "ZCRQ", "1999-12-12")
    Case 500, 1022
        strTemp = strSql
        strTemp = strReplace(strTemp, "KSRQ", "1999-12-12")
        strTemp = strReplace(strTemp, "JSRQ", "1999-12-12")
        strTemp = strReplace(strTemp, "ZTRQ", "1999-12-12")
        strSql = strTemp
    Case 516 To 519, 765 '经营稽查 wq
         strSql = strReplace(strSql, "JSRQ", "1999-12-12")
    Case 541, 571, 572, 574, 1017, 1019, 1021, 1149, 1150, 1188, 1220, 1221, 1222, 1223, 1235, 1236, 1244
         strTemp = strSql
         strTemp = strReplace(strTemp, "KSRQ", "1999-12-12")
         strTemp = strReplace(strTemp, "JSRQ", "1999-12-12")
         strSql = strTemp
    Case 549, 550, 1000, 1001, 1100, 1101, 1102, 1030, 1103 'wr
         strSql = strReplace(strSql, "KSRQ", "1999-12-12")
         strSql = strReplace(strSql, "JSRQ", "1999-12-12")
    Case 764     'WQ
         strSql = strReplace(strSql, "JSRQ", "1999-12-12")
         
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '''''''''''''''''''''''''''以下为标准表 '''''''''''''''''''''''''''''''''''
    
    Case 462, 466                '预测报表
        StandardReport.GetParaSql pqtRSaleQ, strTemp
        strSql = strReplace(strSql, "$RSaleQ$", strTemp)
        StandardReport.GetParaSql pqtRStockQ, strTemp
        strSql = strReplace(strSql, "$RStockQ$", strTemp)
        strSql = strReplace(strSql, "YCTS", 1)
        strSql = strReplace(strSql, "KSRQ", "1999-12-12")
        strSql = strReplace(strSql, "JZRQ", "1999-12-12")
    Case 648, 649, 650, 1114, 1115, 1116      '注册日期
        strSql = strReplace(strSql, "ZCRQ", "1999-12-12")
        strSql = strReplace(strSql, "JSRQ", "1999-12-12")
    Case 520                     '滞销稽查
        StandardReport.GetParaSql pqtRLastSale, strTemp
        strSql = strReplace(strSql, "$RLastSale$", strTemp)
        StandardReport.GetParaSql pqtRStockQ, strTemp
        strSql = strReplace(strSql, "$RStockQ$", strTemp)
        strSql = strReplace(strSql, "ZTRQ", "1999-12-12")
        strSql = strReplace(strSql, "JZRQ", "1999-12-12")
    Case 779, 781                '采购稽查
         StandardReport.GetParaSql pqtRQReceive, strTemp
         strSql = strReplace(strSql, "$RQReceive$", strTemp)
         strSql = strReplace(strSql, "JZRQ", "1999-12-12")
    Case 780, 782                '销售稽查
         StandardReport.GetParaSql pqtRQSend, strTemp
         strSql = strReplace(strSql, "$RQSend$", strTemp)
         strSql = strReplace(strSql, "JZRQ", "1999-12-12")
    Case 754, 774, 775           '固定资产清单
         StandardReport.GetBasePeriods strTemp
         strSql = strReplace(strSql, "KJQJS", strTemp)
    Case 763     'wq
        strSql = strReplace(strSql, "KSRQ", "1999-12-12")
        strSql = strReplace(strSql, "JSRQ", "1999-12-12")
    Case 1156, 1157    '保险费汇缴清册'保险费汇缴变更清册
         strSql = strReplace(strSql, "ZCRQ", "1999-12-12")
         strSql = strReplace(strSql, "TWBL", "0.15")
         strSql = strReplace(strSql, "TRBL", "0.02")
         strSql = strReplace(strSql, "GRBL", "0.02")
         strSql = strReplace(strSql, "TXBL", "0.02")
    Case Else
    End Select
    
    '返回SQL
    strSel = strSql
End Sub