[VB6] CDbl & CDec like Val

[Merri]

Some people may want to use the locale aware CDbl or CDec function to check for numbers from text fields, the problem being that these functions will raise an error on invalid input. There is the Val function, but it will only accept US locale.

What are here are speed optimized VDbl & VDec functions. I may post more similar conversion functions later on (VLng would be wanted I guess?). The only thing that limits speed is that two VB6 runtime API calls are made each time (ArrPtr & PutMem4, each once per call).

Rules:

1. Function always returns a number in the expected datatype & never raises an error
2. Accepts numbers
3. Accepts locale decimal separator ONCE
4. Accepts plus or minus ONCE before any numbers
5. Ignores space, comma & period (thus allows to use thousands separators)
6. Any other character will break parsing and the current number is returned
7. If a too big value is encountered that cannot be handled by the datatype the function simply returns 0

The current problem with VDec is that it doesn't got up to the maximum limit of Decimal subtype of Variant. The biggest accepted number is 9999999999999999999999999999 (28 numbers there).

' Conversion.bas
Option Explicit

Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Arr() As Any) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value As Long)

Private m_A() As Long
Private m_AP As Long
Private m_H(0 To 6) As Long
Private m_HP As Long

Public Function VDbl(ByVal Text As String) As Double
    Static Separator As Integer, HI(0 To 6) As Long, HPI As Long
    Dim AI() As Integer, API As Long, D As Double, I As Integer, L As Long, N As Long
    Dim M As Boolean, P As Boolean, S As Boolean
    Dim HasSafeArray As Boolean, OldHeaderPtr As Long
    ' store current locale decimal separator
    If Separator = 0 Then Separator = AscW(Format$(0, ".#"))
    ' get length
    L = Len(Text)
    ' nuffin?
    If L < 1 Then Exit Function
    ' generic safe array hack
    If m_AP = 0 Then
        ' array variable pointer
        m_AP = ArrPtr(m_A)
        ' create a safe array header
        m_H(0) = vbLong: m_H(1) = &H800001: m_H(2) = 4: m_H(5) = &H7FFFFFFF
        ' header pointer
        m_HP = VarPtr(m_H(1))
    End If
    ' set pointer to array
    HasSafeArray = Not Not m_A
    Debug.Assert App.hInstance
    If Not HasSafeArray Then PutMem4 m_AP, m_HP Else OldHeaderPtr = m_H(4)
    ' local safe array hack
    API = ArrPtr(AI)
    If HPI = 0 Then
        HI(0) = vbInteger: HI(1) = &H800001: HI(2) = 2: HI(5) = &H7FFFFFFF
        HPI = VarPtr(HI(1))
    End If
    ' set pointer to array variable (equivalent of "PutMem4 API, HPI" - just faster!)
    m_H(4) = API: m_A(0) = HPI
    HI(4) = StrPtr(Text)
    ' then process!
    D = 1
    For L = 0 To L - 1
        I = AI(L)
        Select Case I
        ' numbers
        Case 48, 49, 50, 51, 52, 53, 54, 55, 56, 57
            ' move character?
            If N < L Then AI(N) = I
            N = N + 1
        ' decimal separator of current locale
        Case Separator
            ' only one separator accepted
            If S Then Exit For
            S = True
            ' move character?
            If N < L Then AI(N) = I
            N = N + 1
        ' ignore space, comma, dot
        Case 32, 44, 46
        ' ignore plus
        Case 43
            ' only accept before any numbers
            If N > 0 Or P Then Exit For
            P = True
        ' store minus
        Case 45
            ' only accept before any numbers
            If N > 0 Or P Then Exit For
            M = True
            ' move character?
            If N < L Then AI(N) = I
            N = N + 1
        ' any other character cuts us off
        Case Else
            Exit For
        End Select
    Next L
    ' we got a result!
    If N + M + S Then VDbl = CDbl(Left$(Text, N))
    ' end safe array hack
    m_H(4) = API: m_A(0) = 0
    If Not HasSafeArray Then m_H(4) = m_AP: m_A(0) = 0 Else m_H(4) = OldHeaderPtr
End Function

