VB解一元二次方程式

因为作业繁重，特写此来写作业，不过只能进行简单运算，暂不支持带有括号，常量尽量简单些
用的是公式法解方程，自动搜索简单的a,b,c带入公式法运算，得出结果
Option Explicit
Private Type Item '项
ItemString As String '项的字符串 永远为正数
Symbol As Long '符号(1=+ -1=- 2=* -2=/)
Time As Long '项的次数
Coefficient As Single '项的系数
Unknown As String '未知数字符
ConstItem As Boolean '是否为常数项(True是 False否)
Position As Boolean '位置是左(False)还是右(True)
End Type

'公式法
'x=(-b±根号(b^2-4ac))/2a

Public Function Solving_Quadratics(ByVal Quadratics As String,ByRef x1 As Single,ByRef x2 As Single) As Long '解一元二次方程
On Error Resume Next
'一元二次方程式字符串 解1 解2
'返回值: 0=无解 1=有两个相同的实数根 2=有两个不相同的实数根
Dim QuaItem() As Item '方程式的项
Dim LeftItem() As Item '左边的项
Dim RightItem() As Item '右边的项
Dim QuaItemCount As Long '方程式的项数
Dim LeftItemCount As Long
Dim RightItemCount As Long
Dim LeftOrRight As Boolean '是方程左边False还是右边True
LeftOrRight = False '首先遍历左边
'-------------------------------------------------------------------------------------方程式正误检测Begin
If (Quadratics = "") Then '要解的方程式为空
    Solving_Quadratics = 0
    Exit Function
End If
'-------------------------------------------------------------------------------------方程式正误检测End
'-------------------------------------------------------------------------------------去括号Begin
'根据去括号法则,前面是-里面所有的项都要变号(+变- -变+) 前面是*就用乘法分配律 前面是/
'-------------------------------------------------------------------------------------去括号End
'-------------------------------------------------------------------------------------获取每一项存入Begin
'+-为一项
Dim i As Long
Dim Char As String
Dim LastSymbolPlace As Long '上一个符号(+-)位置
LastSymbolPlace = 1 '第一个自成一项
For i = 0 To Len(Quadratics) - 1 '遍历每一个字符
    Char = Mid(Quadratics,i + 1,1) '取出这个字符
    If (Char = "+") Or (Char = "-") Or (Char = "=") Then '成一项
        ReDim Preserve QuaItem(QuaItemCount)
        QuaItem(QuaItemCount).ItemString = Mid(Quadratics,LastSymbolPlace,i + 1 - LastSymbolPlace)
        '判断这一项的符号
        Select Case Mid(Quadratics,1)
        Case "+"
            QuaItem(QuaItemCount).Symbol = 1
            QuaItem(QuaItemCount).ItemString = Right(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - 1) '去掉项的符号
        Case "-"
            QuaItem(QuaItemCount).Symbol = -1
            QuaItem(QuaItemCount).ItemString = Right(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - 1)
        Case "*"
            QuaItem(QuaItemCount).Symbol = 2
            QuaItem(QuaItemCount).ItemString = Right(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - 1)
        Case "/"
            QuaItem(QuaItemCount).Symbol = -2
            QuaItem(QuaItemCount).ItemString = Right(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - 1)
        Case Else '都不是就默认是+ And +号可以省略
            QuaItem(QuaItemCount).Symbol = 1
        End Select
        '获取这个项的次数
        Dim TimePlace As Long '次数在这个项中的开始位置
        TimePlace = InStr(1,QuaItem(QuaItemCount).ItemString,"^",vbTextCompare) '获取^的位置
        If (TimePlace = 0) Then '没有找到^则说明默认是一次项
            QuaItem(QuaItemCount).Time = 1 '一次项
        Else '有^ 说明不是一次项 就获取次数
            QuaItem(QuaItemCount).Time = Mid(QuaItem(QuaItemCount).ItemString,TimePlace + 1,Len(QuaItem(QuaItemCount).ItemString) - TimePlace)
            QuaItem(QuaItemCount).ItemString = Left(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - (Len(QuaItem(QuaItemCount).ItemString) - TimePlace) - 1) '去掉^
        End If
        '判断是否为常数项
        QuaItem(QuaItemCount).ConstItem = IsNumeric(QuaItem(QuaItemCount).ItemString) '判断是全数字
        '获取这个项的系数 与 未知数
        If (QuaItem(QuaItemCount).ConstItem = True) Then '是常数项
            QuaItem(QuaItemCount).Coefficient = Val(QuaItem(QuaItemCount).ItemString) '直接取得
        Else '不是常数项
            Dim ii As Long
            For ii = 0 To Len(QuaItem(QuaItemCount).ItemString) - 1 '循环遍历所有字符
                If ((Asc(Mid(QuaItem(QuaItemCount).ItemString,ii + 1,1)) < 41) Or (Asc(Mid(QuaItem(QuaItemCount).ItemString,1)) > 57) Or (Asc(Mid(QuaItem(QuaItemCount).ItemString,1)) = 44)) Then '不是运算符
                    QuaItem(QuaItemCount).Coefficient = Left(QuaItem(QuaItemCount).ItemString,ii + 1 - 1) '系数
                    QuaItem(QuaItemCount).Unknown = Right(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - ii) '未知数
                    If (QuaItem(QuaItemCount).Coefficient = 0) Then '系数为0(隐藏了系数1)
                        QuaItem(QuaItemCount).Coefficient = 1 '必须为1
                    End If
                End If
            Next ii
        End If
        '判断是左项还是右项
        QuaItem(QuaItemCount).Position = LeftOrRight
        LastSymbolPlace = i + 1 '设置位置
        QuaItemCount = QuaItemCount + 1
    End If
    If (Char = "=") Then '换边
        LeftOrRight = Not LeftOrRight '换边
        LastSymbolPlace = i + 2 '设置=符号后一个(=不算入其内)位置
    End If
