mdlcalculate.bas

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

Attribute VB_Name = "mdlCalculate"
Option Explicit
Public Enum ItemType
    SHUOMING = 0
    SHUZHI = 1
    YINYANG = 2
    JISUAN = 3
End Enum

'根据数据库里面存放的表达式返回计算型项目的值
'该函数将首先验证表达式是否合法，即验证表达式中涉及的项目都仍存在
Public Function CalculateByString(ByVal strInput As String, ByVal lngGUID As Long, _
        ByRef CmbInfo As Object)
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strRet_Show As String
    Dim strRet_Database As String
    Dim intPos As Integer
    Dim i As Integer, j As Integer, K As Integer
    Dim intIndex As Integer
    Dim strExpression As String '该变量存放的表达式用于提交给脚本计算返回值
    Dim strXMID As String
    Dim strChar As String
    Dim strValue As String
    
    Dim intTmp As Integer
    Dim strTemp As String
    Dim intEpos As Integer

    Screen.MousePointer = vbHourglass
    intPos = InStr(1, strInput, ",")
    strRet_Show = Left(strInput, intPos - 1)
    strRet_Database = Mid(strInput, intPos + 1)
    '首先验证表达式是否仍然合法
    If CheckExpression(strRet_Show, "", False) = "" Then GoTo ExitLab
    
    i = 0: j = 0
    For K = 1 To Len(strRet_Database)
        strChar = Mid(strRet_Database, K, 1)
        If strChar = EXPRESSIONHEADER Then
            If i = 0 Then
                i = K
            Else
                j = K
            End If
            
            If j > 0 Then
                '说明已经取到了项目
                strXMID = Mid(strRet_Database, i + 1, j - i - 1)
                
                '首先检索当前录入，查看是否有匹配记录
                For intIndex = CmbInfo.LBound To CmbInfo.UBound
                    If CmbInfo(intIndex).Tag = strXMID Then
                        strValue = Trim(CmbInfo(intIndex).Text)
                        Exit For
                    End If
                Next intIndex
                
                '如果在当前录入中没有找到输入，则检索数据库中是否有记录
                If strValue = "" Then
                    strSQL = "select SET_DX.DXID,XXPYSX,SET_XX.XXID,XXMC" _
                            & " from SET_XX,SET_ZH_Data,SET_DX" _
                            & " where SET_XX.XXID='" & strXMID & "'" _
                            & " and SET_XX.XXID=SET_ZH_Data.XXID" _
                            & " and SET_ZH_Data.DXID=SET_DX.DXID"
                    Set rstemp = New ADODB.Recordset
                    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                    '前面已验证过表达式，项目肯定存在，所以无需再检查是否存在记录
                    rstemp.MoveFirst
                    For i = 1 To rstemp.RecordCount
                        '函数GetExistResult可以取出所有可能存在的值，所以无需循环
                        strValue = GetExistResult(lngGUID, rstemp("DXID"), rstemp("XXPYSX"), rstemp("XXID"), True)
                        If strValue <> "" Then '取得体检值即退出循环
                            Exit For
                        Else
                            MsgBox "计算型表达式中包含的项目 “" & rstemp("XXMC") & _
                                "” 尚未检查，无法计算当前项目的体检值！", vbInformation, "提示"
                            GoTo ExitLab
                        End If
                        
                        rstemp.MoveNext
                    Next i
                    
                    rstemp.Close
                End If
                
                '取回了体检值
                strExpression = strExpression & strValue
                
                i = 0: j = 0
            End If
        Else
            If i = 0 Then
                strExpression = strExpression & strChar
            End If
        End If
    Next K
    
    '表达式已构造完毕
    '调用脚本计算
    CalculateByString = CalculateValueByString(strExpression)
    
    '如果结果中含有"E",说明为指数形式，需要变为小数
    intEpos = InStr(1, CalculateByString, "E", vbTextCompare)
    strTemp = ""
    If intEpos > 1 Then
