发信人: 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
'////////////////////////////////////////////////////////////////////////////////////
----
不想计较得失，却总在计较得失 |
|