Next i
'结束后右项还有一个项没有算入 将最后一项加入
ReDim Preserve QuaItem(QuaItemCount)
QuaItem(QuaItemCount).ItemString = Mid(Quadratics,i + 1 - LastSymbolPlace)
Select Case Mid(Quadratics,1)
Case "+"
    QuaItem(QuaItemCount).Symbol = 1
    QuaItem(QuaItemCount).ItemString = Right(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - 1)
Case "-"
    QuaItem(QuaItemCount).Symbol = -1
    QuaItem(QuaItemCount).ItemString = Right(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - 1)
Case "*"
    QuaItem(QuaItemCount).Symbol = 2
    QuaItem(QuaItemCount).ItemString = Right(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - 1)
Case "/"
    QuaItem(QuaItemCount).Symbol = -2
    QuaItem(QuaItemCount).ItemString = Right(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - 1)
Case Else '都不是就默认是+ And +号可以省略
    QuaItem(QuaItemCount).Symbol = 1
End Select
'获取这个项的次数
TimePlace = InStr(1,vbTextCompare) '获取^的位置
If (TimePlace = 0) Then '没有找到^则说明默认是一次项
    QuaItem(QuaItemCount).Time = 1 '一次项
Else '有^ 说明不是一次项 就获取次数
    QuaItem(QuaItemCount).Time = Mid(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - TimePlace)
    QuaItem(QuaItemCount).ItemString = Left(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - (Len(QuaItem(QuaItemCount).ItemString) - TimePlace) - 1) '去掉^
End If
'判断是否为常数项
QuaItem(QuaItemCount).ConstItem = IsNumeric(QuaItem(QuaItemCount).ItemString) '判断是全数字
'获取这个项的系数 与 未知数
If (QuaItem(QuaItemCount).ConstItem = True) Then '是常数项
    QuaItem(QuaItemCount).Coefficient = Val(QuaItem(QuaItemCount).ItemString) '直接取得