'        strTemp = Mid(CalculateByString, intEpos + 1, Len(CalculateByString) - intEpos)
'        If Mid(strTemp, 1, 1) = "-" Then    '是负数
'            intTmp = CInt(Mid(strTemp, 2, Len(strTemp) - 1))
'            strTemp = Mid(CalculateByString, 1, intEpos - 1)
'            strTemp = strDelSpeStr(strTemp, ".")
'            For i = 1 To intTmp
'                strTemp = 0 & strTemp
'            Next
'            strTemp = strAddSpeStr(strTemp, intTmp - 1, ".")
'        ElseIf Mid(strTemp, 1, 1) = "+" Then
'            intTmp = CInt(Mid(strTemp, 2, Len(strTemp) - 1))
'            strTemp = Mid(CalculateByString, 1, intEpos - 1)
'            '将小数点右移intTmp位
'            strTemp = RightShiftSpeStr(strTemp, intTmp)
'        End If
        strTemp = ChangeStrToE(CalculateByString)
    End If
    
    If strTemp <> "" Then
        CalculateByString = strTemp
    ElseIf Len(CalculateByString) > 10 _
            And InStr(1, CalculateByString, ".", vbTextCompare) = 0 Then    '计算出一个大整数
        CalculateByString = Mid(strAddSpeStr(CalculateByString, 1, "."), 1, 5) & "E+" & Len(CalculateByString) - 1
    ElseIf InStr(1, CalculateByString, ".", vbTextCompare) = 10 Then
        CalculateByString = Mid(CalculateByString, 1, 9)
    ElseIf InStr(1, CalculateByString, ".", vbTextCompare) > 10 Then
        intEpos = InStr(1, CalculateByString, ".", vbTextCompare)
        strTemp = Mid(CalculateByString, 1, intEpos - 1)
        strTemp = strAddSpeStr(strTemp, 1, ".")
        strTemp = Mid(strTemp, 1, 5) & "E+" & intEpos - 2
        CalculateByString = strTemp
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'校验指定表达式是否符合要求
'返回值：""，表示失败
'       <>""，表示成功
Public Function CheckExpression(ByRef strExpression As String, _
        ByVal strLawlessValue As String, ByVal blnCheckAgain As Boolean) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer, j As Integer, K As Integer
    Dim intLeft As Integer, intRight As Integer '左右括号的数量
    Dim strOperator As String
    Dim strChar As String
    Dim strValue As String
    Dim strRet_Show As String
    Dim strRet_Database As String
    Dim strXMID As String
    
    Screen.MousePointer = vbHourglass
    strOperator = "+-*/()" '涉及的运算符
    
    '为了后面便于处理，在表达式前后加上括号
    strExpression = "(" & strExpression & ")"
    
    '第一步：校验括号是否成对
    '取得左括号数量
    i = 0: j = 0
    Do
        i = InStr(i + 1, strExpression, "(")
        intLeft = intLeft + 1
    Loop Until i = 0
    '取得右括号数量
    Do
        j = InStr(j + 1, strExpression, "(")
        intRight = intRight + 1
    Loop Until j = 0
    '是否相等
    If intRight <> intLeft Then
        MsgBox "左括号和右括号的数量不等，请仔细核对！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '第二步：取得每两个运算符之间的变量
    i = 0: j = 0
    For K = 1 To Len(strExpression)
        strChar = Mid(strExpression, K, 1)
        If InStr(1, strOperator, strChar) > 0 Then
            If (i = 0) And (j = 0) Then
                i = K
            Else
                If K = i + 1 Then
                    i = K
                Else
                    j = K
                End If
            End If
            
            If j = 0 Then
                strRet_Show = strRet_Show & strChar
                strRet_Database = strRet_Database & strChar
            End If
            If (i > 0) And (j > 0) Then
                '取出两个运算符之间的变量
                strValue = Mid(strExpression, i + 1, j - i - 1)
                If CheckNumeric(strValue) = False Then
                    '说明是项目名称
                    '首先检查是否非法字符串
                    If strValue = strLawlessValue Then
                        MsgBox "您输入了非法项目 “" & strLawlessValue & "”", vbInformation, "提示"
                        GoTo ExitLab
                    End If
                    
                    '检查数据库里面是否有该项目名称
                    strSQL = "select XXID,XXType from SET_XX" _
                            & " where XXMC='" & strValue & "'"
                    Set rstemp = New ADODB.Recordset
                    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                    If rstemp.RecordCount = 0 Then
                        MsgBox "表达式 “" & strValue & "” 不是已设置的项目！", vbInformation, "提示"
                        GoTo ExitLab
                    Else
                        If rstemp("XXType") <> 1 Then
                            If Not blnCheckAgain Then
                                MsgBox "表达式 “" & strValue & "” 不是数值型项目，不能作为计算型变量！", vbInformation, "提示"
                            Else