精华区 [关闭][返回]

当前位置:网易精华区>>讨论区精华>>编程开发>>● VB和Basic>>Re:那么热闹,我也来一个

主题:Re:那么热闹,我也来一个
发信人: lzzzl(lzzzl)
整理人: winsy(2004-06-30 15:18:16), 站内信件
Option Explicit
'////////////////////////////////////////////////////////////////////////////////////
'算术器
'概念及相互间的包含关系
    '字符:              a,b,c,d,...1,2,3,...+,-,*,/
    '数元:              1,2,123,...,a,b,ab,...
    '符元:              +,-,*,/
    '元素:              数元或符元
    '实体:              括号内的表达式
    '单元:              元素或实体
    '多元表达式:                        有操作符的表达式
    '表达式:            这里指的是数学表达式
'////////////////////////////////////////////////////////////////////////////////////
Public gErrFlag As Boolean
Public gErrMsg As String
'Default Property Values:
Const m_def_ErrMsg = "<运行时只读>"
Const m_def_CanCal = False
Const m_def_BackColor = 0
Const m_def_ForeColor = 0
Const m_def_Enabled = 0
Const m_def_BackStyle = 0
Const m_def_BorderStyle = 0
Const m_def_Formulation = ""
Const m_def_Value = 0
'Property Variables:
Dim m_ErrMsg As String
Dim m_CanCal As Boolean
Dim m_BackColor As Long
Dim m_ForeColor As Long
Dim m_Enabled As Boolean
Dim m_Font As Font
Dim m_BackStyle As Integer
Dim m_BorderStyle As Integer
Dim m_Formulation As String
Dim m_Value As Single
'Event Declarations:
Event Click()
Event DblClick()
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

Private Sub UserControl_Resize()
    On Error Resume Next
    Image1.Left = 0
    Image1.Top = 0
    Image1.Stretch = True
    UserControl.Width = Image1.Width
    UserControl.Height = Image1.Height
End Sub

Public Property Get BackColor() As Long
    BackColor = m_BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As Long)
    m_BackColor = New_BackColor
    PropertyChanged "BackColor"
End Property

Public Property Get ForeColor() As Long
    ForeColor = m_ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As Long)
    m_ForeColor = New_ForeColor
    PropertyChanged "ForeColor"
End Property

Public Property Get Enabled() As Boolean
    Enabled = m_Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    m_Enabled = New_Enabled
    PropertyChanged "Enabled"
End Property

Public Property Get Font() As Font
    Set Font = m_Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set m_Font = New_Font
    PropertyChanged "Font"
End Property

Public Property Get BackStyle() As Integer
    BackStyle = m_BackStyle
End Property

Public Property Let BackStyle(ByVal New_BackStyle As Integer)
    m_BackStyle = New_BackStyle
    PropertyChanged "BackStyle"
End Property

Public Property Get BorderStyle() As Integer
    BorderStyle = m_BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    m_BorderStyle = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property

Public Sub Refresh()
     
End Sub

Public Property Get Formulation() As String
    Formulation = m_Formulation
End Property

Public Property Let Formulation(ByVal New_Formulation As String)
    m_Formulation = New_Formulation
    PropertyChanged "Formulation"
    If Trim(Me.Formulation) = "" Then Exit Property
    '仅设计时及时检查表达式
    If Ambient.UserMode Then Exit Property
    If Not CheckFml(Trim(Me.Formulation)) Then
        Me.ErrMsg = "表达式不正确"
    End If
End Property

Public Property Get Value() As Single
    Value = m_Value
End Property

Public Property Let Value(ByVal New_Value As Single)
    If Ambient.UserMode = False Then Exit Property
    m_Value = New_Value
    PropertyChanged "Value"
End Property

