Keskustelu: Koodit: VB6: Laskulausekkeen laskija

'Laskulausekkeen laskija
'--------------------------------------------------
'
'Tämä ohjelma laskee laskulausekkeen laskujärjes-
'tyssääntöjä noudattaen. Laskulausekkeessa voi olla:
'
'   Double-tyyppisiä lukuja
'   +, -, *, / -laskuja
'   sulkeita
'
'Copyright Antti Laaksonen 2002
'www.ohjelmointiputka.net

Option Explicit

Const KELPAAVAT_MERKIT = "0123456789+-*/,()"

'Pääfunktio, palauttaa lausekkeen laskettuna
Function LaskeLauseke(lauseke As String) As String
    On Error GoTo virhe
    lauseke = TarkistaLauseke(lauseke)
    If lauseke = "" Then Exit Function
    lauseke = LaskeLausekeOsa(lauseke)
    LaskeLauseke = lauseke
    Exit Function
virhe:
    MsgBox "Virhe: " & Error(Err)
    Exit Function
    Resume Next
End Function

'Laskee lausekkeen tai sen sulkujen välisen osan
Function LaskeLausekeOsa(osa As String) As String
    Dim alku As Integer, loppu As Integer
    Dim kohta As Integer, p1 As Integer, p2 As Integer
    Dim vali As String, i As Integer, ero As Integer
    Do
        If InStr(osa, "(") <> 0 Then
            alku = InStr(osa, "(") + 1
            ero = 1
            For i = alku To Len(osa)
                If Mid(osa, i, 1) = "(" Then
                    ero = ero + 1
                ElseIf Mid(osa, i, 1) = ")" Then
                    ero = ero - 1
                End If
                If ero = 0 Then
                    loppu = i
                    Exit For
                End If
            Next
            vali = Mid(osa, alku, loppu - alku)
            osa = Mid(osa, 1, alku - 2) & LaskeLausekeOsa(vali) & Mid(osa, loppu + 1)
        Else
            Exit Do
        End If
    Loop
    Do
        If InStr(osa, "*") <> 0 Or InStr(osa, "/") <> 0 Then
            If (InStr(osa, "*") < InStr(osa, "/") Or InStr(osa, "/") = 0) And InStr(osa, "*") <> 0 Then
                HaeTekijat osa, "*", alku, loppu, p1, p2
                osa = Mid(osa, 1, alku - 1) & CDbl(Mid(osa, alku, p1)) * CDbl(Mid(osa, loppu, p2)) & Mid(osa, loppu + p2)
            Else
                HaeTekijat osa, "/", alku, loppu, p1, p2
                osa = Mid(osa, 1, alku - 1) & CDbl(Mid(osa, alku, p1)) / CDbl(Mid(osa, loppu, p2)) & Mid(osa, loppu + p2)
                osa = VaihdaMJ(osa, ".", ",")
            End If
        ElseIf InStr(osa, "+") <> 0 Then
            HaeTekijat osa, "+", alku, loppu, p1, p2
            osa = Mid(osa, 1, alku - 1) & CDbl(Mid(osa, alku, p1)) + CDbl(Mid(osa, loppu, p2)) & Mid(osa, loppu + p2)
        Else
            Exit Do
        End If
    Loop
    LaskeLausekeOsa = osa
End Function

'Tarkistaa lausekkeen oikeellisuuden ja tekee eräitä
'merkkivaihdoksia
Function TarkistaLauseke(lauseke As String) As String
    Dim uusi As String, sulut As Integer
    Dim i As Integer

    lauseke = VaihdaMJ(lauseke, ".", ",")

    For i = 1 To Len(lauseke)
        If InStr(KELPAAVAT_MERKIT, Mid(lauseke, i, 1)) <> 0 Then
            uusi = uusi + Mid(lauseke, i, 1)
        End If
        If Mid(lauseke, i, 1) = "(" Then
            sulut = sulut + 1
        ElseIf Mid(lauseke, i, 1) = ")" Then
            sulut = sulut - 1
        End If
    Next


    uusi = VaihdaMJ(uusi, "--", "+")

    For i = 0 To 9
        uusi = VaihdaMJ(uusi, i & "(", i & "*(")
        uusi = VaihdaMJ(uusi, i & "-", i & "+-")
    Next

    uusi = VaihdaMJ(uusi, ")-", ")+-")
    uusi = VaihdaMJ(uusi, ")(", ")*(")

    If sulut <> 0 Then
        MsgBox "Eri määrä sulkuja lausekkeessa!"
        TarkistaLauseke = ""
    Else
        TarkistaLauseke = uusi
    End If
End Function

'Hakee merkin vasemmalla ja oikealla puolella olevat luvut
Sub HaeTekijat(osa As String, merkki As String, alku As Integer, loppu As Integer, p1 As Integer, p2 As Integer)
    Dim kohta As Integer, i As Integer
    alku = 0: loppu = 0
    p1 = 0: p2 = 0
    kohta = InStr(osa, merkki)
    loppu = kohta + 1
    alku = kohta
    For i = kohta - 1 To 1 Step -1
        Select Case Mid(osa, i, 1)
        Case "0" To "9", "-", ","
        Case Else
            Exit For
        End Select
        p1 = p1 + 1
        alku = alku - 1
    Next
    For i = kohta + 1 To Len(osa) Step 1
        Select Case Mid(osa, i, 1)
        Case "0" To "9", "-", ","
        Case Else
            Exit For
        End Select
        p2 = p2 + 1
    Next
End Sub

'Vastaa PHP:n str_replace-funktiota, korvaa merkkijonon toisella
Function VaihdaMJ(mj As String, v1 As String, v2 As String) As String
    Dim kohta As Integer
    Do Until InStr(mj, v1) = 0
        kohta = InStr(mj, v1)
        mj = Left(mj, kohta - 1) + v2 + Mid$(mj, kohta + Len(v1))
    Loop
    VaihdaMJ = mj
End Function

'Funktion esittelyä
Private Sub Form_Load()
    Dim lauseke As String
    lauseke = InputBox("Anna laskulauseke:", , "5(7+13)")
    MsgBox "Tulos on: " & LaskeLauseke(lauseke)
    End
End Sub