企业管理

开发平台：
Visual Basic

+：源码内容
							VERSION 5.00
Begin VB.Form JC_Expressions 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "公式选定"
   ClientHeight    =   3075
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5550
   Icon            =   "基础设置_公式选定.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3075
   ScaleWidth      =   5550
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin VB.OptionButton OptUnAdd 
      Caption         =   "减项"
      Height          =   375
      Left            =   4620
      TabIndex        =   8
      Top             =   1665
      Width           =   840
   End
   Begin VB.OptionButton OptAdd 
      Caption         =   "加项"
      Height          =   270
      Left            =   4650
      TabIndex        =   7
      Top             =   1035
      Value           =   -1  'True
      Width           =   810
   End
   Begin VB.TextBox txtExp 
      Height          =   315
      Left            =   60
      TabIndex        =   5
      Top             =   2235
      Width           =   5385
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "取消(&C)"
      Height          =   300
      Left            =   4335
      TabIndex        =   4
      Top             =   2700
      Width           =   1120
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定(&O)"
      Height          =   300
      Left            =   3120
      TabIndex        =   3
      Top             =   2700
      Width           =   1120
   End
   Begin VB.CommandButton cmdSel 
      Caption         =   "选定"
      Height          =   300
      Left            =   4425
      TabIndex        =   2
      Top             =   375
      Width           =   1035
   End
   Begin VB.ListBox LstCodeList 
      Height          =   1500
      ItemData        =   "基础设置_公式选定.frx":1042
      Left            =   60
      List            =   "基础设置_公式选定.frx":1049
      TabIndex        =   1
      Top             =   360
      Width           =   4290
   End
   Begin VB.Label labList 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "---------------"
      Height          =   180
      Left            =   615
      TabIndex        =   6
      Top             =   75
      Width           =   1350
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "科目："
      Height          =   180
      Left            =   60
      TabIndex        =   0
      Top             =   75
      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
'*************************************************************
'*    模 块 名 称 :基础设置公式选定
'*    功 能 描 述 :提供生成公式
'*    程序员姓名  : 魏永生
'*    最后修改人  :
'*    最后修改时间:2002/01/21
'*    备        注:
'*    提供生成公式：公式设定方法：
'*    系统提示总帐系统的会计科目和编码，用户选择相应的编码确定计算公式。
'*************************************************************
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
        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)
        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

						