'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    On Error Resume Next
    m_BackColor = m_def_BackColor
    m_ForeColor = m_def_ForeColor
    m_Enabled = m_def_Enabled
    Set m_Font = Ambient.Font
    m_BackStyle = m_def_BackStyle
    m_BorderStyle = m_def_BorderStyle
    m_Formulation = m_def_Formulation
    m_Value = m_def_Value
    m_CanCal = m_def_CanCal
    m_ErrMsg = m_def_ErrMsg
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    On Error Resume Next
    m_BackColor = PropBag.ReadProperty("BackColor", m_def_BackColor)
    m_ForeColor = PropBag.ReadProperty("ForeColor", m_def_ForeColor)
    m_Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled)
    Set m_Font = PropBag.ReadProperty("Font", Ambient.Font)
    m_BackStyle = PropBag.ReadProperty("BackStyle", m_def_BackStyle)
    m_BorderStyle = PropBag.ReadProperty("BorderStyle", m_def_BorderStyle)
    m_Formulation = PropBag.ReadProperty("Formulation", m_def_Formulation)
    m_Value = PropBag.ReadProperty("Value", m_def_Value)
    m_CanCal = PropBag.ReadProperty("CanCal", m_def_CanCal)
    m_ErrMsg = PropBag.ReadProperty("ErrMsg", m_def_ErrMsg)
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    On Error Resume Next
    Call PropBag.WriteProperty("BackColor", m_BackColor, m_def_BackColor)
    Call PropBag.WriteProperty("ForeColor", m_ForeColor, m_def_ForeColor)
    Call PropBag.WriteProperty("Enabled", m_Enabled, m_def_Enabled)
    Call PropBag.WriteProperty("Font", m_Font, Ambient.Font)
    Call PropBag.WriteProperty("BackStyle", m_BackStyle, m_def_BackStyle)
    Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, m_def_BorderStyle)
    Call PropBag.WriteProperty("Formulation", m_Formulation, m_def_Formulation)
    Call PropBag.WriteProperty("Value", m_Value, m_def_Value)
    Call PropBag.WriteProperty("CanCal", m_CanCal, m_def_CanCal)
    Call PropBag.WriteProperty("ErrMsg", m_ErrMsg, m_def_ErrMsg)
End Sub

Public Property Get CanCal() As Boolean
    If Trim(Me.Formulation) = "" Then
        CanCal = False
        Me.ErrMsg = "缺少表达式"
        Exit Property
    End If
    If Not CheckFml(Trim(Me.Formulation)) Then
        CanCal = False
        Me.ErrMsg = "表达式不正确"
        Exit Property
    End If
    gErrMsg = ""
    gErrFlag = True
    Me.Value = CalStr(Trim(Me.Formulation))
    CanCal = gErrFlag
    Me.ErrMsg = gErrFlag
End Property

Public Property Let CanCal(ByVal New_CanCal As Boolean)
    If Ambient.UserMode = False Then Exit Property
    m_CanCal = New_CanCal
    PropertyChanged "CanCal"
End Property

Public Property Get ErrMsg() As String
    ErrMsg = m_ErrMsg
End Property

Public Property Let ErrMsg(ByVal New_ErrMsg As String)
    If Ambient.UserMode = False Then Exit Property
    m_ErrMsg = New_ErrMsg
    PropertyChanged "ErrMsg"
End Property

'////////////////////////////////////////////////////////////////////////////////////