Else '不是常数项
    For ii = 0 To Len(QuaItem(QuaItemCount).ItemString) - 1 '循环遍历所有字符
        If ((Asc(Mid(QuaItem(QuaItemCount).ItemString,1)) < 42) Or (Asc(Mid(QuaItem(QuaItemCount).ItemString,1)) = 44)) Then '不是数字
            QuaItem(QuaItemCount).Coefficient = Left(QuaItem(QuaItemCount).ItemString,ii + 1 - 1) '系数
            QuaItem(QuaItemCount).Unknown = Right(QuaItem(QuaItemCount).ItemString,Len(QuaItem(QuaItemCount).ItemString) - ii) '未知数
            If (QuaItem(QuaItemCount).Coefficient = 0) Then '系数为0(隐藏了系数1)
                QuaItem(QuaItemCount).Coefficient = 1 '必须为1
            End If
        End If
    Next ii
End If
QuaItem(QuaItemCount).Position = LeftOrRight '获取位置
QuaItemCount = QuaItemCount + 1
'-------------------------------------------------------------------------------------获取每一项存入End
'-------------------------------------------------------------------------------------移项 化为标准形式Begin
'标准形式为ax^2+bx+c=0
Dim a As Single
Dim b As Single
Dim c As Single
'将次数相同未知数的项进行运算并移项
Dim TmpItem As Item '缓存
'运算所有常量项与第三个项交换位置
Dim ConstString As String '保存找到的常量项
Dim ConstNumber As Long '保存常量运算结果
'提取所有常量项
For i = 0 To UBound(QuaItem)
    If (QuaItem(i).ConstItem = True) Then '是常数项
        If (QuaItem(i).Position = False) Then '这个项在左边
            If (QuaItem(i).Symbol = 1) Then '+
                ConstString = ConstString & "+" & QuaItem(i).Coefficient '获取系数
            Else '-
                ConstString = ConstString & "-" & QuaItem(i).Coefficient
            End If
        Else '这个项在右边
            '移项变号
            QuaItem(i).Symbol = -QuaItem(i).Symbol '变号
            If (QuaItem(i).Symbol = 1) Then '+
                ConstString = ConstString & "+" & QuaItem(i).Coefficient '获取系数
            Else '-
                ConstString = ConstString & "-" & QuaItem(i).Coefficient
            End If
        End If
    End If
Next i
'运算所有常量项
ConstNumber = MyMainCount(ConstString)
'记录常量
c = Val(ConstNumber)
ConstString = ""
Dim Unknown As String
For i = 0 To UBound(QuaItem)
    If (QuaItem(i).ConstItem = False) And (QuaItem(i).Time = 1) And (QuaItem(i).Unknown <> "") Then '不是常数项 次数为1 有未知数
        If (QuaItem(i).Position = False) Then '这个项在左边
            Unknown = QuaItem(i).Unknown '获取未知数
            If (QuaItem(i).Symbol = 1) Then '+
                ConstString = ConstString & "+" & QuaItem(i).Coefficient '获取系数
            Else '-
                ConstString = ConstString & "-" & QuaItem(i).Coefficient
            End If
        Else '这个项在右边
            '移项变号
            QuaItem(i).Symbol = -QuaItem(i).Symbol '变号
            If (QuaItem(i).Symbol = 1) Then '+
                ConstString = ConstString & "+" & QuaItem(i).Coefficient '获取系数
            Else '-
                ConstString = ConstString & "-" & QuaItem(i).Coefficient
            End If
        End If
    End If
Next i
ConstNumber = MyMainCount(ConstString) '获取一次项运算结果
b = Val(ConstNumber)
'运算所有二次项与第一个项交换位置
ConstString = ""
For i = 0 To UBound(QuaItem)
    If (QuaItem(i).ConstItem = False) And (QuaItem(i).Time = 2) And (QuaItem(i).Unknown <> "") Then '不是常数项 次数为2 有未知数
        If (QuaItem(i).Position = False) Then '这个项在左边
            Unknown = QuaItem(i).Unknown '获取未知数
            If (QuaItem(i).Symbol = 1) Then '+
                ConstString = ConstString & "+" & QuaItem(i).Coefficient '获取系数
            Else '-
                ConstString = ConstString & "-" & QuaItem(i).Coefficient
            End If
        Else '这个项在右边
            '移项变号
            QuaItem(i).Symbol = -QuaItem(i).Symbol '变号
            If (QuaItem(i).Symbol = 1) Then '+
                ConstString = ConstString & "+" & QuaItem(i).Coefficient '获取系数
            Else '-
                ConstString = ConstString & "-" & QuaItem(i).Coefficient
            End If
        End If
    End If
