匿名用户
1级
2008-07-01 回答
我没有2000系统中的那个计算器，但是我有我自己写的一个，源码给你吧！
Option Explicit
Const PI = 3.14159265358979
Const e = 2.71828182845905
Dim Express As String
Dim expr As String
Private Function Operate(Woperate As String, a As Double, b As Double) As Double
On Error GoTo myerr
Select Case Woperate
Case "+"
Operate = a + b
Case "-"
Operate = a - b
Case "*"
Operate = a * b
Case "/"
Operate = a / b
Case "^"
Operate = a ^ b
End Select
myerr: If Err <> 0 Then MsgBox Error: Exit Function
End Function
Private Function InstrAsc(Wstring As String, START As Long, UAscii As Integer, LAscii As Integer) As Long
Dim a As Long
Dim b As String
Dim lenth As Long
lenth = Len(Wstring)
For a = START To lenth
b = Mid(Wstring, a, 1)
If Asc(b) < UAscii + 1 And Asc(b) > LAscii - 1 Then InstrAsc = a: Exit For
Next
If a > lenth Then InstrAsc = 0
End Function
Private Function Compute(WExpress As String) As Double
Dim a As Double
Dim b As Double
Dim i As Long
Dim l As Long
Dim r As Long
Dim answer As Double
Dim temp As Long
Dim Express As String
Dim isfunc As Boolean
Express = WExpress
Dim lenth As Long
'lenth = Len(express)
Dim ex As String
Dim fun As String
'''''''^
Do
For i = Len(Express) To 1 Step -1
ex = Mid(Express, i, 1)
If ex = "^" Then
FindNum Express, i, a, b, l, r
answer = Operate(ex, a, b)
Express = Mid(Express, 1, l - 1) & CStr(answer) & Mid(Express, r + 1)
Exit For
End If
Next
Loop Until i = 0
''''''Function
Do
fun = ""
isfunc = False
For i = Len(Express) To 1 Step -1
ex = Mid(Express, i, 1)
If Asc(ex) <= vbKeyZ And Asc(ex) >= vbKeyA And ex <> "E" And ex <> "-" And ex <> "+" Then
fun = ex & fun
If isfunc = False Then l = i
isfunc = True
Else
If isfunc = True Then Exit For
End If
Next
i = i + 1
' If i = 0 Then Exit Do
If fun = "" Then Exit Do
FindNum Express, l, a, b, temp, r
answer = Func(fun, b)
Express = Mid(Express, 1, i - 1) & answer & Mid(Express, r + 1)
Loop Until i = 0
''''''*/
Do
For i = 1 To Len(Express)
ex = Mid(Express, i, 1)
If ex = "*" Or ex = "/" Then
FindNum Express, i, a, b, l, r
answer = Operate(ex, a, b)
Express = Mid(Express, 1, l - 1) & CStr(answer) & Mid(Express, r + 1)
End If
Next
Loop Until i = Len(Express) + 1
''''''+-
On Error Resume Next
Dim g As Double
Do
For i = 1 To Len(Express)
ex = Mid(Express, i, 1)
Err = 0
g = CDbl2(Express)
If Err = 0 Then Exit Do
If i > 1 And (ex = "+" Or ex = "-") Then
If Mid(Express, i - 1, 1) <> "E" Then
FindNum Express, i, a, b, l, r
answer = Operate(ex, a, b)
Express = Mid(Express, 1, l - 1) & CStr(answer) & Mid(Express, r + 1)
End If
End If
Next
Loop Until i = Len(Express) + 1
Compute = CDbl2(Express)
End Function
Private Sub DelSpace()
Dim a As Long
Dim lenth As Long
'lenth = Len(Text1.Text)
For a = 1 To Len(Text1.Text)
If Mid(Text1.Text, a, 1) = " " Then
Text1.Text = Left(Text1.Text, a - 1) & Mid(Text1.Text, a + 1)
a = a - 1
End If
Next
End Sub
Private Function FindNum(ByVal Wstring As Variant, ByVal START As Long, a As Variant, b As Variant, l As Long, r As Long) As Boolean
On Error Resume Next
Dim a0 As String
Dim b0 As String
Dim X As Long
Dim Y As String
Dim lenth As Long
'lenth = Len(WString)
For X = START - 1 To 1 Step -1
Y = Mid(Wstring, X, 1)
If Asc(Y) >= vbKey0 And Asc(Y) <= vbKey9 Or Y = "." Or Y = "E" Or Mid(Wstring, X - 1, 1) = "E" Or _
(FindChar(Mid(Wstring, X - 1, 2), "-", "+", "*", "/") > 0 And (Y = "-" Or Y = "+")) Then ' And x = 1 And (y = "-" Or y = "+")) Then
a0 = Y & a0
Else: Exit For
End If
l = X
Next
For X = START + 1 To Len(Wstring)
Y = Mid(Wstring, X, 1)
If Asc(Y) >= vbKey0 And Asc(Y) <= vbKey9 Or Y = "." Or Y = "E" Or Mid(Wstring, X - 1, 1) = "E" Or _
(FindChar(Mid(Wstring, X - 1, 2), "-", "+", "*", "/") > 0 And (Y = "-" Or Y = "+")) Or (Asc(Mid(Wstring, X - 1, 1)) <= vbKeyZ And Asc(Mid(Wstring, X - 1, 1)) >= vbKeyA And Asc(Mid(Wstring, X - 1, 1)) <> vbKeyE) Then
b0 = b0 & Y
Else: Exit For
End If
r = X
Next
a = CDbl2(a0)
b = CDbl2(b0)
If Err Then FindNum = False Else FindNum = True
End Function
Private Sub Command0_Click()
If Text1.Text = "" Then Exit Sub
expr = Text1.Text
Text1 = Cal
End Sub
Private Function Cal() As Double
Dim a As Long
Dim b As Long
Dim sign As String
Dim answer As String
Call START
Do
For b = 1 To Len(Express)
sign = Mid(Express, b, 1)
If sign = ")" Then a = instr2(Express, "(", b): Exit For
Next
If sign <> ")" Then Exit Do
answer = Compute(Mid(Express, a + 1, b - a - 1))
Express = Mid(Express, 1, a - 1) & CStr(answer) & Mid(Express, b + 1)
If b = Len(Express) + 1 Then
If Asc(Mid(Express, 2, 1)) > vbKeyZ Or Asc(Mid(Express, 2, 1)) < vbKeyA Then
If Left(Express, 1) = "(" Then Express = Mid(Express, 2, Len(Express) - 2)
Exit Do
End If
End If
Loop
Cal = Express
End Function
Private Function instr2(Wstring As String, Wfind As String, START As Long) As Long
Dim a As Long
For a = START To 1 Step -1
If Mid(Wstring, a, 1) = Wfind Then instr2 = a: Exit For
Next
End Function
Private Sub START()
On Error Resume Next
Dim a As Long
Dim b As Long
Dim sign As String
Dim answer As String
Dim l As Long
Dim r As Long
'Dim a0, b0
DelSpace
Express = "(" & Text1.Text & ")"
For a = 1 To Len(Express)
If Mid(Express, a, 1) = "(" Then
b = b + 1
ElseIf Mid(Express, a, 1) = ")" Then b = b - 1
End If
Next
For a = 1 To b
Express = Express & ")"
Next
Express = UCase(Express)
Do
For a = 1 To Len(Express) - 1
If Asc(Mid(Express, a, 1)) < vbKey9 + 1 And Asc(Mid(Express, a, 1)) > vbKey0 - 1 _
And (Mid(Express, a + 1, 1) = "(" Or (Asc(Mid(Express, a + 1, 1)) < vbKeyZ + 1 _
And Asc(Mid(Express, a + 1, 1)) > vbKeyA - 1) And Mid(Express, a + 1, 1) <> "E") Then
Express = Mid(Express, 1, a) & "*" & Mid(Express, a + 1)
' FindNum Express, a + 1, a0, b0, l, r
' l = iif(InstrAsc(Express, a + 2, vbKey9, vbKey0)>findchar(express,"+","-","*","/") ,
Exit For
End If
Next
If Err Then Exit Do
Loop Until a = Len(Express)
'Print Express
End Sub
Private Sub FUHAO()
Dim a As Long
Dim b As Long
Dim c As String
'Do
' For a = 1 To Len(express)
' if Mid(a, 1)="
End Sub
Private Function CDbl2(Express As String) As Double
Dim a As Long
Dim cou As Long
Dim b As String
b = Express
For a = 1 To Len(Express)
If Mid(Express, a, 1) = "-" Then cou = cou + 1
Next
If cou > 0 Then
For a = 1 To Len(Express)
If Mid(Express, a, 1) = "." Or Asc(Mid(Express, a, 1)) <= vbKey9 And Asc(Mid(Express, a, 1)) >= vbKey0 Then Exit For
Next
cou = cou Mod 2
If cou = 1 Then b = "-" & Mid(Express, a) Else b = Mid(Express, a)
End If
CDbl2 = CDbl(b)
End Function
Private Function FindChar(Wstring As String, Char As String, Optional Char2 As String, Optional char3 As String, Optional char4 As String) As Long
Dim a As Long
If Char2 = "" Then Char2 = Char
If char3 = "" Then char3 = Char
If char4 = "" Then char4 = Char
FindChar = 0
For a = 1 To Len(Wstring)
If Mid(Wstring, a, 1) <> Char And Mid(Wstring, a, 1) <> Char2 And Mid(Wstring, a, 1) <> char3 And Mid(Wstring, a, 1) <> char4 Then
FindChar = a - 1
Exit For
End If
Next
If a = Len(Wstring) + 1 Then FindChar = a - 1
End Function
Private Function Func(WFunction As String, a As Double) As Double
On Error Resume Next
Select Case WFunction
Case "SIN"
Func = Sin(a)
Case "COS"
Func = Cos(a)
Case "TAN"
Func = Tan(a)
Case "TG"
Func = Tan(a)
Case "ARCTG"
Func = Atn(a)
Case "ABS"
Func = Abs(a)
Case "LN"
Func = Log(a)
Case "LG"
Func = Log(a) / Log(10)
Case "LOG"
Func = Log(a) / Log(10)
Case "EXP"
Func = Exp(a)
Case "SQR"
Func = Sqr(a)
Case "SEC"
Func = 1 / Cos(a)
Case "CSC"
Func = 1 / Sin(a)
Case "CTG"
Func = 1 / Tan(a)
Case "ARCSIN"
Func = Atn(a / Sqr(-a * a + 1))
Case "ARCCOS"
Func = Atn(-a / Sqr(-a * a + 1)) + PI / 2
Case "ARCSEC"
Func = Atn(a / Sqr(a * a - 1)) + Sgn((a) - 1) * (PI / 2)
Case "ARCCSC"
Func = Atn(a / Sqr(a * a - 1)) + (Sgn(a) - 1) * (PI / 2)
Case "ARCCTG"
Func = Atn(a) + PI / 2
Case "SH"
Func = (Exp(a) - Exp(-a)) / 2
Case "CH"
Func = (Exp(a) + Exp(-a)) / 2
Case Else
MsgBox "有错误发生": End
End Select
If Err <> 0 Then MsgBox "有错误发生": End
End Function
Private Sub Label1_Click()
End Sub
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
End Sub
Private Sub Command1_Click(Index As Integer)
Text1.Text = Text1.Text & Command1(Index).Caption
End Sub
Private Sub Command2_Click(Index As Integer)
Text1.Text = Text1.Text & Command2(Index).Caption
End Sub
Private Sub Command3_Click(Index As Integer)
Text1.Text = Text1.Text & Command3(Index).Caption
End Sub
Private Sub Command4_Click()
If expr <> "" Then Text1.Text = expr
End Sub
Private Sub Command5_Click()
expr = ""
Text1.Text = ""
End Sub
Private Sub Command6_Click()
Form2.Show
End Sub
扫一扫
1150
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