Public Function VDec(ByVal Text As String) As Variant
    Static Separator As Integer, HI(0 To 6) As Long, HPI As Long
    Dim AI() As Integer, API As Long, D As Double, I As Integer, L As Long, N As Long
    Dim M As Boolean, P As Boolean, S As Boolean
    Dim HasSafeArray As Boolean, OldHeaderPtr As Long
    ' store current locale decimal separator
    If Separator = 0 Then Separator = AscW(Format$(0, ".#"))
    ' get length
    L = Len(Text)
    ' nuffin?
    If L < 1 Then Exit Function
    ' generic safe array hack
    If m_AP = 0 Then
        ' array variable pointer
        m_AP = ArrPtr(m_A)
        ' create a safe array header
        m_H(0) = vbLong: m_H(1) = &H800001: m_H(2) = 4: m_H(5) = &H7FFFFFFF
        ' header pointer
        m_HP = VarPtr(m_H(1))
    End If
    ' set pointer to array
    HasSafeArray = Not Not m_A
    Debug.Assert App.hInstance
    If Not HasSafeArray Then PutMem4 m_AP, m_HP Else OldHeaderPtr = m_H(4)
    ' local safe array hack
    API = ArrPtr(AI)
    If HPI = 0 Then
        HI(0) = vbInteger: HI(1) = &H800001: HI(2) = 2: HI(5) = &H7FFFFFFF
        HPI = VarPtr(HI(1))
    End If
    ' set pointer to array variable (equivalent of "PutMem4 API, HPI" - just faster!)
    m_H(4) = API: m_A(0) = HPI
    HI(4) = StrPtr(Text)
    ' then process!
    D = 1
    For L = 0 To L - 1
        I = AI(L)
        Select Case I
        ' numbers
        Case 48, 49, 50, 51, 52, 53, 54, 55, 56, 57
            ' move character?
            If N < (28 - S - M) Then
                If N < L Then AI(N) = I
            Else
                N = 0
                Exit For
            End If
            N = N + 1
        ' decimal separator of current locale
        Case Separator
            ' only one separator accepted
            If S Then Exit For
            S = True
            ' move character?
            If N < L Then AI(N) = I
            N = N + 1
        ' ignore space, comma, dot
        Case 32, 44, 46
        ' ignore plus
        Case 43
            ' only accept before any numbers
            If N > 0 Or P Then Exit For
            P = True
        ' store minus
        Case 45
            ' only accept before any numbers
            If N > 0 Or P Then Exit For
            M = True
            ' move character?
            If N < L Then AI(N) = I
            N = N + 1
        ' any other character cuts us off
        Case Else
            Exit For
        End Select
    Next L
    ' remove minus & separator characters from length
    L = N + M + S
    ' we got a result!
    If L > 0 And L < 29 Then VDec = CDec(Left$(Text, N)) Else VDec = CDec(0)
    ' end safe array hack
    m_H(4) = API: m_A(0) = 0
    If Not HasSafeArray Then m_H(4) = m_AP: m_A(0) = 0 Else m_H(4) = OldHeaderPtr
End Function

Small competition!
If anyone wants to have a try at writing the shortest function that gives the exact same results as these functions, you are welcome to try! You can find the rules above. They are as similar to Val's rules as possible while adding locale awareness support.


Edit!
After a quick test I noticed Val does raise an error for overflows (when going out of the limitations of the Double datatype). However, I guess these functions should never raise an error. Which means I should also fix the VDbl function so that it won't raise an overflow error when getting to 308 digits...

[Magic Ink]

Another approach if you want the same behavior as Val is to use Val but preprocess the string sent to it.

Function Val#(ByVal txt$)

    'Wraps VBA.Val
    '   enables handling of decimal point chars other than "."
    '   VBA val only works on decimals when the decimal char is "."

    Static normal As Boolean, init As Boolean, dp$
    
    If Not init Then
        dp$ = dpChar()
        normal = (dp$ = ".")
        init = True
    End If
    
    If normal Then
        Val = VBA.Val(txt$)
    Else
        Val = VBA.Val(Replace$(txt$, dp$, "."))
    End If

    'VB help recommends CDbl but..
    'the following dos'nt work with strings that contain numbers and text
    ' like eg. "5.4 mp" because the error is tripped and 0 is returned
    'On Error Resume Next
    'Val = CDbl(txt$)
    
End Function

Function dpChar$()

    dpChar$ = Mid$(Format$(0.1, "fixed"), 2, 1)
    
End Function