mdlcalculate.bas

本系统可用于医院和专业体检中心的健康体检管理

                                MsgBox "表达式 “" & strValue & "” 缺少运算符！", vbInformation, "提示"
                            End If
                            GoTo ExitLab
                        Else
                            '是数值型项目
                            strRet_Show = strRet_Show & strValue
                            strRet_Database = strRet_Database & EXPRESSIONHEADER & rstemp("XXID") & EXPRESSIONHEADER
                        End If
                    End If
                Else
                    '是数字
                    strRet_Show = strRet_Show & strValue
                    strRet_Database = strRet_Database & strValue
                End If
                
                '跟上后面的运算符
                strRet_Show = strRet_Show & strChar
                strRet_Database = strRet_Database & strChar
                
                i = j: j = 0
            End If
        End If
    Next K
    
    '去掉最新加上去的括号
    strRet_Show = Mid(strRet_Show, 2, Len(strRet_Show) - 2)
    strRet_Database = Mid(strRet_Database, 2, Len(strRet_Database) - 2)
    strExpression = strRet_Database
    CheckExpression = strRet_Show
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'检查指定字符串里面是否含有非数字字符
'如果有，则直接返回
'否则转换为数值型
Private Function CheckNumeric(ByRef strValue As String) As Boolean
    Dim i As Integer
    Dim blnHave As Boolean '是否含有非数字字符
    Dim strChar As String
    
    For i = 1 To Len(strValue)
        strChar = Mid(strValue, i, 1)
        If Not IsNumeric(strChar) Then
            If strChar <> "." Then
                blnHave = True
                Exit For
            End If
        End If
    Next
    
    If blnHave Then
        CheckNumeric = False '含有非数字字符
    Else
        CheckNumeric = True '数值型
        strValue = Val(strValue)
    End If
End Function

'根据指定表达式计算
Public Function CalculateValueByString(GS As String) As String
On Error GoTo ErrMsg
    Dim Status
    Dim i, n As Integer
    Dim TempGs, Temp As String
    Dim Vl() As String '操作数
    Dim Vls As Integer '操作数的数目
    Dim Si As Integer '上一操作符的位置
    Dim Ads, Sus, Mus, Bys, Lks, Rks As Integer     '操作符的数目
    Dim Adp(), Mup(), Byp(), Lkp(), Rkp() As Integer '操作符的位置
    Dim Adn(), Mun(), Byn() As Integer '操作符的排列次序
    Dim Sig() As Integer '每一个操作符的位置

    Do While True
        ReDim Adp(Len(GS)), Mup(Len(GS)), Byp(Len(GS)) _
            , Lkp(Len(GS)), Rkp(Len(GS)) As Integer
        ReDim Adn(Len(GS)), Mun(Len(GS)), Byn(Len(GS)) _
            , Lkn(Len(GS)), Rkn(Len(GS)), Sig(Len(GS)) As Integer
        
        ReDim Vl(Len(GS))
        
        If Len(GS) = 0 Then GoTo ErrMsg
        If Mid(GS, Len(GS), 1) <> "#" Then
        
            TempGs = GS
            For i = 1 To Len(GS) '将减化加
                
                If Mid(GS, i, 1) = "-" And i <> 1 Then
                    If Mid(GS, i - 1, 1) <> "+" And Mid(GS, i - 1, 1) <> "-" _
                        And Mid(GS, i - 1, 1) <> "*" And Mid(GS, i - 1, 1) <> "/" Then
                        TempGs = Mid(TempGs, 1, i - 1 + n) + "+" + Mid(GS, i)
                        n = n + 1
                    End If
                    
                End If
            Next i
            GS = TempGs
            
            n = 0
            For i = 1 To Len(GS) '处理负负得正
                If Mid(GS, i, 1) = "-" Then
                    If Mid(GS, i + 1, 1) = "-" Then
                        TempGs = Mid(TempGs, 1, i - 1 - n) + Mid(GS, i + 2)
                        n = n + 2
                    End If
                End If
            Next i
            GS = TempGs
            GS = GS + "#"
        End If
        
        Vls = 1
        Ads = 0: Sus = 0: Mus = 0: Bys = 0: Lks = 0: Rks = 0
        
        For i = 1 To Len(GS)
            
            Select Case Mid(GS, i, 1)
                Case "+"
                    Ads = Ads + 1
                    Adp(Ads) = i
                    Adn(Ads) = Vls
                Case "*"
                    Mus = Mus + 1
                    Mup(Mus) = i
                    Mun(Mus) = Vls
                Case "/"
                    Bys = Bys + 1
                    Byp(Bys) = i
                    Byn(Bys) = Vls
                Case "("
                    Lks = Lks + 1
                    Lkp(Lks) = i
                   
                Case ")"
                    Rks = Rks + 1
                    Rkp(Rks) = i
                    
            End Select
            
            If Mid(GS, i, 1) = "+" Or Mid(GS, i, 1) = "*" Or _
                Mid(GS, i, 1) = "/" Or Mid(GS, i, 1) = "#" Then
                