Next i
ConstNumber = MyMainCount(ConstString) '获取二次项运算结果
a = Val(ConstNumber)
'-------------------------------------------------------------------------------------移项 化为标准形式End
'-------------------------------------------------------------------------------------判断解并带入公式求解 Begin
'返回值: 0=无解 1=有两个相同的实数根 2=有两个不相同的实数根
Dim Dt As Double  '检验
Dt = b ^ 2 - 4 * a * c
If (Dt < 0) Then '没有解
    Solving_Quadratics = 0
    Exit Function '不进行求根
End If
If (Dt = 0) Then '有两个相同的解
    Solving_Quadratics = 1
    x1 = (-b + Sqr(b ^ 2 - 4 * a * c)) / (2 * a)
    x2 = x1 '相同解
    Exit Function
End If
If (Dt > 0) Then '有两个不相同的解
    Solving_Quadratics = 2
    x1 = (-b + Sqr(b ^ 2 - 4 * a * c)) / (2 * a)
    x2 = (-b - Sqr(b ^ 2 - 4 * a * c)) / (2 * a)
    Exit Function
End If
'-------------------------------------------------------------------------------------判断解并带入公式求解 End
End Function

Public Function MyMainCount(ByVal Str As String) As Long 'Str可带括号
'支持+,-,*,/,()
'先从()算起 从左至右
Dim Str1 As String
Dim Count As Long '整个算式的结果
Dim i As Long
Dim bracket As Long '括号位置
bracket = 1 '从第一个
Count = 0
For i = 0 To Len(Str)  '循环检测是否有括号
    bracket = InStr(bracket,Str,"(",vbTextCompare)
    If bracket = 0 Then '没有括号
        Count = MyCount(Str)
    Else '有括号
        '先算括号里面的
        Str1 = Mid(Str,bracket + 1,InStr(bracket,")",vbTextCompare) - 2) '分解出括号里面的 无括号
        Count = Count + MyCount(Str1)
        Str = Replace(Str,"(" & Str1 & ")",CStr(Count),vbTextCompare) '将原来字符串中的()中的内容替换为运算后的得数
        Count = 0 '只是为了将括号去掉 所以不记返回值
    End If
    bracket = bracket + 1 '当前括号已经运算所以作废 先前移动一个字符
Next i
MyMainCount = Count
End Function

Public Function MyCount(ByVal Str As String) As Long 'Str不可带括号 四舍五入制
On Error Resume Next
Dim i As Long
'判断有几个符号(数字=符号数量+1)
Dim sym As Long '符号数量
sym = 0
For i = 0 To Len(Str)
    If Mid(Str,1) = "+" Or Mid(Str,1) = "-" Or Mid(Str,1) = "*" Or Mid(Str,1) = "/" Then
        sym = sym + 1
    End If
Next i
'提出所有数字存入数组 提出所有符号存入到数组
Dim number() As Long '数字数组
Dim numbercount As Long '数字总数
Dim tmpbuffer As String '缓冲数组字符区
ReDim number(sym) '动态设置数组维数
'-------------------------------------------
Dim symstring() As String '符号数组
ReDim symstring(sym - 1) '动态设置数组维数
Dim symcount As Long '符号总数
numbercount = 0
symcount = 0
'开头不能是符号
For i = 0 To Len(Str) - 1
    If Asc(Mid(Str,1)) >= &H30 And Asc(Mid(Str,1)) <= &H39 Then '是0~9的Ascii码
        tmpbuffer = tmpbuffer & Mid(Str,1) '添加到缓冲区
    Else '是运算符
        number(numbercount) = Val(tmpbuffer) '将缓冲区输入到数组
        numbercount = numbercount + 1 '数字总数+1
        tmpbuffer = "" '清空运算符 供下次使用
        '将运算符输入到数组
        symstring(symcount) = Mid(Str,1)
        symcount = symcount + 1
    End If
