[VB6] CDbl & CDec like Val

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:
Function always returns a number in the expected datatype & never raises an error
Accepts numbers
Accepts locale decimal separator ONCE
Accepts plus or minus ONCE before any numbers
Ignores space, comma & period (thus allows to use thousands separators)
Any other character will break parsing and the current number is returned
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).

Code:

' 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...