VB6 Converting a fraction to a decimal and a decimal to fraction

Question

There's a few posts on this, but none seem to provide a whole code solution, so I'm posting this up, which is culled (and credited where appropriate) from various bits and pieces of ideas on the Internet. VB6 doesn't have any function to convert from a fraction to a decimal number, which I needed for a project that I was working on which was concerned with meal recipes. I considered writing a DLL in .NET and plugging it into my application, but decided on this approach in the end. I hope this is useful for others. The solution below will do the following:

1. You supply a decimal number and you will be returned the fraction as a string.

2. You supply a fraction as a string and you will be returned with the decimal number.

In both cases, whole numbers are accounted for eg. "2 3/4" (two and three quarters) or "2.75".

I'm sure the code is not efficient, so any improvements are welcome.

Answer 1

Copy/Paste this as a new Class module:

Option Explicit

Private ErrorNote As String

'Properties
Public Property Get GetAsFraction(numToConvert As Double) As String

        On Error GoTo GetAsFraction_Error

        GetAsFraction = FncGetAsFraction(numToConvert)

        On Error GoTo 0

        Exit Property

GetAsFraction_Error:

        ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'GetAsFraction' in 'ClsFractionDecimal'"
        MsgBox (ErrorNote)

End Property

Public Property Get GetAsDecimal(fractionString As String) As Double

        On Error GoTo GetAsDecimal_Error

        GetAsDecimal = FncGetAsDecimal(fractionString)

        On Error GoTo 0

        Exit Property

GetAsDecimal_Error:

        ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'GetAsDecimal' in 'ClsFractionDecimal'"
        MsgBox (ErrorNote)

End Property

'Functions - private
Private Function FncGetAsDecimal(fractionToConvert As String) As Double

        Dim result As Double
        Dim wholeNumber As Integer
        Dim splitStr As Variant
        Dim numerator As Integer
        Dim denominator As Integer
        Dim fractionString As String
        Dim dividedByPos As Integer

        On Error GoTo FncGetAsDecimal_Error

        splitStr = Split(fractionToConvert, " ")

        If UBound(splitStr) = 1 Then

            wholeNumber = splitStr(0)
            fractionString = splitStr(1)

        Else

            fractionString = splitStr(0)

        End If

        dividedByPos = InStr(1, fractionString, "/")

        numerator = Left(fractionString, dividedByPos - 1)
        denominator = Mid(fractionString, dividedByPos + 1)

        result = Val(numerator) / Val(denominator) + wholeNumber

       FncGetAsDecimal = result

       On Error GoTo 0

       Exit Function

FncGetAsDecimal_Error:

       ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'FncGetAsDecimal' in 'ClsFractionDecimal'"
       MsgBox (ErrorNote)

End Function

Private Function FncGetAsFraction(numToConvert As Double) As String

        Dim result As String
        Dim numeratorCount As Integer
        Dim denominator As Single
        Dim multiplierStr As String
        Dim i As Integer
        Dim fractionNum As Single
        Dim lowestCommonDenominator As Long
        Dim wholeNumber As Integer
        Dim decimalPos As Integer

        On Error GoTo FncGetAsFraction_Error

        If numToConvert > 0 Then

            decimalPos = InStr(1, CStr(numToConvert), ".")

            If decimalPos > 1 Then

                wholeNumber = CStr(Mid(numToConvert, 1, decimalPos - 1))
                numToConvert = CStr(Mid(numToConvert, decimalPos))

            End If

            numeratorCount = FncCountDecimalPlaces(numToConvert)
            multiplierStr = "1"

           For i = 1 To numeratorCount

               multiplierStr = multiplierStr & "0"

           Next i

           fractionNum = numToConvert * Val(multiplierStr)
           denominator = 1 * Val(multiplierStr)

               result = FncCrunchFraction(fractionNum, denominator)
               If result = "" Then result = fractionNum & "/" & denominator
               If wholeNumber <> 0 Then result = wholeNumber & " " & result

       Else

           result = "ERROR"

       End If

       FncGetAsFraction = result

       On Error GoTo 0

       Exit Function

FncGetAsFraction_Error:

       ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'FncGetAsFraction' in 'ClsFractionDecimal'"
       MsgBox (ErrorNote)

End Function

Private Function FncCountDecimalPlaces(num As Double) As Integer

        Dim result As Integer
        Dim numberStr As String
        Dim i As Integer
        Dim decimalPointPos As Integer

        On Error GoTo FncCountDecimalPlaces_Error

        numberStr = CStr(num)

        If Len(numberStr) > 0 Then

            i = 1

            Do While i <= Len(numberStr) And decimalPointPos = 0

                If Mid(numberStr, i, 1) = "." Then decimalPointPos = i
                i = i + 1

            Loop

        End If

        If i > 1 Then

           result = (Len(numberStr) - i + 1)

       End If

       FncCountDecimalPlaces = result

       On Error GoTo 0

       Exit Function

FncCountDecimalPlaces_Error:

       ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'FncCountDecimalPlaces' in 'ClsFractionDecimal'"
       MsgBox (ErrorNote)

End Function

'Credit to:
'http://www.tek-tips.com/viewthread.cfm?qid=206890
'dsi (Programmer) - 7 Feb 02 10:38
Private Function FncCrunchFraction(num1 As Single, num2 As Single) As String

        Dim num As Single
        Dim dem As Single
        Dim cnt1 As Integer
        Dim cnt2 As Integer
        Dim numFactors() As Single
        Dim demFactors() As Single
        Dim common As Single
        Dim i As Integer
        Dim j As Integer

        On Error GoTo FncCrunchFraction_Error

        num = num1
        dem = num2

        For i = 2 To Int(num / 2) Step 1

            If (num Mod i = 0) Then

                cnt1 = cnt1 + 1
                ReDim Preserve numFactors(1 To cnt1)
                numFactors(cnt1) = i

            End If

        Next i

        cnt1 = cnt1 + 1

        ReDim Preserve numFactors(1 To cnt1)
       numFactors(cnt1) = num

       For i = 2 To Int(dem / 2) Step 1

           If (dem Mod i = 0) Then

                cnt2 = cnt2 + 1
                ReDim Preserve demFactors(1 To cnt2)
                demFactors(cnt2) = i

            End If

        Next i

        cnt2 = cnt2 + 1
        ReDim Preserve demFactors(1 To cnt2)
        demFactors(cnt2) = dem

        For i = cnt1 To 1 Step -1

            For j = cnt2 To 1 Step -1

                If (numFactors(i) = demFactors(j)) Then

                    common = numFactors(i)
                    FncCrunchFraction = num / common & "/" & dem / common
                    Exit Function

                End If

            Next j

        Next i

        FncCrunchFraction = ""

        On Error GoTo 0

        Exit Function

FncCrunchFraction_Error:

        ErrorNote = "Line:" & Erl & " Number:" & Err.number & " (" & Err.Description & ") in procedure 'FncCrunchFraction' in 'ClsFractionDecimal'"
        MsgBox (ErrorNote)

End Function

Then call it with these code examples:

    Public Function DecimalToFraction(number As Double) As String

    Dim myFractionDecimal As New ClsFractionDecimal

    DecimalToFraction = myFractionDecimal.GetAsFraction(number)

    Set myFractionDecimal = Nothing

End Function

Public Function FractionToDecimal(fractionString As String) As Double

    Dim myFractionDecimal As New ClsFractionDecimal

    FractionToDecimal = myFractionDecimal.GetAsDecimal(fractionString)

    Set myFractionDecimal = Nothing

End Function