+

财务分析 财财务分析务分析

VERSION 5.00
Begin VB.Form JC_Expressions 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "公式选定"
   ClientHeight    =   3240
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5595
   Icon            =   "基础设置_公式选定.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3240
   ScaleWidth      =   5595
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin VB.OptionButton OptUnAdd 
      Caption         =   "减项"
      Height          =   375
      Left            =   4575
      TabIndex        =   8
      Top             =   1725
      Width           =   840
   End
   Begin VB.OptionButton OptAdd 
      Caption         =   "加项"
      Height          =   270
      Left            =   4575
      TabIndex        =   7
      Top             =   1185
      Value           =   -1  'True
      Width           =   810
   End
   Begin VB.TextBox txtExp 
      Height          =   315
      Left            =   105
      TabIndex        =   5
      Top             =   2385
      Width           =   5295
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "取消(&C)"
      Height          =   300
      Left            =   4320
      TabIndex        =   4
      Top             =   2850
      Width           =   1120
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定(&O)"
      Height          =   300
      Left            =   3090
      TabIndex        =   3
      Top             =   2850
      Width           =   1120
   End
   Begin VB.CommandButton cmdSel 
      Caption         =   "选定"
      Height          =   300
      Left            =   4470
      TabIndex        =   2
      Top             =   645
      Width           =   1120
   End
   Begin VB.ListBox LstCodeList 
      Height          =   1680
      ItemData        =   "基础设置_公式选定.frx":1042
      Left            =   120
      List            =   "基础设置_公式选定.frx":1049
      TabIndex        =   1
      Top             =   450
      Width           =   4290
   End
   Begin VB.Label labList 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "---------------"
      Height          =   180
      Left            =   675
      TabIndex        =   6
      Top             =   165
      Width           =   1350
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "科目："
      Height          =   180
      Left            =   150
      TabIndex        =   0
      Top             =   165
      Width           =   540
   End
End
Attribute VB_Name = "JC_Expressions"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public bExpChange As Boolean  '如果确认公式所做的修改 则此值为True
                              '否则为False
Private Const ME_CAPTION = "公式选定"
Private Const ME_CODE = "cwfx_Expressions"

Private CodeListRs As New ADODB.Recordset


Private Sub cmdCancel_Click()
    Me.bExpChange = False
    Me.Hide
    
End Sub

Private Sub cmdOK_Click()
    If CheckExp = False Then
        'MsgBox "公式不合法！", vbCritical, "提示"
        Xtxxts "公式不合法！", 0, 1
        Exit Sub
    End If
    '返回解析后的公式（正向解析）
    Me.Tag = ExpTranslate(True, txtExp.Text)
    Me.bExpChange = True
    Me.Hide
End Sub

Private Sub cmdSel_Click()
    Call lstCodeList_DblClick '默认为相加
End Sub

Private Sub Form_Activate()
    With Me
        '公式文本框内容为解析后的公式 (反向解析)
        txtExp.Text = ExpTranslate(False, Me.Tag)
        .Tag = ""
        .labList.Caption = ""
        bExpChange = False
        .Caption = ME_CAPTION
        txtExp.SetFocus
        txtExp.SelStart = 0
        txtExp.SelLength = Len(txtExp.Text)
    End With
End Sub

Private Sub Form_Load()
    
    Call FullCodeList ' 填充科目列表
    
End Sub