'                If Si + 1 = i And Mid(GS, i + 1, 1) <> "#" _
'                        Then '操作符非法连续或以操作符开头
'                    GoTo ErrMsg
'                Else
'                    If Mid(GS, i + 1, 1) <> "#" Then '原来的算法没有这一行判断
'                        Si = i
'                    End If
'                End If
                
                If Not IsNumeric(Vl(Vls)) And Mid(GS, i + 1, 1) <> "#" _
                        Then '操作数不是数字
                    GoTo ErrMsg
                End If
                Sig(Vls) = i
                Vls = Vls + 1
                
            Else
                If Mid(GS, i, 1) <> "(" And Mid(GS, i, 1) <> ")" Then
                    Vl(Vls) = Vl(Vls) + Mid(GS, i, 1) '制作操作数
                Else
                    If i <> 1 Then
                        If ((Mid(GS, i - 1, 1) = "(" And Mid(GS, i, 1) = ")") Or _
                                (Mid(GS, i - 1, 1) = ")" And Mid(GS, i, 1) = "(")) _
                                Then '判定括号前后符号的合法性
                            GoTo ErrMsg
                        End If
                    End If
                End If
            End If
            
        Next i
        
        If Lks <> Rks Then
            GoTo ErrMsg '左右括号数是否匹配
        End If
        
        For i = 1 To Lks
            If Lkp(i) > Rkp(i) Then GoTo ErrMsg '左右括号出现顺序错误
        Next i
        
        If Lks <> 0 Then '括号处理
            Do While True
                For i = Lks To 1 Step -1
                    For n = Rks To 1 Step -1
                        Temp = CalculateValueByString(Mid(GS, Lkp(i) + 1, Rkp(n) - Lkp(i) - 1))
                        If Temp <> "" Then
                            GS = Mid(GS, 1, Lkp(i) - 1) + Temp + Mid(GS, Rkp(n) + 1)
                            Exit Do
                        End If
                    Next n
                Next i
                If Temp = "" Then GoTo ErrMsg
                '括号中有错误退出
            Loop
        Else
            If Mus <> 0 Then '乘法处理
                GS = Mid(GS, 1, Sig(Mun(1) - 1)) + Trim(str(Val(Vl(Mun(1))) _
                    * Val(Vl(Mun(1) + 1)))) + Mid(GS, Val(Mup(1)) + Len(Vl(Mun(1) _
                    + 1)) + 1)
            Else
                If Bys <> 0 Then '除法处理
                    GS = Mid(GS, 1, Sig(Byn(1) - 1)) + Trim(str(Val(Vl(Byn(1))) _
                        / Val(Vl(Byn(1) + 1)))) + Mid(GS, Val(Byp(1)) + Len(Vl(Byn(1) _
                        + 1)) + 1)
                Else
                    If Ads <> 0 Then '加法处理
                        GS = Trim(str(Val(Vl(1)) + Val(Vl(2)))) + Mid(GS, Val(Adp(1)) _
                            + Len(Vl(2)) + 1)
                    Else
                        CalculateValueByString = Mid(GS, 1, Len(GS) - 1)
'                        GoSub ChangeResult
'                        CalculateValueByString = strTemp
                        GoTo ExitLab
                    End If
                End If
            End If
        End If
    Loop
        
ErrMsg:
'    MsgBox "表达式错误！", vbInformation, "提示"
    CalculateValueByString = ""
ExitLab:
    '
End Function