Next i
'将最后一个(结尾为数字)数组提出
number(numbercount) = Val(tmpbuffer) '将缓冲区输入到数组
numbercount = numbercount + 1 '数字总数+1
tmpbuffer = "" '清空运算符 供下次使用
'--------------------------------------------
'开始运算
'没有括号(不同级:先*/再+-)(同级:从左到右)
'运算符有几个就算几次
'Dim Level As Long '1=乘除级别 0=加减级别
Dim ii As Long
'Level = 0
'For i = 0 To symcount - 1 '判断是否有乘除符号
'    '找乘除
'    If symstring(i) = "/" Or symstring(i) = "*" Then '有乘除
'        Level = 1 '乘除级别
'        Exit For
'    End If
'Next i
    '先乘除后加减-------------------------------------------------------------
    '乘除从左到右
    For i = 0 To symcount - 1
        If i > symcount - 1 Then '超出范围了
            Exit For
        End If
        If symstring(i) = "/" Or symstring(i) = "*" Then '乘法Or除法
            If symstring(i) = "/" Then
                '没有算的最左边的/符号 开始进行除法运算
                number(i) = number(i) / number(i + 1) '除法运算
            End If
            If symstring(i) = "*" Then
                '没有算的最左边的*符号 开始进行乘法运算
                number(i) = number(i) * number(i + 1) '除法运算
            End If
            '数字数组减少一个 缺了一个空补上
            For ii = i + 1 To numbercount - 1
                number(ii) = number(ii + 1) '替换
            Next ii
            numbercount = numbercount - 1
            ReDim Preserve number(numbercount - 1) '保留+重定义
            '符号数组减少一个
            For ii = i + 1 To symcount - 1
                symstring(ii - 1) = symstring(ii)
            Next ii
            symcount = symcount - 1
            ReDim Preserve symstring(symcount - 1)
            i = i - 1 '回滚
        End If
    Next i
    '加减从左到右
    For i = 0 To symcount - 1
        If i > symcount - 1 And symcount < 1 Then '超出范围了并且没有运算符号了就退出循环(不用运算了)
            Exit For
        Else '其中有一个为False特别是第二个就说明还有一个运算符 还要运算一次 所以将第一个与第二个进行运算
            If i > symcount - 1 Then
                i = 0 '设置数组元素第1个
            End If
        End If
        If symstring(i) = "+" Or symstring(i) = "-" Then '加法Or减法
            If symstring(i) = "+" Then
                '没有算的最左边的/符号 开始进行除法运算
                number(i) = number(i) + number(i + 1) '加法运算
            End If
            If symstring(i) = "-" Then
                '没有算的最左边的*符号 开始进行乘法运算
                number(i) = number(i) - number(i + 1) '减法运算
            End If
            '数字数组减少一个 缺了一个空补上
            For ii = i + 1 To numbercount - 1
                number(ii) = number(ii + 1) '替换
            Next ii
            numbercount = numbercount - 1
            ReDim Preserve number(numbercount - 1) '保留+重定义
            '符号数组减少一个
            For ii = i + 1 To symcount - 1
                symstring(ii - 1) = symstring(ii)
            Next ii
            symcount = symcount - 1
            ReDim Preserve symstring(symcount - 1)
            i = i - 1
        End If
    Next i
'-----------------------------------------------------------------------------------------------
MyCount = number(0) '返回结果(数组的第一个元素) 因为前面删除了空出来的元素 最后只剩下答案了
End Function
VB解一元二次方程式

猜你在找的VB相关文章