'=================自定义程序开始====================================
Private Function CheckExp() As Boolean
    '公式检察，如果公式合法返加TRUE，否则返回FALSE
    Dim strTem As String
    Dim strTem2 As String
    Dim strTemLast As String
    Dim bOK As Boolean  '公式合法，则为True
    Dim i As Integer
    Dim j As Integer
    Dim codeColl As New Collection  '用于存放科目编码的集合
    Dim iLen As Integer
    Dim iWordBegin As Integer  '用于确定一个科目在字符串中的
    Dim iWordEnd As Integer    '开始位置和结束位置
    strTem = Trim(txtExp.Text)
    
    
    '去除字符串中的不合法字符
    Dim strLastWord As String
    For i = 1 To Len(strTem)
        strTem2 = Mid(strTem, i, 1)
        If strTem2 = "+" And strLastWord = "+" Then
            '不合法，去除此字符
        ElseIf strTem2 = "-" And strLastWord = "-" Then
            '不合法，去除此字符
        ElseIf strTem2 = "+" And strLastWord = "-" Then
            '不合法，去除此字符
        ElseIf strTem2 = "-" And strLastWord = "+" Then
            '不合法，去除此字符
        ElseIf strTem2 = " " Then
            '不合法，去除此字符
        ElseIf (Asc(strTem2) < Asc("0") Or Asc(strTem2) > Asc("9")) And (strTem2 <> "+" And strTem2 <> "-") Then
            '不合法，去除此字符
        Else
            strTemLast = strTemLast & strTem2
        End If
        strLastWord = strTem2
    Next
    '去除字符串右边多余的符号
    If Right(strTemLast, 1) = "+" Or Right(strTemLast, 1) = "-" Then
        strTemLast = Left(strTemLast, Len(strTemLast) - 1)
    End If
    '去除字符串左边多余的符号
    If Left(strTemLast, 1) = "+" Or Left(strTemLast, 1) = "-" Then
        strTemLast = Right(strTemLast, Len(strTemLast) - 1)
    End If
    txtExp.Text = strTemLast
    
    If strTemLast = "" Then  '如果公式为空
        CheckExp = True
        Exit Function
    End If
    
    
    '得到科目列表集合
    iLen = Len(strTemLast)
    iWordBegin = 1
    iWordEnd = 1
    For i = 1 To iLen
        
        strTem = Mid(strTemLast, i, 1)
        'iWordEnd = i - 1
        If strTem = "+" Or strTem = "-" Or i = iLen Then
            strTem = Mid(strTemLast, iWordBegin, i - iWordBegin + 1)
            strTem = IIf(Right(strTem, 1) = "+" Or Right(strTem, 1) = "-", Left(strTem, Len(strTem) - 1), strTem)
            codeColl.Add strTem
            iWordBegin = i + 1
        End If
    Next
    
    '验公式是否合法
    For i = 1 To codeColl.count
        bOK = False
        For j = 0 To LstCodeList.ListCount
            strTem2 = Trim(Left(LstCodeList.List(j), 20))
            Debug.Print codeColl.item(i)
            If codeColl.item(i) = strTem2 Then
                bOK = True
                Exit For
            End If
            
        Next
        If bOK = False Then
            CheckExp = bOK
            txtExp.SetFocus
            '----------------------------------------------------------
            '此处代码有待改进，
            'i的值为不合法的科目位置，如i=2则第二个科目不合法。
            '找出第(i-1)个符号与第i个符号之间的字符串，就为不合法字符串
            '“符号”指“+”或“-”
            txtExp.SelStart = InStr(1, strTemLast, codeColl.item(i)) - 1
            txtExp.SelLength = Len(codeColl.item(i))
            '---------------------------------------------------
            Exit Function
        End If
    Next
    CheckExp = bOK
End Function

Private Sub FullCodeList()
    Dim strSql As String
    Dim strCodeList As String
    strSql = "SELECT cCode,cClass,cName,EndFlag,cGrade FROM Cwzz_AccCode ORDER BY cCode"
    Set CodeListRs = Cw_DataEnvi.DataConnect.Execute(strSql)
    LstCodeList.Clear
    '格式化字符串
    With CodeListRs
        Do Until .EOF
            strCodeList = Trim(CodeListRs!cCode)
            strCodeList = strCodeList & Space(20 - Len(strCodeList))
            strCodeList = strCodeList & Trim(CodeListRs!cName)
            LstCodeList.AddItem strCodeList
            .MoveNext
        Loop
    End With
End Sub
Private Function ExpTranslate(ByVal bWay As Boolean, ByVal strExp As String) As String
    '公式解析过程序，参数bWay为TRUE则为正向解析，由科目代码->文字
    '                          FALSE 为反向解析，由文字->科目代码
    'strExp 为传递的公式字符串
    
    
    ExpTranslate = strExp
End Function
'=================自定义程序结束====================================
Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    CodeListRs.Close
    Set CodeListRs = Nothing
End Sub

Private Sub lstCodeList_Click()
    Dim strTem As String
    strTem = Right(LstCodeList.List(LstCodeList.ListIndex), Len(LstCodeList.List(LstCodeList.ListIndex)) - 20)
    labList.Caption = strTem
End Sub

Private Sub lstCodeList_DblClick()
    Dim strTem As String
    Dim iWhere As Integer '用于截取字符
    Dim strSign As String  '符号，+ 或 - 或 ""
    If LstCodeList.ListIndex = -1 Then Exit Sub
    iWhere = InStr(1, LstCodeList.List(LstCodeList.ListIndex), " ") - 1
    strTem = Left(LstCodeList.List(LstCodeList.ListIndex), iWhere)
    If Trim(txtExp.Text) = "" Then
        strSign = ""
    ElseIf OptAdd.Value = True Then
        strSign = "+"
    ElseIf OptAdd.Value = False Then
        strSign = "-"
    End If
    
    txtExp.Text = txtExp.Text & strSign & strTem
End Sub

Private Sub lstCodeList_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        Call lstCodeList_DblClick
    End If
End Sub

Private Sub txtExp_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case 13
            Call cmdOK_Click
    End Select
End Sub