compute.frm

VB打造的 科学计算器

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