Private Function CalStr(St As String)
    '计算入口,本函数把一个公式看成 S1 Pre S2 Stuff S3 的模型,
    '其中 Pre, Stuff 表示四则运算符,而 Si 本身也可以是一个子模型。
    '通过比较 Pre 和 Stuff 的优先级进行组合计算
     Dim s(3) As Single
     Dim L As Integer
     Dim Pre As String
     Dim Stuff As String
     Dim StMid As String
     
     L = Len(St)
     '取得一个单元,注释见子程序
     StMid = GetItem(St, L)
     s(1) = Val(StMid)
     If L = 0 Then
        '字串已处理完毕
        CalStr = s(1)
        Exit Function
     End If
     Pre = GetItem(St, L)
     StMid = GetItem(St, L)
     s(2) = Val(StMid)
     If L = 0 Then
        CalStr = Cal2(s(1), s(2), Pre)
        Exit Function
     End If
    
     While True
        Stuff = GetItem(St, L)
        StMid = GetItem(St, L)
        s(3) = Val(StMid)
        '表达式是否已取尽,则可按优先级完成计算,否则只能计算一步
        If L = 0 Then
           If (Stuff = "*" Or Stuff = "/") And (Pre = "+" Or Pre = "-") Then
                '仅当 Pre 劣 Stuff 优时才向后先组合
               s(2) = Cal2(s(2), s(3), Stuff)
               s(1) = Cal2(s(1), s(2), Pre)
           Else
               s(2) = Cal2(s(1), s(2), Pre)
               s(1) = Cal2(s(2), s(3), Stuff)
           End If
           CalStr = s(1)
           Exit Function
        Else
           If Pre = "*" Or Pre = "/" Then
               '前导符优先,则把前两个数计算的结果作为下一轮计算的第一个数
               s(1) = Cal2(s(1), s(2), Pre)
               s(2) = s(3)
               Pre = Stuff
           Else
               If Stuff = "+" Or Stuff = "-" Then
                   s(1) = Cal2(s(1), s(2), Pre)
                   s(2) = s(3)
                   Pre = Stuff
               Else
                   s(2) = Cal2(s(2), s(3), Stuff)
               End If
           End If
        End If
     Wend
End Function

Private Function Cal2(a As Single, b As Single, Op As String)
    '计算两个数的四则运算结果
    Select Case Op
    Case "+"
        Cal2 = a + b
    Case "-"
        Cal2 = a - b
    Case "*"
        Cal2 = a * b
    Case "/"
        If b = 0 Then
            gErrFlag = True
            gErrMsg = "除数为零"
            Cal2 = 0
        Else
            Cal2 = a / b
        End If
    Case Else
        Cal2 = 0
        gErrFlag = True
        gErrMsg = "无法运算"
    End Select
End Function

Private Function GetItem(St As String, L As Integer)
    '功能:取得一个单元。“单元”常常是一个元素或一个实体
    Dim NewSt As String
    Dim CalMid As Single
    
    '空串不处理
    If L = 0 Then Exit Function
    If Left(St, 1) = "(" Then
        '左括号表示实体的开始
        L = L - 1
        St = Right(St, L)
        NewSt = GetRealBody(St, L)
        '取得一个实体,并把实体作为递归(间接)参数,其结果是一个数元
        CalMid = CalStr(NewSt)
        GetItem = Str(CalMid)
    Else
        '取得一个元素,注释见子程序
        GetItem = GetNumeric(St, L)
    End If
End Function

Private Function GetNumeric(St, L)
    '取得一个元素。“元素”是不能分割的一个操作数(数元)或操作符(符元),如a,ab,1,123,+,-,*,/
    Dim ReSt As String
    Dim NewChar As String
    Dim LL As Integer
    Dim i As Integer
    
    ReSt = Left(St, 1)
    St = Right(St, L - 1)
    L = L - 1
    If L = 0 Then
        '字串已处理完毕
        GetNumeric = ReSt
        Exit Function
    End If
    If InStr("+-*/()", ReSt) > 0 Then
        '返回符元
        GetNumeric = ReSt
        Exit Function
    End If
    LL = L
    For i = 1 To LL
        NewChar = Left(St, 1)
        If InStr("+-*/()", NewChar) > 0 Then Exit For
        ReSt = ReSt + NewChar
        St = Right(St, L - 1)
        L = L - 1
    Next i
    '返回数元
    GetNumeric = ReSt
End Function

Private Function GetRealBody(St As String, L As Integer)
    '取得一个实体。实体是一对括号内的表达式(不包括左、右括号)
    '进入本函数的前提是出现了左括号,
    '故本函数一直取到单元结束符右括号为止
    '注意:可能有嵌套的情况,这时要把内层看作一个新的算式
    Dim GetTemp As String
    Dim i As Integer
    
    GetTemp = ""
    For i = 1 To L
        If Left(St, 1) = ")" Then
            L = L - 1
            St = Right(St, L)
            GetRealBody = GetTemp
            Exit Function
        ElseIf Left(St, 1) = "(" Then
            L = L - 1
            St = Right(St, L)
            GetTemp = GetTemp & CalStr(GetRealBody(St, L))
        Else
            GetTemp = GetTemp + Left(St, 1)
            L = L - 1
            St = Right(St, L)
        End If
    Next i
End Function

Private Function DelSpace(ByVal strExp As String)
    '删除空格
    Dim L As Integer
    Dim i As Integer
    Dim strRest As String
    Dim NewChar As String
    
    strExp = Trim(strExp)
    L = Len(strExp)
    strRest = strExp
    strExp = ""
    For i = 1 To L
        NewChar = Left(strRest, 1)
        If i < L Then strRest = Right(strRest, L - i)
If NewChar <> " " Then
            strExp = strExp & NewChar
        End If
    Next
    DelSpace = strExp
End Function

Private Function Check2(Pre As String, Stuff As String)
    '检查相邻两个字符是否合理放置
    '参数 Per 与 Stuff 表示相邻的两个字符,一前一后
    Select Case Pre
    Case "+", "-", "*", "/"
        If InStr("+-*/", Stuff) > 0 Then
            Check2 = False
            Exit Function
        End If
    Case "("
        If InStr(")*/", Stuff) > 0 Then
            Check2 = False
            Exit Function
        End If
    Case ")"
        If InStr("abcdABCD(", Stuff) > 0 Then
            Check2 = False
            Exit Function
        End If
    Case Else
    'Case "a", "b", "c", "c", "A", "B", "C", "D"大多数字符后面不直接连符号 (
        If InStr("(", Stuff) > 0 Then
            Check2 = False
            Exit Function
        End If
    End Select
    Check2 = True
End Function

Private Function CheckFml(St As String) As Boolean
    '检查公式正确性
    Dim Brackets As Integer '左右括号对消结果统计
    Dim Pre As String
    Dim Stuff As String
    Dim i As Integer
    Dim L As Integer
    
    L = Len(St)
    '1 公式长度不能小于3。“公式”最少有两个操作数和一个操作符,故元素在这里不看成公式
    If L = 0 Or L = 2 Then
        CheckFml = False
    End If
    
    Pre = Left(St, 1)
    '2 公式不能由以下字符开头: ) *  /
    If InStr(")*/", Pre) > 0 Then
        CheckFml = False
        Exit Function
    End If
    
    Stuff = Right(St, 1)
    '3 公式不能由以下字符结尾:  + - *  / (
    If InStr("+-*/(", Stuff) > 0 Then
        CheckFml = False
        Exit Function
    End If
    
    Brackets = 0
    Pre = Left(St, 1)
    '遇左括号,统计结果加一;遇右括号,统计结果减一
    If Pre = "(" Then Brackets = Brackets + 1
    For i = 2 To L
         Stuff = Mid(St, i, 1)
         If Stuff = "(" Then Brackets = Brackets + 1
         If Stuff = ")" Then Brackets = Brackets - 1
        '4 任何时候统计结果都不能小于0,因为左括号总比右括号先出现
         If Brackets < 0 Then
CheckFml = False
Exit Function
End If
'5 判断相邻两个字符是否合理放置
If Check2(Pre, Stuff) = False Then
CheckFml = False
Exit Function
End If
Pre = Stuff
Next i
'6最后统计结果应为0,因为括号总是成双出现的
If Brackets <> 0 Then
        CheckFml = False
        Exit Function
    End If
    CheckFml = True
End Function
'////////////////////////////////////////////////////////////////////////////////////




----
不想计较得失,却总在计较得失     

[关闭][返回]