Metamorphing Machine I rather be this walking metamorphosis
than having that old formed opinion about everything!

Let's build a transpiler! Part 44

This is the forty fourth post in a series of building a transpiler.
You can find the previous ones here.

Banker's rounding

VB has a feature that I never saw in other programming languages. When rounding numbers, it does not employ any of the traditional rounding modes like rounding down, up, towards zero, or away from zero.
It happens to be the default rounding mode used in IEEE 754:
When the digit after the least significant one is 1, 2, 3, or 4, the least significant digit remains the same. 3.14159 rounded to two places would yield 3.14, for instance.
When the digit after the least significant one is 6, 7, 8, or 9, it is increased (or decreased if negative) away from zero. Reusing our example above, 3.14159 rounded to four places would yield 3.1416.
But when the digit after the least significant one is 5, then the least significant digit remains the same if it is even.
If it is odd, it is increased (or decreased if negative) away from zero. 3.14159 rounded to three places would yield 3.142.

This mode is called "banker's rounding". It is used in the Round function, or when rounding implicitly like assigning a Currency, Decimal, Single, or Double value to an integral data type, like Byte, Integer, Long, or LongLong, or when dividing using the integer divisor operator ("\").

Back to business

Last time I said we would get ahead of ourselves for no good reason. Let me explain it.
My most important pending points so far are: After being done with them, we can start to transpile for real.
The problem is - at least for the first point - I've been there, done that... and failed.
It is a lot of boring work and I'm not sure I will succeed this time. So I started thinking about the challenges that will come after transpiling is a thing of the past.
And then I jumped into it. 😞

All work and no play makes Andrej a dull boy

So, let's talk about it. There's a lot to cover.
The code below is to convert one data type to another. While I expect that most of them will not be needed as the host language - the one we will transpile our version of VB to - probably knows how to convert a Single/float to Double, some of them will be required, like converting Decimal to Boolean.

I named the functions inspired by the Leszinsky naming convention:

Data type Abbrev.
Boolean Bln
Byte Byt
Integer Int
Long Lng
LongLong Big
Currency Cur
Decimal Dec
Single Sng
Double Dbl
Date Dtm
String Str
Object Obj
Variant Var

There are conversions I know I need to do, but I don't have an idiom to refer to some data types. Like fixed-length strings. They are not a VB proper data type.
How would be the signature for a function converting fixed-length strings to regular strings (BSTRs)?

Public Function StfToStr(ByVal Value As ...what?) As String
The same goes for converting arrays to Variants. I suppose I would need generics to be able to express that kind of function:

Dim Months(1 To 12) As Integer

Rem Implicit conversion:
Dim Ms As Variant
Ms = Months

Rem Explicit conversion:
Public Function Of T ArrToVar(ByRef Value() As T) As Variant
(...)
End Function

Ms = ArrToVar(Months)

I don't plan to handle generics for now.

Another minor issue is ParamArray. As I said in a previous post, it is a data type on its own but is not representable in plain VB either.
I refrained to write a make-believe ParamArray to Variant function because of that. But somewhen along our journey, these three functions will be needed.

Dates are special to me ! (So are Booleans!)

You will see that we have over one hundred conversion functions. To keep this number manageable, I special-cased Boolean and Date. There are only conversions from Boolean to Integer or String and back.
If there's a need to convert Boolean to, say, Double, one would need to convert it to Integer and then convert it to Double
The same goes for Date. There's conversion to Double and String and back, and that's it.

Speaking of Dates, we have some duplicated code now. I think it is unavoidable. Our Scanner class has ReadDate and ReadTime methods, but we cannot use them in a standard library that's supposed to be something apart from the compiler / transpiler.
So we have StrToDtm. As you will see, it has some requirements that are different from ReadDate/ReadTime.
For starters, "12/3456" is a valid date string. It will be converted to 3456-12-01.
"March/1" is also a valid date string. When converting it, VB will append the current year to it.
If you are so inclined to, take a look at StrToDtm. We are doing some juggling to guess how to better turn a string into a date there.

Still talking about duplication, once I got the function to convert String to Double - ValDbl - working, I copied, pasted, and adapted it to convert String to Decimal. No shame here.

By the way, these functions were poorly tested.
I cannot even test some of them. In a previous life, when I had a job, my work machine had MS Office 64-bit installed. I would open Excel's VBA editor and test functions dealing with LongLongs. Now I don't have it anymore.
I still have to figure out what to do.

One thing I am proud of is DecToStr. I have been thinking long and hard for too long now how to convert a Decimal to String.
See, Decimals have 96 bits of storage space. Ninety-six freaking bits! It is three Longs, or one and a half LongLong. To get its string representation, we would divide it by ten, get the remainder, accumulate it in a buffer, and loop until there were no more digits left.
But how does one divide three consecutive Longs by ten? I tried it before, and it is a lot of error-prone code to be produced.

This time I took a different approach. Doubles can contain any number a Decimal may have, but it has only 53 bits precision.
So, I stuffed a big enough decimal number into a double and converted it to a string. Obviously what I've got was an incomplete number; its lower digits were missing.
Then I subtracted that incomplete number from the original one. After the subtraction, we're left with a number that fits into a Double without loss.
Rinse and repeat and presto! A flawless decimal to string conversion.

I have your days numbered

Something that seemed stupid to do took me a good three or four days to nail: DtmToStr.
I tried several approaches and all of them went nowhere. The working version bellow has several magic numbers.
I am so fed up with working on it that I don't even want to go back there and improve its readability.
For posteriority, 146097 is the number of days 400 years have, 36524 the days in 100 years, and 1461 the days in 4 years.
693594 is how much I need to add to a VB date turned into a Double so the calculations work.

About singles (and doubles)

Converting Singles or Doubles to String is a whole different can of worms.
Previously I had a code based on the Grisu algorithm. It was a mess, the original code was never meant to be translated to VB.
The new one is based on the Errol algorithm. Even though I cannot be accused of understanding the paper, at least I was able to translate it.
You will see that there is a lot of duplicated code there because VB6 does not have generics.
Also, as I said before, Types are cumbersome to work, so I created classes instead - HpSng and HpDbl.

The ninth circle of hell

As I said before, VB does not have pointers. To get the address of a variable one has to use VarPtr. Using it is functionally identical to using the operator & in C.
Declaring a fixed-length string is just like declaring a C-style int16_t array. They do not have a four-byte length prefix nor are null-terminated.
While Mid$ is a VB function, it is a statement too. It gives write access to a string's character range.
In this sense, I regard VarPtr (and StrPtr, and ObjPtr), fixed-length strings, and Mid$ statement as being "low-level."

Most of the following conversion functions were written using only low-level operations. This is good. Whenever a conversion function uses a high-level operation, we're up to be trapped in a vicious circle of hell: The conversion procedure uses a function that makes use of that very same conversion procedure. It's a stack overflow waiting to happen, and not the good one.

There are only a few functions that do not follow this pattern: BigToStr, CurToStr, DecToStr, DecToStrEx, SngToStr, DblToStr, DtmToStr, StrToDtm, RoundDec, ValDbl, and ValDec. They have "high-level" functions like Format$ and MonthName.
Most certainly I'll need to go back to them in the future to deal with that.

It is a new low now, even for me

While we're talking low level, I use CopyMemory extensively for type punning. As far as I understand it, it is safe, and I had to be careful about endianness, although it is a little bit abstract now because we're not transpiling anything yet and I don't have access to a big-endian machine.

The last parts I need to talk about are unsigned arithmetic and bit shifting. VB6 does not support any of them, but to test my code I resorted to an excellent code I got from vb accelerator that provides shift functions, and I created procedures to add, subtract, and compare Longs as they were unsigned. Be sure to take a look at them.

Next week, I'll try to go back to where I stopped.

Andrej Biasic
2021-07-21

Private Module LowLevel
Option Explicit

Private Const Sign As Byte = &H80

Private Const MIN_BYTE As Byte = 0
Private Const MAX_BYTE As Byte = 255

Private Const MIN_INT As Integer = -32_768
Private Const MAX_INT As Integer = 32_767

Private Const MIN_LNG As Long = -2_147_483_648
Private Const MAX_LNG As Long = 2_147_483_647

Private Const MIN_LNGLNG As LongLong = -9_223_372_036_854_775_808^
Private Const MAX_LNGLNG As LongLong = 9_223_372_036_854_775_807^

Private Const MIN_DATE As Double = -657_434
Private Const MAX_DATE As Double = 2_958_466

Private Const MIN_DEC As Decimal = -79_228_162_514_264_337_593_543_950_335+
Private Const MAX_DEC As Decimal = 79_228_162_514_264_337_593_543_950_335+

Private Type DecimalStruct
TypeDescriptor As Integer
Places As Byte
Sign As Byte
High As Long
Low As Long
Middle As Long
End Type

Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Dest As LongPtr, ByVal Src As LongPtr, ByVal Length As Long) As Long
Private Declare Function AllocMemory Lib "ole32" Alias "CoTaskMemAlloc" (ByVal Size As Long) As LongPtr
Private Declare Sub FreeMemory Lib "ole32" Alias "CoTaskMemFree" (ByVal Ptr As LongPtr)


Private Function DecSep() As String
Exit "."
End Function


Private Function IsLittleEndian() As Boolean
Const Magic As Integer = &H1234
Dim Test As Byte
CopyMemory VarPtr(Test), VarPtr(Magic), 1
Exit Test = &H34
End Function


Public Function BlnToInt(ByVal Value As Boolean) As Integer
If Value Then Exit -1
End Function


Public Function BytToInt(ByVal Value As Byte) As Integer
Dim Result As Integer

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Result) + 1, VarPtr(Value), Len(Value)
End If

Exit Result
End Function


Public Function BytToLng(ByVal Value As Byte) As Long
Dim Result As Long

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Result) + 3, VarPtr(Value), Len(Value)
End If

Exit Result
End Function


Public Function BytToBig(ByVal Value As Byte) As LongLong
Dim Result As LongLong

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Result) + 7, VarPtr(Value), Len(Value)
End If

Exit Result
End Function


Public Function BytToCur(ByVal Value As Byte) As Currency
If Value = 0 Then Exit Function

Dim Tmp As LongLong

If IsLittleEndian Then
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Tmp) + 7, VarPtr(Value), Len(Value)
End If

Tmp *= 10_000

Dim Result As Currency
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Result)
Exit Result
End Function


Public Function BytToDec(ByVal Value As Byte) As Decimal
Dim Result As Decimal

If IsLittleEndian Then
CopyMemory VarPtr(Result) + 8, VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Result) + 10, VarPtr(Value), Len(Value)
End If

Exit Result
End Function


Public Function BytToSng(ByVal Value As Byte) As Single
If Value = 0 Then Exit Function

Const BIAS = 127
Const SIGNIFICAND = 23
If Value = 0 Then Exit Function

Dim Result As Single
Dim Tmp As Long
Dim Count As Long = 8

If IsLittleEndian Then
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Tmp) + 3, VarPtr(Value), Len(Value)
End If

Do
Tmp <<= 1
Count -= 1
Loop Until Tmp >= &H100

Tmp Xor= &H100
Count += BIAS
Count <<= SIGNIFICAND

Tmp <<= SIGNIFICAND - Len(Value) * 8
Tmp Or=Count
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Tmp)
Exit Result
End Function


Public Function BytToDbl(ByVal Value As Byte) As Double
If Value = 0 Then Exit Function

Const BIAS = 1023
Const SIGNIFICAND = 52
If Value = 0 Then Exit Function

Dim Result As Double
Dim Tmp As LongLong
Dim Count As LongLong = 8

If IsLittleEndian Then
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Tmp) + 7, VarPtr(Value), Len(Value)
End If

Do
Tmp <<= 1
Count -= 1
Loop Until Tmp >= &H100

Tmp Xor= &H100
Count += BIAS
Count <<= SIGNIFICAND

Tmp <<= SIGNIFICAND - Len(Value) * 8
Tmp Or= Count
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Tmp)
Exit Result
End Function


Public Function BytToStr(ByVal Value As Byte) As String
Dim Integral As LongLong = BytToBig(Value)
Exit BigToStr(Integral)
End Function


Public Function BytToVar(ByVal Value As Byte) As Variant
Dim Result As Variant
CopyMemory VarPtr(Result), VarPtr(vbByte), SizeOf(Integer)
CopyMemory VarPtr(Result) + 8, VarPtr(Value), Len(Value)
Exit Result
End Function


Public Function IntToBln(ByVal Value As Integer) As Boolean
Exit Value <> 0
End Function


Public Function IntToByt(ByVal Value As Integer) As Byte
If Value < MIN_BYTE OrElse Value > MAX_BYTE Then Err.Raise 6
Dim Result As Byte

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Value) + 1, Len(Result)
End If

Exit Result
End Function


Public Function IntToLng(ByVal Value As Integer) As Long
Dim Result As Long
If Value < 0 Then Result = -1 'Sign-extend

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Result) + 2, VarPtr(Value), Len(Value)
End If

Exit Result
End Function


Public Function IntToBig(ByVal Value As Integer) As LongLong
Dim Result As LongLong
If Value < 0 Then Result = -1 'Sign-extend

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Result) + 6, VarPtr(Value), Len(Value)
End If

Exit Result
End Function


Public Function IntToCur(ByVal Value As Integer) As Currency
If Value = 0 Then Exit Function

Dim Tmp As LongLong

If IsLittleEndian Then
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Tmp) + 6, VarPtr(Value), Len(Value)
End If

Tmp *= 10_000
If Value < 0 Then Tmp = -Tmp

Dim Result As Currency
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Tmp)
Exit Result
End Function


Public Function IntToDec(ByVal Value As Integer) As Decimal
If Value = 0 Then Exit Function
Dim Result As Decimal

If Value < 0 Then
CopyMemory VarPtr(Result) + 3, VarPtr(Sign), SizeOf(Byte)
If Value <> MIN_INT Then Value = -Value
End If

If IsLittleEndian Then
CopyMemory VarPtr(Result) + 8, VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Result) + 10, VarPtr(Value), Len(Value)
End If

Exit Result
End Function


Public Function IntToSng(ByVal Value As Integer) As Single
If Value = 0 Then Exit Function

Const BIAS = 127
Const SIGNIFICAND = 23

Dim IsNeg As Boolean = Value < 0
Dim Result As Single
Dim Tmp As Long
Dim Count As Long = SizeOf(Integer) * 8

If IsNeg AndAlso Value <> MIN_INT Then Value = -Value

If IsLittleEndian Then
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Tmp) + 2, VarPtr(Value), Len(Value)
End If

Do
Tmp <<= 1
Count -= 1
Loop Until Tmp >= &H10000

Tmp Xor= &H10000
Count += BIAS
Count <<= SIGNIFICAND

Tmp <<= SIGNIFICAND - Len(Value) * 8
Tmp Or= Count
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Tmp)
If IsNeg Then Result = -Result
Exit Result
End Function


Public Function IntToDbl(ByVal Value As Integer) As Double
If Value = 0 Then Exit Function

Const BIAS = 1023
Const SIGNIFICAND = 52

Dim IsNeg As Boolean = Value < 0
Dim Result As Double
Dim Tmp As LongLong
Dim Count As LongLong = SizeOf(Integer) * 8

If IsNeg AndAlso Value <> MIN_NEG Then Value = -Value

If IsLittleEndian Then
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Tmp) + 6, VarPtr(Value), Len(Value)
End If

Do
Tmp <<= 1
Count -= 1
Loop Until Tmp >= &H10000

Tmp Xor= &H10000
Count += BIAS
Count <<= SIGNIFICAND

Tmp <<= SIGNIFICAND - Len(Value) * 8
Tmp Or= Count
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Tmp)
If IsNeg Then Result = -Result
Exit Result
End Function


Public Function IntToStr(ByVal Value As Integer) As String
Dim Integral As LongLong = IntToBig(Value)
Exit BigToStr(Integral)
End Function


Public Function IntToVar(ByVal Value As Integer) As Variant
Dim Result As Variant
CopyMemory VarPtr(Result), VarPtr(vbInteger), Len(Value)
CopyMemory VarPtr(Result) + 8, VarPtr(Value), Len(Value)
Exit Result
End Function


Public Function LngToByt(ByVal Value As Long) As Byte
If Value < MIN_BYTE OrElse Value > MAX_BYTE Then Err.Raise 6
Dim Result As Byte

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Value) + 3, Len(Result)
End If

Exit Result
End Function


Public Function LngToInt(ByVal Value As Long) As Integer
If Value < MIN_INT OrElse Value > MAX_INT Then Err.Raise 6
Dim Result As Integer

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Value) + 2, Len(Result)
End If

Exit Result
End Function


Public Function LngToBig(ByVal Value As Long) As LongLong
Dim Result As LongLong
If Value < 0 Then Result = -1 'Sign-extend

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Result) + 2, VarPtr(Value), Len(Value)
End If

Exit Result
End Function


Public Function LngToCur(ByVal Value As Long) As Currency
If Value = 0 Then Exit Function

Dim IsNeg As Boolean = Value < 0
If IsNeg AndAlso Value <> MIN_LNG Then Value = -Value

Dim Tmp As LongLong

If IsLittleEndian Then
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Tmp) + 4, VarPtr(Value), Len(Value)
End If

Tmp *= 10_000
If IsNeg Then Tmp = -Tmp

Dim Result As Currency
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Tmp)
Exit Result
End Function


Public Function LngToDec(ByVal Value As Long) As Decimal
If Value = 0 Then Exit Function
Dim Result As Decimal

If Value < 0 Then
CopyMemory VarPtr(Result) + 3, VarPtr(Sign), Len(Sign)
If Value <> MIN_LNG Then Value = -Value
End If

CopyMemory VarPtr(Result) + 8, VarPtr(Value), Len(Value)
Exit Result
End Function


Public Function LngToSng(ByVal Value As Long) As Single
If Value = 0 Then Exit Function

Const BIAS = 127
Const SIGNIFICAND = 23

Dim IsNeg As Boolean = Value < 0
Dim Result As Single
Dim Tmp As LongLong
Dim Count As LongLong = SizeOf(Long) * 8

If IsNeg AndAlso Value <> MIN_LNG Then Value = -Value

If IsLittleEndian Then
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Tmp) + 4, VarPtr(Value), Len(Value)
End If

Do
Tmp <<= 1
Count += 1
Loop Until Tmp >= &H1_0000_0000

Tmp Xor= &H1_0000_0000
Count += BIAS
Count <<= SIGNIFICAND + 32

Tmp <<= SIGNIFICAND + 32 - Len(Value) * 8
Tmp Or= Count

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Value)
Else
CopyMemory VarPtr(Result), VarPtr(Tmp) + 4, Len(Value)
End If

If IsNeg Then Result = -Result
Exit Result
End Function


Public Function LngToDbl(ByVal Value As Long) As Double
If Value = 0 Then Exit Function

Const BIAS = 1023
Const SIGNIFICAND = 52

Dim IsNeg As Boolean = Value < 0
Dim Result As Double
Dim Tmp As LongLong
Dim Count As LongLong = SizeOf(Long) * 8

If IsNeg AndAlso Value <> MIN_LNG Then Value = -Value

If IsLittleEndian Then
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Tmp) + 4, VarPtr(Value), Len(Value)
End If

Do
Tmp <<= 1
Count -= 1
Loop Until Tmp >= &H1_0000_0000

Tmp Xor= &H1_0000_0000
Count += BIAS
Count <<= SIGNIFICAND + 32

Tmp <<= SIGNIFICAND + 32 - Len(Value) * 8
Tmp Or= Count
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Tmp)
If IsNeg Then Result = -Result
Exit Result
End Function


Public Function LngToStr(ByVal Value As Long) As String
Dim Integral As LongLong = LngToBig(Value)
Exit BigToStr(Integral)
End Function


Public Function LngToVar(ByVal Value As Long) As Variant
Dim Result As Variant
CopyMemory VarPtr(Result), VarPtr(vbLong), SizeOf(Integer)
CopyMemory VarPtr(Result) + 8, VarPtr(Value), Len(Value)
Exit Result
End Function


Public Function BigToByt(ByVal Value As LongLong) As Byte
If Value < MIN_BYTE OrElse Value > MAX_BYTE Then Err.Raise 6
Dim Result As Byte

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Value) + 7, Len(Result)
End If

Exit Result
End Function


Public Function BigToInt(ByVal Value As LongLong) As Integer
If Value < MIN_INT OrElse Value > MAX_INT Then Err.Raise 6
Dim Result As Integer

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Value) + 6, Len(Result)
End If

Exit Result
End Function


Public Function BigToLng(ByVal Value As LongLong) As Long
If Value < MIN_LNG OrElse Value > MAX_LNG Then Err.Raise 6
Dim Result As Long

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Value) + 4, Len(Result)
End If

Exit Result
End Function


Public Function BigToCur(ByVal Value As LongLong) As Currency
Select Case Value
Case 0
Exit Function

Case Is > 922_337_203_685_477, Is < -922_337_203_685_477
Err.Raise 6
End Select

Value *= 10_000
Dim Result As Currency
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Tmp)
Exit Result
End Function


Public Function BigToDec(ByVal Value As LongLong) As Decimal
If Value = 0 Then Exit Function
Dim Result As Decimal

If Value < 0 Then
CopyMemory VarPtr(Result) + 3, VarPtr(Sign), SizeOf(Byte)
If Value <> MIN_LNGLNG Then Value = -Value
End If

CopyMemory VarPtr(Result) + 8, VarPtr(Value), SizeOf(Long)
CopyMemory VarPtr(Result) + 12, VarPtr(Value) + 4, SizeOf(Long)
Exit Result
End Function


Public Function BigToSng(ByVal Value As LongLong) As Single
If Value = 0 Then Exit Function

Dim IsNeg As Boolean = Value < 0
If IsNeg AndAlso Value <> MIN_LNGLNG Then Value = -Value
Dim Result As Single

Do
If Value And 1 Then Result += 1
Value >>= 1
Result <<= 1
Loop Until Value = 0

If IsNeg Then Result = -Result
Exit Result
End Function


Public Function BigToDbl(ByVal Value As LongLong) As Double
If Value = 0 Then Exit Function

Dim IsNeg As Boolean = Value < 0
If IsNeg AndAlso Value <> MIN_LNGLNG Then Value = -Value
Dim Result As Double

Do
If Value And 1 Then Result += 1
Value >>= 1
Result <<= 1
Loop Until Value = 0

If IsNeg Then Result = -Result
Exit Result
End Function


Public Function BigToStr(ByVal Value As LongLong) As String
Const START_BYTE = 89
Dim IsNeg As Boolean = Value < 0
Dim Digit As Integer
Dim Idx As Integer = START_BYTE
Dim Length As Long
Dim Ptr As LongPtr
Dim Result As String
Dim Buffer As String * 46

If IsNeg AndAlso Value <> MIN_LNGLNG Then Value = -Value

Do
Digit = Value Mod 10
Value \= 10
If Digit < 0 Then Digit = -Digit
MidB$(Buffer, Idx, 1) = Chr$(Digit + Asc("0"))
Idx -= 2
Loop Until Value = 0

If IsNeg Then
MidB$(Buffer, Idx, 1) = "-"
Idx -= 2
End If

Length = START_BYTE - Idx
CopyMemory VarPtr(Buffer) + Idx, VarPtr(Length), Len(Length)
Length += Len(Length) + SizeOf(Integer)
Ptr = AllocMemory(Length)
Ptr = VarPtr(Buffer) + Idx - 3 + Len(Length)
CopyMemory VarPtr(Result), VarPtr(Ptr), SizeOf(LongPtr)
Exit Result
End Function


Public Function BigToVar(ByVal Value As LongLong) As Variant
Dim Result As Variant
CopyMemory VarPtr(Result), VarPtr(vbLongLong), SizeOf(Integer)
CopyMemory VarPtr(Result) + 8, VarPtr(Value), Len(Value)
Exit Result
End Function


Public Function CurToByt(ByVal Value As Currency) As Byte
If Value = 0 Then Exit Function

Value = RoundCur(Value, 0)
If Value < MIN_BYTE OrElse Value > MAX_BYTE Then Err.Raise 6
Value /= 10_000@

Dim Result As Byte

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Value), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Value) + 7, Len(Result)
End If

Exit Result
End Function


Public Function CurToInt(ByVal Value As Currency) As Integer
If Value = 0 Then Exit Function

Dim Tmp As LongLong
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Tmp \= 10_000
If Tmp < MIN_INT OrElse Tmp > MAX_INT Then Err.Raise 6

Dim Result As Integer

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Tmp) + 6, Len(Result)
End If

Exit Result
End Function


Public Function CurToLng(ByVal Value As Currency) As Long
If Value = 0 Then Exit Function

Dim Tmp As LongLong
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Tmp \= 10_000
If Tmp < MIN_LNG OrElse Tmp > MAX_LNG Then Err.Raise 6

Dim Result As Long

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Tmp) + 4, Len(Result)
End If

Exit Result
End Function


Public Function CurToBig(ByVal Value As Currency) As LongLong
Dim Result As LongLong
CopyMemory VarPtr(Result), VarPtr(Value), Len(Result)
Result \= 10_000
Exit Result
End Function


Public Function CurToDec(ByVal Value As Currency) As Decimal
If Value = 0 Then Exit Function
Dim Result As Decimal

If Value < 0 Then
CopyMemory VarPtr(Result) + SizeOf(Integer) + SizeOf(Byte), VarPtr(Sign), SizeOf(Byte)
If Value <> MIN_CUR Then Value = -Value
End If

CopyMemory VarPtr(Result) + 8, VarPtr(Value), SizeOf(Currency)

Const Places As Byte = 4
CopyMemory VarPtr(Result) + 2, VarPtr(Places), Len(Places)
Exit Result
End Function


Public Function CurToSng(ByVal Value As Currency) As Single
If Value = 0 Then Exit Function

Dim Tmp As LongLong
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)

Dim Result As Single = BigToSng(Tmp)
Result /= 10_000!
Exit Result
End Function


Public Function CurToDbl(ByVal Value As Currency) As Double
If Value = 0 Then Exit Function

Dim Tmp As LongLong
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)

Dim Result As Double = BigToDbl(Tmp)
Result /= 10_000.0
Exit Result
End Function


Public Function CurToStr(ByVal Value As Currency) As String
If Value = 0 Then Exit "0"

Dim Tmp As LongLong
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
If Tmp = MIN_LNGLNG Then Exit "-922337203685477" & DecSep & "5808"

Dim IsNeg As Boolean = Value < 0
If IsNeg Then Value = -Value
Dim Result As String = BigToStr(Tmp)

Select Case Len(Result)
Case 1
Result = "0" & DecSep & "000" & Result

Case 2
Result = "0" & DecSep & "00" & Result

Case 3
Result = "0" & DecSep & "0" & Result

Case 4
Result = "0" & DecSep & Result

Case Else
Result = Left$(Result, Len(Result) - 4) & DecSep & Right$(Result, 4)
End Select

If IsNeg Then Result = "-" & Result
Exit Result
End Function


Public Function CurToVar(ByVal Value As Currency) As Variant
Dim Result As Variant
CopyMemory VarPtr(Result), VarPtr(vbCurrency), SizeOf(Integer)
CopyMemory VarPtr(Result) + 8, VarPtr(Value), Len(Value)
Exit Result
End Function


Public Function DecToByt(ByVal Value As Decimal) As Byte
If Value = 0 Then Exit Function

Value = RoundDec(Value, 0)
Dim Dec As DecimalStruct
CopyMemory VarPtr(Dec), VarPtr(Value), Len(Value)
If Dec.Sign <> 0 OrElse Dec.Middle <> 0 OrElse Dec.High <> 0 OrElse Dec.Low > MAX_BYTE Then Err.Raise 6

Dim Result As Byte
CopyMemory VarPtr(Result), VarPtr(Dec.Low), Len(Result)
Exit Result
End Function


Public Function DecToInt(ByVal Value As Decimal) As Integer
If Value = 0 Then Exit Function

Value = RoundDec(Value, 0)
Dim Dec As DecimalStruct
CopyMemory VarPtr(Dec), VarPtr(Value), Len(Value)

If Dec.Middle <> 0 OrElse _
Dec.High <> 0 OrElse _
Dec.Sign <> 0 AndAlso Dec.Low > MAX_INT + 1 OrElse _
Dec.Sign = 0 AndAlso Dec.Low > MAX_INT _
Then Err.Raise 6

Dim Result As Integer
CopyMemory VarPtr(Result), VarPtr(Dec.Low), Len(Result)
Exit Result
End Function


Public Function DecToLng(ByVal Value As Decimal) As Long
If Value = 0 Then Exit Function

Value = RoundDec(Value, 0)
Dim Dec As DecimalStruct
CopyMemory VarPtr(Dec), VarPtr(Value), Len(Value)

If Dec.Middle <> 0 OrElse _
Dec.High <> 0 OrElse _
Dec.Sign = 0 AndAlso Dec.Low = MIN_LNG _
Then Err.Raise 6

Dim Result As Long
CopyMemory VarPtr(Result), VarPtr(Dec.Low), Len(Result)
Exit Result
End Function


Public Function DecToBig(ByVal Value As Decimal) As LongLong
If Value = 0 Then Exit Function

Value = RoundDec(Value, 0)
Dim Dec As DecimalStruct
CopyMemory VarPtr(Dec), VarPtr(Value), Len(Value)

If Dec.High <> 0 OrElse _
Dec.Sign = 0 AndAlso Dec.Middle = MIN_LNG AndAlso Dec.Low = MIN_LNG _
Then Err.Raise 5

Dim Result As LongLong
CopyMemory VarPtr(Result), VarPtr(Dec.Low), Len(Result)
Exit Result
End Function


Public Function DecToCur(ByVal Value As Decimal) As Currency
If Value = 0 Then Exit Function

Dim T As DecimalStruct
CopyMemory VarPtr(T), VarPtr(Value), Len(Value)
If T.High <> 0 OrElse T.Middle = MIN_LNG AndAlso T.Low = MIN_LNG AndAlso T.Sign = 0 And T.Places = 0 Then Err.Raise 6

Dim Tmp As LongLong
CopyMemory VarPtr(Tmp), VarPtr(Value) + 8, SizeOf(LongLong)

While T.Places
Tmp \= 10
T.Places -= 1
Wend

If T.Sign AndAlso Tmp <> MIN_LNGLNG Then Tmp = -Tmp
Dim Result As Currency
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(T)
Exit Result
End Function


Public Function DecToSng(ByVal Value As Decimal) As Single
Dim P As Long
Dim Result As Single
Dim T As DecimalStruct

CopyMemory VarPtr(T), VarPtr(Value), SizeOf(Decimal)
If T.High = 0 AndAlso T.Middle = 0 AndAlso T.Low = 0 Then Exit Function

If T.High <> 0 Then
P = &H8000_0000

Do
Result *= 2
If P And T.High Then Result += 1
P >>= 1
Loop While P
End If

If T.High <> 0 Or T.Middle <> 0 Then
P = &H8000_0000

Do
Result *= 2
If P And T.Middle Then Result += 1
P >>= 1
Loop While P
End If

P = &H8000_0000

Do
Result *= 2
If P And T.Low Then Result += 1
P >>= 1
Loop While P

While T.Places
Result /= 10
T.Places -= 1
Wend

If T.Sign Then Result = -Result
Exit Result
End Function


Public Function DecToDbl(ByVal Value As Variant) As Double
Dim P As Long
Dim Result As Double
Dim T As DecimalStruct

CopyMemory VarPtr(T), VarPtr(Value), Len(T)
If T.High = 0 AndAlso T.Middle = 0 AndAlso T.Low = 0 Then Exit Function

If T.High <> 0 Then
P = &H8000_0000

Do
Result *= 2
If P And T.High Then Result += 1
P >>= 1
Loop While P
End If

If T.High <> 0 OrElse T.Middle <> 0 Then
P = &H8000_0000

Do
Result *= 2
If P AndAlso T.Middle Then Result += 1
P >>= 1
Loop While P
End If

P = &H8000_0000

Do
Result *= 2
If P AndAlso T.Low Then Result += 1
P >>= 1
Loop While P

While T.Places
Result /= 10
T.Places -= 1
Wend

If T.Sign Then Result = -Result
Exit Result
End Function


Public Function DecToStr(ByVal Value As Decimal) As String
Dim T As DecimalStruct
CopyMemory VarPtr(T), VarPtr(Value), Len(Value)

Dim Result As String
Dim Buffer As String * 31
Dim Idx As Integer = 61
Dim Digit As Integer

If T.High <> 0 Then Exit DecToStrEx(Value)

If T.High = 0 AndAlso T.Middle <> 0 Then
If T.Middle > 0 AndAlso T.Middle <= &H1F_FFFF Then
Dim Dbl As Double = DecToDbl(Value)
Exit DblToStr(Dbl)
End If

Exit DecToStrEx(Value)
End If

If T.High = 0 AndAlso T.Middle = 0 Then
Dim Div As Long = IIf(T.Low < 0, -10, 10)
Dim Dot As Integer = IIf(T.Places, T.Places, -1)

Do
Digit = T.Low Mod Div
MidB$(Buffer, Idx, 1) = Chr$(Digit + AscW("0"))

T.Low \= Div
Idx -= 2
Dot -= 1

If Dot = 0 Then
MidB$(Buffer, Idx, 1) = DecSep
Idx -= 2

If T.Low = 0 Then
MidB$(Buffer, Idx, 1) = "0"
Idx -= 2
End If
End If
Loop While T.Low

If T.Sign Then
MidB$(Buffer, Idx, 1) = "-"
Idx -= 2
End If

Exit MidB$(Buffer, Idx)
End If
End Function


Public Function DecToVar(ByVal Value As Decimal) As Variant
Dim Result As Variant
CopyMemory VarPtr(Result), VarPtr(vbDecimal), SizeOf(Integer)
CopyMemory VarPtr(Result) + 8, VarPtr(Value), 16
Exit Result
End Function


Public Function SngToByt(ByVal Value As Single) As Byte
If Value = 0 Then Exit Function

Value = RoundSng(Value, 0)
If Value < MIN_BYTE OrElse Value > MAX_BYTE Then Err.Raise 6

Dim Tmp As Long
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Tmp And= &B1111111000000000000000
Tmp Or= &B10000000000000000000000
Tmp >>= 15

Dim Result As Byte

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Tmp) + 3, Len(Result)
End If

Exit Result
End Function


Public Function SngToInt(ByVal Value As Single) As Integer
If Value = 0 Then Exit Function

Value = RoundSng(Value, 0)
If Value < MIN_INT OrElse Value > MAX_INT Then Err.Raise 6

Dim Tmp As Long
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Tmp And= &B11111111111111100000000
Tmp Or= &B100000000000000000000000
Tmp >>= 8
If Value < 0 Then Tmp = -Tmp

Dim Result As Integer

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Tmp) + 2, Len(Result)
End If

Exit Result
End Function


Public Function SngToLng(ByVal Value As Single) As Long
If Value = 0 Then Exit Function

Const BIAS = 127
Const SIGNIFICAND = 23
Value = RoundSng(Value)
If Value < MIN_LNG OrElse Value > MAX_LNG Then Err.Raise 6

Dim Result As Long
CopyMemory VarPtr(Result), VarPtr(Value), Len(Value)

Dim Places As Byte = (((Result And &B1111111100000000000000000000000) >> SIGNIFICAND) + BIAS) And &B11111111
Result And= &B11111111111111111111111
Result Or= &B100000000000000000000000
Result >>= SIGNIFICAND - Places - 1
If Value < 0 Then Result = -Result
Exit Result
End Function


Public Function SngToBig(ByVal Value As Single) As LongLong
If Value = 0 Then Exit Function

Const BIAS = 127
Const SIGNIFICAND = 23
Value = RoundSng(Value, 0)
If Value < MIN_LNGLNG OrElse Value > MAX_LNGLNG Then Err.Raise 6

Dim Result As LongLong

If IsLittleEndian Then
CopyMemory VarPtr(Result) + SizeOf(Long), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Result), VarPtr(Value), Len(Value)
End If

Dim Places As Byte = (((Result And &B111111110000000000000000000000000000000000000000000000000000000) >> (SIGNIFICAND + 32)) + BIAS) And &B11111111
Result And= &B1111111111111111111111100000000000000000000000000000000
Result Or= &B10000000000000000000000000000000000000000000000000000000
Result >>= SIGNIFICAND + 32 - Places - 1
If Value < 0 Then Result = -Result
Exit Result
End Function


Public Function SngToCur(ByVal Value As Single) As Currency
If Value = 0 Then Exit Function

Value *= 10_000
Dim Tmp As LongLong = SngToBig(Value)

Dim Result As Currency
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Tmp)
Exit Result
End Function


Public Function SngToDec(ByVal Value As Single) As Decimal
Dim Result As String = SngToStr(Value)
Exit StrToDec(Result)
End Function


Public Function SngToDbl(ByVal Value As Single) As Double
Dim Tmp As LongLong

If IsLittleEndian Then
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Else
CopyMemory VarPtr(Tmp), VarPtr(Value) + 4, Len(Value)
End If

Dim Dbl As LongLong = ((Tmp And &H7F800000) + &H180000000) << 32
Tmp And= &H7FFFFF
Tmp <<= 29
Dbl Or= Tmp

Dim Result As Double
CopyMemory VarPtr(Result), VarPtr(Dbl), Len(Dbl)
If Value < 0 Then Result = -Result
Exit Result
End Function


Public Function SngToStr(ByVal Value As Single) As String
Dim DoIt As Boolean
Dim IsSpecial As Boolean
Dim Exponent As Long
Dim Tmp As String
Dim Sign As String

Dim Var As Variant = SngToVar(Value)
Dim Result As String = FloatToString(Var, Exponent, IsSpecial)

If Left$(Result, 1) = "-" Then
Sign = "-"
Result = Mid$(Result, 2)
End If

Dim Length As Integer = Len(Result)
If Length > 7 Then GoSub RoundString

If Not IsSpecial Then
Select Case Exponent
Case Is > 7
Tmp = Left$(Result, 1)
If Length > 1 Then Tmp &= DecSep & Mid$(Result, 2)
Result = Tmp & "E+" & Format$(Exponent - 1, "00")

Case 1 To 7
If Length <= Exponent Then
Result &= String$(Exponent - Length, "0")
Else
Result = Left$(Result, Exponent) & DecSep & Mid$(Result, Exponent + 1)
End If

Case 0
Result = "0" & DecSep & Result

Case -7 To -1
If Abs(Exponent) + Length > 7 Then GoTo CaseElse
Result = "0" & DecSep & String(-Exponent, "0") & Result

Case Else ' Is < -7
CaseElse:
Tmp = Left$(Result, 1)
If Length > 1 Then Tmp &= DecSep & Mid$(Result, 2)
Result = Tmp & "E" & Format$(Exponent - 1, "00")
End Select

Result = Sign & Result
End If

Exit Result

RoundString:
Select Case Mid$(Result, 8, 1)
Case "6" To "9"
DoIt = True

Case "5"
Select Case Mid$(Result, 7)
Case "1", "3", "5", "7", "9"
DoIt = True
End Select
End Select

If DoIt Then
Dim Idx As Integer = 7

Do
Dim Digit As Integer = Asc(Mid$(Result, Idx, 1)) - Asc("0")
Digit += 1

If Digit > 9 Then Digit = 0
Mid$(Result, Idx, 1) = Chr$(Digit + Asc("0"))
Idx -= 1
Loop While Digit = 0
End If

Result = Left$(Result, 7)
Return
End Function


Public Function SngToVar(ByVal Value As Single) As Variant
Dim Result As Variant
CopyMemory VarPtr(Result), VarPtr(vbSingle), SizeOf(Integer)
CopyMemory VarPtr(Result) + 8, VarPtr(Value), Len(Value)
Exit Result
End Function


Public Function DblToByt(ByVal Value As Double) As Byte
If Value = 0 Then Exit Function

Value = RoundDbl(Value, 0)
If Value < MIN_BYTE OrElse Value > MAX_BYTE Then Err.Raise 6

Dim Tmp As Long = DblToLng(Value)
Dim Result As Byte

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Tmp) + 3, Len(Result)
End If

Exit Result
End Function


Public Function DblToInt(ByVal Value As Double) As Integer
If Value = 0 Then Exit Function

Value = RoundDbl(Value, 0)
If Value < MIN_INT OrElse Value > MAX_INT Then Err.Raise 6

Dim Tmp As Long = DblToLng(Value)
Dim Result As Integer

If IsLittleEndian Then
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Result)
Else
CopyMemory VarPtr(Result), VarPtr(Tmp) + 2, Len(Result)
End If

Exit Result
End Function


Public Function DblToLng(ByVal Value As Double) As Long
If Value = 0 Then Exit Function

Value = RoundDbl(Value, 0)
If Value < MIN_LNG OrElse Value > MAX_LNG Then Err.Raise 6
Dim Tmp As LongLong
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)

Dim Result As Long = (Tmp And &B1111111111111111111111111111111000000000000000000000) >> 21
Result Or= &H8000_0000
Dim Places As Integer = ((Tmp And &B111111111110000000000000000000000000000000000000000000000000000) >> 52) - 1023
Result >>= 31 - Places
If Tmp < 0 Then Result = -Result
Exit Result
End Function


Public Function DblToBig(ByVal Value As Double) As LongLong
If Value = 0 Then Exit Function

Value = RoundDbl(Value, 0)
If Value < MIN_LNGLNG OrElse Value > MAX_LNGLNG Then Err.Raise 6

Dim Result As LongLong
CopyMemory VarPtr(Result), VarPtr(Value), Len(Value)

Dim Places As Integer = ((Result And &B111111111110000000000000000000000000000000000000000000000000000) >> 52) - 1023
Result And= &B1111111111111111111111111111111111111111111111111111
Result Or= &B10000000000000000000000000000000000000000000000000000
Result >>= 52 - Places
Exit Result
End Function


Public Function DblToCur(ByVal Value As Double) As Currency
If Value = 0 Then Exit Function

Value *= 10_000
Value = RoundDbl(Value, 0)
If Value < -9_223_372_036_854_775_808 OrElse Value > 9_223_372_036_854_775_807 Then Err.Raise 6

Dim Tmp As LongLong
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)

Dim Result As LongLong = (Tmp And &B1111111111111111111111111111111000000000000000000000) >> 21
Result Or= &H10_0000_0000_0000

Dim Places As Integer = ((Tmp And &B111111111110000000000000000000000000000000000000000000000000000) >> 52) - 1023
Result >>= 31 - Places
If Tmp < 0 Then Result = -Result

If IsLittleEndian Then
CopyMemory VarPtr(DblToCur), VarPtr(Result), Len(Result)
Else
CopyMemory VarPtr(DblToCur), VarPtr(Result), Len(Result)
End If

End Function


Public Function DblToDec(ByVal Value As Double) As Decimal
Dim Tmp As String = DblToStr(Value)
Exit StrToDec(Tmp)
End Function


Public Function DblToSng(ByVal Value As Double) As Single
Dim Tmp As LongLong
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)

Dim Sng As Long = ((Tmp And &H7FF0_0000_0000_0000) >> 32) + &H80_0000
If Sng < 0 Then Err.Raise 6
Tmp >>= 29
Tmp And= &H7F_FFFF
Sng Or= Tmp

Dim Result As Single
CopyMemory VarPtr(Result), VarPtr(Sng), Len(Sng)
If Value < 0 Then Result = -Result
Exit Result
End Function


Public Function DblToDtm(ByVal Value As Double) As Date
If Value < MIN_DATE OrElse Value >= MAX_DATE Then Err.Raise 6
Dim Result As Date
CopyMemory VarPtr(Result), VarPtr(Value), Len(Value)
Exit Result
End Function


Public Function DblToStr(ByVal Value As Double) As String
Dim DoIt As Boolean
Dim IsSpecial As Boolean
Dim Exponent As Long
Dim Tmp As String
Dim Sign As String

Dim Var As Variant = DblToVar(Value)
Dim Result As String = FloatToString(Var, Exponent, IsSpecial)

If Left$(Result, 1) = "-" Then
Sign = "-"
Result = Mid$(Result, 2)
End If

Dim Length As Integer = Len(Result)
If Length > 15 Then GoSub RoundString

If Not IsSpecial Then
Select Case Exponent
Case Is > 15
Tmp = Left$(Result, 1)
If Length > 1 Then Tmp &= DecSep & Mid$(Result, 2)
Result = Tmp & "E+" & Format$(Exponent - 1, "00")

Case 1 To 15
If Length <= Exponent Then
Result &= String$(Exponent - Length, "0")
Else
Result = Left$(Result, Exponent) & DecSep & Mid$(Result, Exponent + 1)
End If

Case 0
Result = "0" & DecSep & Result

Case -15 To -1
If Abs(Exponent) + Length > 15 Then GoTo CaseElse
Result = "0" & DecSep & String$(-Exponent, "0") & Result

Case Else ' Is < -14
CaseElse:
Tmp = Left$(Result, 1)
If Length > 1 Then Tmp &= DecSep & Mid$(Result, 2)
Result = Tmp & "E" & Format$(Exponent - 1, "00")
End Select

Result = Sign & Result
End If

Exit Result

RoundString:
Select Case Mid$(Result, 16, 1)
Case "6" To "9"
DoIt = True

Case "5"
Select Case Mid$(Result, 15)
Case "1", "3", "5", "7", "9"
DoIt = True
End Select
End Select

If DoIt Then
Dim Idx As Integer = 15

Do
Dim Digit As Integer = Asc(Mid$(Result, Idx, 1)) - Asc("0")
Digit += 1

If Digit > 9 Then Digit = 0
Mid$(Result, Idx, 1) = Chr$(Digit + Asc("0"))
Idx -= 1
Loop While Digit = 0
End If

Result = Left$(Result, 15)
Return
End Function


Public Function DblToVar(ByVal Value As Double) As Variant
Dim Result As Variant
CopyMemory VarPtr(Result), VarPtr(vbDouble), SizeOf(Integer)
CopyMemory VarPtr(Result) + 8, VarPtr(Value), Len(Value)
Exit Result
End Function


Public Function DtmToDbl(ByVal Value As Date) As Double
Dim Result As Double
CopyMemory VarPtr(Result), VarPtr(Value), Len(Value)
Exit Result
End Function


Public Function StrToByt(ByVal Value As String) As Byte
Dim Result As Double = StrToDbl(Value)
Exit DblToByt(Value)
End Function


Public Function StrToInt(ByVal Value As String) As Integer
Dim Result As Double = StrToDbl(Value)
Exit DblToInt(Value)
End Function


Public Function StrToLng(ByVal Value As String) As Long
Dim Result As Double = StrToDbl(Value)
Exit DblToLng(Value)
End Function


Public Function StrToBig(ByVal Value As String) As LongLong
Dim Result As Decimal = StrToDec(Value)
Exit DecToBig(Result)
End Function


Public Function StrToCur(ByVal Value As String) As Currency
Dim Tmp As Decimal = StrToDec(Value)
Tmp = RoundDec(Tmp, 4)
Dim T As DecimalStruct
CopyMemory VarPtr(T), VarPtr(Tmp) Len(Tmp)
If T.High <> 0 OrElse T.Middle = -1 AndAlso T.Low = -1 AndAlso T.Sign = 0 Then Err.Raise 6

Dim Result As Currency
CopyMemory VarPtr(Result), VarPtr(T.Low), Len(T.Low)
CopyMemory VarPtr(Result) + Len(T.Low), VarPtr(T.Middle), Len(T.Middle)
If T.Sign AndAlso Result <> MIN_CUR Then Result = -Result
Exit Result
End Function


Public Function StrToDec(ByVal Value As String) As Decimal
Exit ValDec(Value, RaiseError:=True)
End Function


Public Function StrToSng(ByVal Value As String) As Single
Dim Result As Double = StrToDbl(Value)
Exit DblToSng(Result)
End Function


Public Function StrToDbl(ByVal Value As String) As Double
StrToDbl = ValDbl(Value, RaiseError:=True)
End Function


Public Function StrToVar(ByVal Value As String) As Variant
Dim Length As Long
CopyMemory VarPtr(Length), StrPtr(Value) - Len(Length), Len(Length)

Dim Size As Long = Length + Len(Length) + SizeOf(Integer)
Dim Ptr As LongPtr = AllocMemory(Size)
CopyMemory Ptr, StrPtr(Value) - Len(Length), Size
Ptr += Len(Length)

CopyMemory VarPtr(StrToVar), VarPtr(vbString), SizeOf(Integer)
CopyMemory VarPtr(StrToVar) + 8, VarPtr(Ptr), Size
End Function


Public Function ObjToVar(ByVal Value As Object) As Variant
Dim Result As Variant
CopyMemory VarPtr(Result), VarPtr(vbObject), SizeOf(Integer)

If Value IsNot Nothing Then
CopyMemory VarPtr(Result) + 8, VarPtr(Value), SizeOf(LongPtr)

Dim Dummy As Object
Dim Nil As Object
Set Dummy = Value 'Increment reference
CopyMemory VarPtr(Dummy), VarPtr(Nil), SizeOf(LongPtr)
End If

Exit Result
End Function


Public Function VarToByt(ByVal Value As Variant) As Byte
Dim Result As Byte
CopyMemory VarPtr(Result), VarPtr(Value) + 8, Len(Result)
Exit Result
End Function


Public Function VarToInt(ByVal Value As Variant) As Integer
Dim Result As Integer
CopyMemory VarPtr(Result), VarPtr(Value) + 8, Len(Result)
Exit Result
End Function


Public Function VarToLng(ByVal Value As Variant) As Long
Dim Result As Long
CopyMemory VarPtr(Result), VarPtr(Value) + 8, Len(Result)
Exit Result
End Function


Public Function VarToBig(ByVal Value As Variant) As LongLong
Dim Result As LongLong
CopyMemory VarPtr(Result), VarPtr(Value) + 8, Len(Result)
Exit Result
End Function


Public Function VarToCur(ByVal Value As Variant) As Currency
Dim Result As Currency
CopyMemory VarPtr(Result), VarPtr(Value) + 8, Len(Result)
Exit Result
End Function


Public Function VarToDec(ByVal Value As Variant) As Decimal
Dim Result As Decimal
CopyMemory VarPtr(Result), VarPtr(Value) + 8, Len(Result)
Exit Result
End Function


Public Function VarToSng(ByVal Value As Variant) As Single
Dim Result As Single
CopyMemory VarPtr(Result), VarPtr(Value) + 8, Len(Result)
Exit Result
End Function


Public Function VarToDbl(ByVal Value As Variant) As Double
Dim Result As Double
CopyMemory VarPtr(Result), VarPtr(Value) + 8, Len(Result)
Exit Result
End Function


Public Function VarToStr(ByVal Value As Variant) As String
Dim Ptr As LongPtr
CopyMemory VarPtr(Ptr), VarPtr(Value) + 8, SizeOf(LongPtr)
If Ptr = 0 Then Exit Function

Dim Length As Long
Ptr -= SizeOf(Long)
CopyMemory VarPtr(Length), Ptr, SizeOf(Long)
Length += SizeOf(Long) + SizeOf(Integer)

Dim NewPtr As LongPtr = AllocMemory(Length)
CopyMemory NewPtr, Ptr, Length
NewPtr += SizeOf(Long)

Dim Result As String
CopyMemory VarPtr(Result), VarPtr(NewPtr), SizeOf(LongPtr)
Exit Result
End Function


Public Function VarToObj(ByVal Value As Variant) As Object
Dim Result As Object
Dim Nil As Object
CopyMemory VarPtr(Result), VarPtr(Value) + 8, SizeOf(LongPtr)

If Result IsNot Nothing Then
Set VarToObj = Result
CopyMemory VarPtr(Result), VarPtr(Nil), SizeOf(LongPtr)
End If
End Function


Public Function TypToVar(ByVal Address As LongPtr, ByVal Interf As LongPtr) As Variant
Dim Flags As Integer = vbUserDefinedType Or vbByRef
Dim Result As Variant
CopyMemory VarPtr(Result), VarPtr(Flags), SizeOf(Integer)
CopyMemory VarPtr(Result) + 8, VarPtr(Address), SizeOf(LongPtr)
CopyMemory VarPtr(Result) + 8 + SizeOf(LongPtr), VarPtr(Interf), SizeOf(LongPtr)
Exit Result
End Function


Public Function RoundCur(ByVal Value As Currency, ByVal Places As Integer) As Currency
Dim Tmp As LongLong
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Dim Remainder As LongLong = Tmp Mod 10_000
Tmp -= Remainder

Select Case Remainder
Case Is >= 6000
Result += 10_000

Case Is <= -6000
Result -= 10_000

Case 5000
If Tmp Mod 2_0000 = 10_000 Then Tmp += 10_000

Case -5000
If Tmp Mod 2_0000 = -10_000 Then Tmp -= 10_000
End Select

Dim Result As Currency
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Tmp)
Exit Result
End Function


Public Function RoundDec(ByVal Value As Decimal, ByVal Places As Integer) As Decimal
Dim Tmp As String = DecToStr(Value)
Dim Idx As Integer = InStr(Tmp, DecSep)
If Idx = 0 Then Exit Value
If Idx + Places >= Len(Tmp) Then Exit Value

Dim Frac As String = Mid$(Tmp, Idx + 1, Places + 1)
Dim Digit As String = Right$(Frac, 1)

Frac = Left$(Frac, Places)
Tmp = Left$(Tmp, Idx - 1)
Tmp &= DecSep & Frac

Dim Result As Decimal = StrToDec(Tmp)
Dim Adjust As Boolean
Dim T As DecimalStruct

Select Case Digit
Case "6 To "9"
Adjust = True

Case "5"
Select Case Left$(Tmp, 1)
Case "1", "3", "5", "7", "9"
Adjust = True
End Select
End Select

If Adjust Then
CopyMemory VarPtr(T), VarPtr(Result), Len(T)
DecAdd T.High, T.Middle, T.Low, 1
CopyMemory VarPtr(Result), VarPtr(T), Len(T)
End If

Exit Result
End Function


Public Function RoundSng(ByVal Value As Single, ByVal Places As Integer) As Single
If Value = 0 Then Exit Function
If Places = 0 Then Exit FixSng(Value)

Dim Sign As Boolean = Value < 0
If Sign Then Value = -Value
Dim Times As Integer = Places + 1

While Times
Value *= 10
Times -= 1
Wend

Value = FixSng(Value)
Dim Result As Single = FixSng(Value / 10)
Dim Digit As Single = Value - Result * 10

Select Case Digit
Case Is >= 6
Result += 1

Case 5
If (Value - FixSng(Value / 10) * 10) Mod 2 = 1 Then Result += 1
End Select

While Places
Result /= 10
Places -= 1
Wend

If Sign Then Result = -Result
Exit Result
End Function


Public Function RoundDbl(ByVal Value As Double, ByVal Places As Integer) As Double
If Value = 0 Then Exit Function
If Places = 0 Then Exit FixDbl(Value)

Dim Sign As Boolean = Value < 0
If Sign Then Value = -Value
Dim Times As Integer = Places + 1

While Times
Value *= 10
Times -= 1
Wend

Value = FixDbl(Value)
Dim Result As Double = FixDbl(Value / 10)
Dim Digit As Double = Value - Result * 10

Select Case Digit
Case Is >= 6
Result += 1

Case 5
If (Value - FixDbl(Value / 10) * 10) Mod 2 = 1 Then Result += 1
End Select

While Places
Result /= 10
Places -= 1
Wend

If Sign Then Result = -Result
Exit Result
End Function


Public Function FixSng(ByVal Value As Single) As Single
If Value > 0 AndAlso Value < 1 OrElse Value < 0 AndAlso Value > -1 Then Exit Function
If Value >= &H1000000& OrElse Value <= &HFF000000& Then Exit Value

Dim Tmp As Long
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Dim Places As Long = ((Tmp And &B1111111100000000000000000000000) >> 23) - 127
If Places < 0 Then Exit Function

Dim Mask As Long = 2 ^ Places - 1
Mask <<= 23 - Places
Mask Or= &B11111111100000000000000000000000
Tmp And= Mask

Dim Result As Single
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Tmp)
Exit Result
End Function


Public Function FixDbl(ByVal Value As Double) As Double
If Value > 0 AndAlso Value < 1 OrElse Value < 0 AndAlso Value > -1 Then Exit Function
If Value >= &H400000_00000000^ OrElse Value <= &HFFC00000_00000000^ Then Exit Value

Dim Tmp As LongLong
CopyMemory VarPtr(Tmp), VarPtr(Value), Len(Value)
Dim Places As Long = ((Tmp And &B111111111110000000000000000000000000000000000000000000000000000) >> 52) - 1023
If Places < 0 Then Exit Function

Dim Mask As Long = 2 ^ Places - 1
Mask <<= 52 - Places
Mask Or= &B1111111111110000000000000000000000000000000000000000000000000000
Tmp And= Mask

Dim Result As Double
CopyMemory VarPtr(Result), VarPtr(Tmp), Len(Tmp)
Exit Result
End Function


Public Function DecToStrEx(ByVal Value As Decimal) As String
Const BUF_SIZ = 30
Const BUF_END = BUF_SIZ * 2 - 1
Dim ZAscii As Byte
Dim Dig As Byte
Dim H1 As Long
Dim M1 As Long
Dim L1 As Long
Dim Buffer As String * BUF_SIZ
Dim T As DecimalStruct

CopyMemory VarPtr(T), VarPtr(Value), Len(T)

Dim Places As Byte = T.Places
T.Places = 0

Dim Sign As Boolean = T.Sign <> 0
T.Sign = 0

CopyMemory VarPtr(Value), VarPtr(T), Len(T)
Dim Dbl As Double = DecToDbl(Value)
Dim Jdx As Integer = BUF_END
GoSub FillBuffer
Dim Idx As Integer = Jdx + 2

For Jdx = Idx To BUF_END Step 2
Dig = AscB(MidB$(Buffer, Jdx, 1))
DecAppend H1, M1, L1, Dig
MidB$(Buffer, Jdx, 1) = ChrB$(AscB(MidB$(Buffer, Jdx, 1)) + Asc("0"))
Next

'''''''''''''''''''''''''''''''''''''''''''''''
T.High = USub(T.High, H1)
T.Middle = USub(T.Middle, M1)

If UCmp(T.Low, L1) = -1 Then
If T.Middle = 0 Then
T.High = USub(T.High, 1)
T.Middle = UAdd(T.Middle, &H8000_0000)
T.Middle = USub(T.Middle, 1)
T.Middle = UAdd(T.Middle, &H8000_0000)
Else
T.Middle = USub(T.Middle, 1)
End If

T.Low = UAdd(T.Low, &H8000_0000)
T.Low = USub(T.Low, L1)
T.Low = UAdd(T.Low, &H8000_0000)
Else
T.Low = USub(T.Low, L1)
End If
'''''''''''''''''''''''''''''''''''''''''''''''

CopyMemory VarPtr(Value), VarPtr(T), Len(T)
Dbl = DecToDbl(Value)
Jdx = BUF_END
ZAscii = AscB("0")
GoSub FillBuffer

If Sign Then
Idx -= 2
MidB$(Buffer, Idx, 1) = "-"
End If

Dim Result As String = MidB$(Buffer, Idx)
If Places Then Result = Left$(Result, Len(Result) - Places) & DecSep & Right$(Result, Places)
Exit Result

FillBuffer:
Do
Dim Tmp As Double = Dbl / 10
Tmp = FixDbl(Tmp)
Tmp *= 10
Dig = Dbl - Tmp
Dbl /= 10
MidB$(Buffer, Jdx, 1) = ChrB$(Dig + ZAscii)
Jdx -= 2
Loop While Dbl >= 1 'Cannot be "While Dbl" because Dbl never really reaches zero

Return
End Function


Public Function ValDbl(ByVal Value As String, Optional ByVal RaiseError As Boolean) As Double
Dim Sign As Boolean
Dim HadE As Boolean
Dim ESign As Boolean
Dim HadDot As Boolean
Dim Digit As Integer
Dim Count As Integer
Dim Pow As Double
Dim Result As Double

Dim Length As Long = Len(Value)
Dim Idx As Long = 1

GoSub IgnoreSpaces
If Idx > Length Then GoTo Quit

If Mid$(Value, Idx, 1) = "-" Then
Idx += 1
Sign = True
End If

If Idx > Length Then GoTo Quit

While Mid$(Value, Idx, 1) = "_"
Idx += 1
Wend

If Idx > Length Then GoTo Quit

Select Case Mid$(Value, Idx, 1)
Case "0 To "9"
GoSub BusinessAsUsual

Case "&"
Idx += 1
If Idx >= Length Then GoTo Quit

Select Case Mid$(Value, Idx, 1)
Case "0 To "9"
GoSub BusinessAsUsual

Case "b", "B"
Idx += 1
If Idx > Length Then GoTo Quit
Count = -1

Do
Select Case Mid$(Value, Idx, 1)
Case "0"
If Count >= 0 Then Count += 1
Result *= 2

Case "1"
Count += 1
Result *= 2
Result += 1

Case "_"
Rem Nothing to do

Case " ", vbTab
Exit Do

Case Else
GoTo Quit
End Select

Idx += 1
Loop Until Idx > Length

Case "o", "O"
Idx += 1
If Idx > Length Then GoTo Quit
Count = -3

Do
Select Case Mid$(Value, Idx, 1)
Case "0"
If Count >= 0 Then Count += 3
Result *= 8

Case "1 To "7"
Count += 3
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("0")
Result *= 8
Result += Digit

Case "_"
Rem Nothing to do

Case " ", vbTab
Exit Do

Case Else
GoTo Quit
End Select

Idx += 1
Loop Until Idx > Length

Case "h", "H"
Idx += 1
If Idx > Length Then GoTo Quit
Count = -4

Do
Select Case Mid$(Value, Idx, 1)
Case "0"
If Count >= 0 Then Count += 4
Result *= 16

Case "1 To "9"
Count += 4
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("0")
Result *= 16
Result += Digit

Case "a To "f"
Count += 4
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("a") + 10
Result *= 16
Result += Digit

Case "A To "F"
Count += 4
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("A") + 10
Result *= 16
Result += Digit

Case "&"
If Count < 28 Then Count = -1 Else GoTo Quit
Exit Do

Case "_"
Rem Nothing to do

Case " ", vbTab
Exit Do

Case Else
GoTo Quit
End Select

Idx += 1
Loop Until Idx > Length

Case Else
GoTo Quit
End Select

Case Else
GoTo Quit
End Select

GoSub IgnoreSpaces
If Idx <= Length Then GoTo Quit
RaiseError = False

Quit:
Select Case Count
Case Is >= 60
If Result >= 9_223_372_036_854_775_808^ Then Result -= 18_446_744_073_709_551_616^

Case Is >= 28
If Result >= &H8000_0000^ Then Result -= 4_294_967_296#

Case Is >= 12
If Result >= &H8000& Then Result -= &H1_0000
End Select

If Sign Then Result = -Result
ValDbl = Result
If RaiseError Then Err.Raise 6
Exit Function

BusinessAsUsual:
Do
Select Case Mid$(Value, Idx, 1)
Case "0 To "9"
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("0")
Result *= 10
Result += Digit

Case "e", "E"
HadE = True
Idx += 1
Exit Do

Case "_"
Rem Nothing to do

Case DecSep
HadDot = True
Idx += 1
Exit Do

Case " ", vbTab
Exit Do

Case Else
GoTo Quit
End Select

Idx += 1
Loop Until Idx > Length

If HadDot Then
If Idx > Length Then GoTo Quit

Do
Select Case Mid$(Value, Idx, 1)
Case "0 To "9"
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("0")
Result *= 10
Result += Digit
Count += 1

Case "e", "E"
HadE = True
Idx += 1
Exit Do

Case "_"
Rem Nothing to do

Case " ", vbTab
Exit Do

Case Else
GoTo Quit
End Select

Idx += 1
Loop Until Idx > Length

While Count
Result /= 10
Count -= 1
Wend
End If

If HadE Then
Select Case Mid$(Value, Idx, 1)
Case "+"
Idx += 1

Case "-"
ESign = True
Idx += 1
End Select

If Idx > Length Then GoTo Quit

Do
Select Case Mid$(Value, Idx, 1)
Case "0 To "9"
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("0")
Pow *= 10
Pow += Digit

Case "_"
Rem Nothing to do

Case " ", vbTab
Exit Do

Case Else
GoTo Quit
End Select

Idx += 1
Loop Until Idx > Length

While Pow
If ESign Then
Result /= 10
Else
Result *= 10
End If

Pow -= 1
Wend
End If

Return

IgnoreSpaces:
Do
Select Case Mid$(Value, Idx, 1)
Case " ", vbTab
Idx += 1

Case Else
Exit Do
End Select
Loop Until Idx > Length

Return
End Function


Private Sub DecLSh1(ByRef High As Long, ByRef Middle As Long, ByRef Low As Long)
If High And &H8000_0000 Then Err.Raise 6
High <<= 1

If Middle And &H8000_0000 Then High Or= 1
Middle <<= 1

If Low And &H8000_0000 Then Middle Or= 1
Low <<= 1
End Sub


Private Sub DecLSh3(ByRef High As Long, ByRef Middle As Long, ByRef Low As Long)
If High And &HE000_0000 Then Err.Raise 6
High <<= 3

If Middle And &H8000_0000 Then High Or= 4
If Middle And &H4000_0000 Then High Or= 2
If Middle And &H2000_0000 Then High Or= 1
Middle <<= 3

If Low And &H8000_0000 Then Middle Or= 4
If Low And &H4000_0000 Then Middle Or= 2
If Low And &H2000_0000 Then Middle Or= 1
Low <<= 3
End Sub


Private Sub DecLSh4(ByRef High As Long, ByRef Middle As Long, ByRef Low As Long)
If High And &HF000_0000 Then Err.Raise 6
High <<= 4

If Middle And &H8000_0000 Then High Or= 8
If Middle And &H4000_0000 Then High Or= 4
If Middle And &H2000_0000 Then High Or= 2
If Middle And &H1000_0000 Then High Or= 1
Middle <<= 4

If Low And &H8000_0000 Then Middle Or= 8
If Low And &H4000_0000 Then Middle Or= 4
If Low And &H2000_0000 Then Middle Or= 2
If Low And &H1000_0000 Then Middle Or= 1
Low <<= 4
End Sub


Private Sub DecAdd(ByRef High As Long, ByRef Middle As Long, ByRef Low As Long, ByVal Value As Long)
If Ovf(Low, Value) Then
If Ovf(Middle, 1) Then
If Ovf(High, 1) Then Err.Raise 6
High = UAdd(High, 1)
End If

Middle = UAdd(Middle, 1)
End If

Low = UAdd(Low, Value)
End Sub


Public Function ValDec(ByVal Value As String, Optional ByVal RaiseError As Boolean) As Decimal
Dim Sign As Boolean
Dim HadE As Boolean
Dim ESign As Boolean
Dim HadDot As Boolean
Dim Digit As Integer
Dim Count As Integer
Dim Places As Integer
Dim Idx As Long
Dim Middle As Long
Dim Low As Long
Dim Pow As Double
Dim Result As Decimal
Dim T As DecimalStruct

Dim Length As Long = Len(Value)
Dim High As Long = 1

GoSub IgnoreSpaces
If Idx > Length Then GoTo Quit

If Mid$(Value, Idx, 1) = "-" Then
Idx += 1
Sign = True
End If

If Idx > Length Then GoTo Quit

While Mid$(Value, Idx, 1) = "_"
Idx += 1
Wend

If Idx > Length Then GoTo Quit

Select Case Mid$(Value, Idx, 1)
Case "0 To "9"
GoSub BusinessAsUsual

Case "&"
Idx += 1
If Idx >= Length Then GoTo Quit

Select Case Mid$(Value, Idx, 1)
Case "0 To "9"
GoSub BusinessAsUsual

Case "b", "B"
Idx += 1
If Idx > Length Then GoTo Quit
Count = -1

Do
Select Case Mid$(Value, Idx, 1)
Case "0"
If Count >= 0 Then Count += 1
DecLSh1 High, Middle, Low

Case "1"
Count += 1
DecLSh1 High, Middle, Low
DecAdd High, Middle, Low, 1

Case "_"
Rem Nothing to do

Case " ", vbTab
Exit Do

Case Else
GoTo Quit
End Select

Idx += 1
Loop Until Idx > Length

Case "o", "O"
Idx += 1
If Idx > Length Then GoTo Quit
Count = -3

Do
Select Case Mid$(Value, Idx, 1)
Case "0"
If Count >= 0 Then Count += 3
DecLSh3 High, Middle, Low

Case "1 To "7"
Count += 3
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("0")
DecLSh3 High, Middle, Low
DecAdd High, Middle, Low, Digit

Case "_"
Rem Nothing to do

Case " ", vbTab
Exit Do

Case Else
GoTo Quit
End Select

Idx += 1
Loop Until Idx > Length

Case "h", "H"
Idx += 1
If Idx > Length Then GoTo Quit
Count = -4

Do
Select Case Mid$(Value, Idx, 1)
Case "0"
If Count >= 0 Then Count += 4
DecLSh4 High, Middle, Low

Case "1 To "9"
Count += 4
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("0")
DecLSh4 High, Middle, Low
DecAdd High, Middle, Low, Digit

Case "a To "f"
Count += 4
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("a") + 10
DecLSh4 High, Middle, Low
DecAdd High, Middle, Low, Digit

Case "A To "F"
Count += 4
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("A") + 10
DecLSh4 High, Middle, Low
DecAdd High, Middle, Low, Digit

Case "&"
If Count < 28 Then Count = -1 Else GoTo Quit
Exit Do

Case "_"
Rem Nothing to do

Case " ", vbTab
Exit Do

Case Else
GoTo Quit
End Select

Idx += 1
Loop Until Idx > Length

Case Else
GoTo Quit
End Select

Case Else
GoTo Quit
End Select

GoSub IgnoreSpaces
If Idx <= Length Then GoTo Quit
RaiseError = False

Quit:
If Sign Then T.Sign = &H80

Select Case Count
Case Is >= 60
If Middle < 0 Then
Middle = Not Middle
Low = Not Low
DecAdd High, Middle, Low, 1
T.Sign = IIf(T.Sign, 0, &H80)
End If

Case Is >= 28
If Low < 0 Then
If Low <> MIN_LNG Then Low = -Low
T.Sign = IIf(T.Sign, 0, &H80)
End If

Case Is >= 12
If Low >= &H8000& Then
Low Or= &HFFFF_0000
If Low <> MIN_LNG Then Low = -Low
T.Sign = IIf(T.Sign, 0, &H80)
End If
End Select

T.TypeDescriptor = vbDecimal
T.Places = Places
T.High = High
T.Middle = Middle
T.Low = Low
CopyMemory VarPtr(Result), VarPtr(T), Len(T)
ValDec = Result
If RaiseError Then Err.Raise 6
Exit Function

BusinessAsUsual:
Do
Select Case Mid$(Value, Idx, 1)
Case "0 To "9"
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("0")
DecAppend High, Middle, Low, Digit

Case "e", "E"
HadE = True
Idx += 1
Exit Do

Case "_"
Rem Nothing to do

Case DecSep
HadDot = True
Idx += 1
Exit Do

Case " ", vbTab
Exit Do

Case Else
GoTo Quit
End Select

Idx += 1
Loop Until Idx > Length

If HadDot Then
If Idx > Length Then GoTo Quit

Do
Select Case Mid$(Value, Idx, 1)
Case "0 To "9"
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("0")
DecAppend High, Middle, Low, Digit
Count += 1

Case "e", "E"
HadE = True
Idx += 1
Exit Do

Case "_"
Rem Nothing to do

Case " ", vbTab
Exit Do

Case Else
GoTo Quit
End Select

Idx += 1
Loop Until Idx > Length
End If

Places = Count
Count = 0

If HadE Then
Select Case Mid$(Value, Idx, 1)
Case "+"
Idx += 1

Case "-"
ESign = True
Idx += 1
End Select

If Idx > Length Then GoTo Quit

Do
Select Case Mid$(Value, Idx, 1)
Case "0 To "9"
Digit = Asc(Mid$(Value, Idx, 1)) - Asc("0")
Pow *= 10
Pow += Digit

Case "_"
Rem Nothing to do

Case " ", vbTab
Exit Do

Case Else
GoTo Quit
End Select

Idx += 1
Loop Until Idx > Length

If ESign Then Places -= Pow Else Places += Pow
End If

Return

IgnoreSpaces:
Do
Select Case Mid$(Value, Idx, 1)
Case " ", vbTab
Idx += 1

Case Else
Exit Do
End Select
Loop Until Idx > Length

Return
End Function


Private Sub DecAppend(ByRef THigh As Long, ByRef TMiddle As Long, ByRef TLow As Long, ByVal Digit As Long)
Dim High As Long
Dim Middle As Long
Dim Low As Long

Rem ----- Multiply by 4 -----
If THigh And &HC000_0000 Then Err.Raise 6
High = THigh << 2
If TMiddle And &H8000_0000 Then High Or= 2
If TMiddle And &H4000_0000 Then High Or= 1

Middle = TMiddle << 2
If TLow And &H8000_0000 Then Middle Or= 2
If TLow And &H4000_0000 Then Middle Or= 1

Low = TLow << 2

Rem ----- Add 4 to 1, efectively multiplying the original number by 5 -----
If Ovf(THigh, High) Then Err.Raise 6
THigh = UAdd(THigh, High)

Rem Carry?
If Ovf(TMiddle, Middle) Then
If Ovf(THigh, 1) Then Err.Raise 6
THigh = UAdd(THigh, 1)
End If

TMiddle = UAdd(TMiddle, Middle)

Rem Carry?
If Ovf(TLow, Low) Then
If Ovf(TMiddle, 1) Then
If Ovf(THigh, 1) Then Err.Raise 6
THigh = UAdd(THigh, 1)
End If

TMiddle = UAdd(TMiddle, 1)
End If

TLow = UAdd(TLow, Low)

Rem ----- Multiply by 2, efectively multiplying the original number by 10 -----
If THigh And &H8000_0000 Then Err.Raise 6
THigh <<= 1

If TMiddle And &H8000_0000 Then THigh Or= 1
TMiddle <<= 1

If TLow And &H8000_0000 Then TMiddle Or= 1
TLow <<= 1

Rem ----- Add the digit -----
Rem Carry?
If Ovf(TLow, Digit) Then
If Ovf(TMiddle, 1) Then
If Ovf(THigh, 1) Then Err.Raise 6
THigh = UAdd(THigh, 1)
End If

TMiddle = UAdd(TMiddle, 1)
End If

TLow = UAdd(TLow, Digit)
End Sub


Public Function DtmToStr(ByVal Value As Date) As String
Dim Mm As Integer
Dim Dd As Integer
Dim Hh As Integer
Dim Nn As Integer
Dim Ss As Integer
Dim Ms(1 To 12) As Integer
Dim Dbl As Double
Dim AMPM As String
Dim Result As String

CopyMemory VarPtr(Dbl), VarPtr(Value), Len(Tmp)
Dim Fff As Double = Dbl - FixDbl(Dbl)
Dim Tmp As Double = FixDbl(Dbl) + 693594

Dim Adj400 As Double = FixDbl(Tmp / 146097)
Tmp -= Adj400 * 146097

Dim Adj100 As Double = FixDbl(Tmp / 36524)
Tmp -= Adj100 * 36524

Dim Adj004 As Double = FixDbl(Tmp / 1461)
Tmp -= Adj004 * 1461

Dim Adj001 As Double = FixDbl(Tmp / 365)
Dbl = Tmp - Adj001 * 365

Dim Yyyy As Integer = Adj400 * 400 + Adj100 * 100 + Adj004 * 4 + Adj001 + 1

If Dbl = 0 Then
Yyyy -= 1
Mm = 12

If (Yyyy Mod 4 = 0 AndAlso Yyyy Mod 100 <> 0 OrElse Yyyy Mod 400 = 0) AndAlso Adj001 = 4 OrElse Adj100 = 4 Then
Dd = 30
Else
Dd = 31
End If
Else
Ms(1) = 31

If Yyyy Mod 4 = 0 AndAlso Yyyy Mod 100 <> 0 OrElse Yyyy Mod 400 = 0 Then
Ms(2) = 29
Else
Ms(2) = 28
End If

Ms(3) = 31
Ms(4) = 30
Ms(5) = 31
Ms(6) = 30
Ms(7) = 31
Ms(8) = 31
Ms(9) = 30
Ms(10) = 31
Ms(11) = 30
Ms(12) = 31

Dd = DblToInt(Dbl)
Mm = 1

While Dd > Ms(Mm)
Dd -= Ms(Mm)
Dbl -= Ms(Mm)
Mm += 1
Wend
End If

If Fff < 0 Then Fff = -Fff

If Fff > 0 Then
Fff *= 24
Hh = DblToStr(FixDbl(Fff))

Fff -= Hh
Fff *= 60
Nn = DblToStr(FixDbl(Fff))

Fff -= Nn
Fff *= 60
Ss = DblToStr(RoundDbl(Fff))
End If

If Yyyy = 1899 AndAlso Mm = 12 AndAlso Dd = 30 AndAlso Hh = 0 AndAlso Nn = 0 AndAlso Ss = 0 Then
Result = "0:00:00 AM"

ElseIf Yyyy = 1899 AndAlso Mm = 12 AndAlso Dd = 30 Then
GoSub HandleAMPM
GoSub FormatTime

ElseIf Hh = 0 AndAlso Nn = 0 AndAlso Ss = 0 Then
GoSub FormatDate

Else
GoSub HandleAMPM
GoSub FormatDate
Result &= " "
GoSub FormatTime
End If

Exit Result & AMPM

HandleAMPM:
If Hh = 12 Then
AMPM = " PM"

ElseIf Hh > 12 Then
AMPM = " PM"
Hh -= 12

Else
AMPM = " AM"
End If

Return

FormatDate:
Result = IntToStr(Yyyy)
Result &= "-"
If Mm < 10 Then Result &= "0"
Result &= IntToStr(Mm)
Result &= "-"
If Dd < 10 Then Result &= "0"
Result &= IntToStr(Dd)
Return

FormatTime:
Result &= IntToStr(Hh)
Result &= ":"
If Nn < 10 Then Result &= "0"
Result &= IntToStr(Nn)
Result &= ":"
If Ss < 10 Then Result &= "0"
Result &= IntToStr(Ss)
Return
End Function


Public Function StrToDtm(ByVal Value As String) As Date
Dim IsLeap As Boolean
Dim HadMm As Boolean
Dim Jdx As Integer
Dim Number As Integer
Dim Name As String
Dim Dig As String * 1
Dim Sep2 As String * 1

Dim Yyyy As Integer = -1
Dim Mm As Integer = -1
Dim Dd As Integer = -1
Dim Hh As Integer = -1
Dim Nn As Integer = -1
Dim Ss As Integer = -1

Dim Udx As Integer = Len(Value)
Dim Idx As Integer = 1

GoSub StripSpaces
If Idx > Udx Then Err.Raise 13
Dig = Mid$(Value, Idx, 1)

Select Case Dig
Case "0 To "9"
GoSub ReadNumber

Select Case Number
Case Is > 31
Rem It can only be the year.
Yyyy = Number

Case Is > 12
Rem Can be year or day. We're going with day.
Dd = Number
End Select

Case "a To "z", "A To "Z" 'TODO: Cover all letters
GoSub ReadMonth

Case Else
Err.Raise 13
End Select

If Idx > Udx Then Err.Raise 13

Dim Sep1 As String * 1 = Mid$(Value, Idx, 1)
Idx += 1
If Idx > Udx Then Err.Raise 13

Select Case Sep1
Case "-"
If HadMm Then Err.Raise 13 'mmm-dd-yyyy format is invalid. Use another separator instead.
Yyyy = Number
Dd = -1

Case ".", "/"
If Not HadMm AndAlso Yyyy = -1 AndAlso Dd = -1 Then Mm = Number 'Favoring mm/dd/yyyy

Case ":"
If HadMm Then Err.Raise 13 'mmm:nn format is invalid.
Hh = Number
Yyyy = -1
Dd = -1

Case Else
Err.Raise 13
End Select

If Sep1 <> ": Then
Dig = Mid$(Value, Idx, 1)

Select Case Dig
Case "0 To "9"
GoSub ReadNumber

If Sep1 = "- Then
If Mm <> -1 Then Err.Raise 13 '[m]mm-?? is invalid.
Mm = Number
Else
Select Case Number
Case Is > 31
If Yyyy <> -1 Then Err.Raise 13 'dd/yy and yy/dd formats are invalid.
Yyyy = Number

Case Else
Dd = Number 'Favoring mm/dd/yyyy
End Select
End If

Case "a To "z", "A To "Z" 'TODO: Cover all letters
If HadMm Then Err.Raise 13

If Mm <> -1 Then
Dd = Mm
Mm = -1
End If

GoSub ReadMonth

Case Else
Err.Raise 13
End Select

If Idx > Udx Then GoTo Done

Sep2 = Mid$(Value, Idx, 1)
Idx += 1

Select Case Dig
Case " ", vbTab
GoSub StripSpaces
If Idx > Udx Then GoTo Done

Case Sep1
GoSub ReadNumber

If Yyyy <> -1 AndAlso Mm <> -1 Then
Dd = Number

ElseIf Yyyy <> -1 AndAlso Dd <> -1 Then
Mm = Number

ElseIf Mm <> -1 And DdAlso <> -1 Then
Yyyy = Number

Else
Debug.Assert False
End If

GoSub StripSpaces
If Idx > Udx Then GoTo Done

Case Else
Err.Raise 13
End Select
End If

If Sep1 <> ": Then
GoSub ReadNumber
Hh = Number
Sep2 = Mid$(Value, Idx, 1)
If Sep2 <> ": Then Err.Raise 13
Idx += 1
End If

GoSub ReadNumber
Nn = Number

If Idx < Udx Then
Sep2 = Mid$(Value, Idx, 1)
Idx += 1

If Sep2 = ": Then
GoSub ReadNumber
Ss = Number
End If

GoSub StripSpaces
End If

If Idx <= Udx Then
Select Case UCase$(Mid$(Value, Idx, 2)) '<-UCase$
Case "AM"
If Hh > 12 Then Err.Raise 13
If Hh = 12 Then Hh = 0

Case "PM"
If Hh > 12 Then Hh -= 12

Case Else
Err.Raise 13
End Select
End If

Done:
If Yyyy = -1 AndAlso Mm = -1 AndAlso Dd = -1 Then
Yyyy = 1899
Mm = 12
Dd = 30
Else
If Yyyy = -1 Then Yyyy = Year(Date)
If Dd = -1 Then Dd = 1
End If

If Yyyy < 100 Then
Yyyy += 1900
If Yyyy < 1950 Then Yyyy += 100
End If

If Hh = -1 Then Hh = 0
If Nn = -1 Then Nn = 0
If Ss = -1 Then Ss = 0

If Mm < 1 OrElse Mm > 12 Then Err.Raise 13
IsLeap = Yyyy Mod 4 = 0 AndAlso Yyyy Mod 100 <> 0 OrElse Yyyy Mod 400 = 0

Select Case Mm
Case 4, 6, 9, 11
If Dd > 30 Then Err.Raise 13

Case 2
If Dd > IIf(IsLeap, 29, 28) Then Err.Raise 13

Case Else
If Dd > 31 Then Err.Raise 13
End Select

If Hh > 23 Then Err.Raise 13
If Nn > 59 Then Err.Raise 13
If Ss > 59 Then Err.Raise 13

Dim Result As Double = Yyyy * 365.2425
If FixDbl(Result) <> Result Then Result += 1
Result = FixDbl(Result)
Result += Array(0, 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334)(Mm)
If IsLeap AndAlso Mm > 2 Then Result += 1
Result += Dd
Result -= 693960
Result += (Hh * 3600# + Nn * 60 + Ss) / 86400
CopyMemory VarPtr(StrToDtm), VarPtr(Result), Len(Result)
Exit Function

ReadNumber:
Number = 0

Do
Dig = Mid$(Value, Idx, 1)

Select Case Dig
Case "0 To "9"
Idx += 1
Number *= 10
Number += Asc(Dig) - Asc("0")
If Number > 9999 Then Err.Raise 13

Case Else
Exit Do
End Select
Loop Until Idx > Udx

Return

ReadMonth:
If Mm <> -1 Then Err.Raise 13

Do
Dig = Mid$(Value, Idx, 1)

Select Case Dig
Case "a To "z", "A To "Z" 'TODO: Cover all letters
Idx += 1
Name &= Dig

Case Else
Exit Do
End Select
Loop Until Idx > Idx

For Jdx = 1 To 12
If StrComp(Name, MonthName(Jdx), vbTextCompare) = 0 OrElse _
StrComp(Name, MonthName(Jdx, Abbreviate:=True), vbTextCompare) = 0 Then
Mm = Jdx
Exit For
End If
Next

If Mm = -1 Then Err.Raise 13
HadMm = True
Return

StripSpaces:
Do Until Idx > Udx
Select Case Mid$(Value, Idx, 1)
Case " ", vbTab
Idx += 1

Case Else
Exit Do
End Select
Loop

Return
End Function
End Module


Public Class Shifter
Rem Based on code found in http://www.vbaccelerator.com/tips/vba0030.htm
Option Explicit

Private PowersOf2_(0 To 31) As Long


Private Sub Class_Initialize()
PowersOf2_(0) = &H1
PowersOf2_(1) = &H2
PowersOf2_(2) = &H4
PowersOf2_(3) = &H8
PowersOf2_(4) = &H10
PowersOf2_(5) = &H20
PowersOf2_(6) = &H40
PowersOf2_(7) = &H80
PowersOf2_(8) = &H100
PowersOf2_(9) = &H200
PowersOf2_(10) = &H400
PowersOf2_(11) = &H800
PowersOf2_(12) = &H1000
PowersOf2_(13) = &H2000
PowersOf2_(14) = &H4000
PowersOf2_(15) = &H8000&
PowersOf2_(16) = &H10000
PowersOf2_(17) = &H20000
PowersOf2_(18) = &H40000
PowersOf2_(19) = &H80000
PowersOf2_(20) = &H100000
PowersOf2_(21) = &H200000
PowersOf2_(22) = &H400000
PowersOf2_(23) = &H800000
PowersOf2_(24) = &H1000000
PowersOf2_(25) = &H2000000
PowersOf2_(26) = &H4000000
PowersOf2_(27) = &H8000000
PowersOf2_(28) = &H10000000
PowersOf2_(29) = &H20000000
PowersOf2_(30) = &H40000000
PowersOf2_(31) = &H80000000
End Sub


Public Function LSh(ByVal Number As Long, ByVal Shift As Long, Optional ByVal Bits As Integer = 32) As Long
Dim Offset As Integer
Dim Result As Long

If Bits <= 0 Or Bits > 32 Then Err.Raise 6

If Bits < 32 Then
Bits = Bits - 1
Number = Number And (2 ^ Bits - 1)
End If

Select Case Shift
Case Is <= 0
Result = Number

Case Is > 31
Result = 0

Case Else
Offset = 31 - Shift
Result = (Number And (PowersOf2_(Offset) - 1)) * PowersOf2_(Shift)
If (Number And PowersOf2_(Offset)) = PowersOf2_(Offset) Then Result = Result Or PowersOf2_(31)
End Select

LSh = Result
End Function


Public Function RSh(ByVal Number As Long, ByVal Shift As Long, Optional ByVal Bits As Integer = 32) As Long
Dim Result As Long

If Bits <= 0 Or Bits > 32 Then Err.Raise 6

If Bits < 32 Then
Bits = Bits - 1
Number = Number And (2 ^ Bits - 1)
End If

Select Case Shift
Case Is <= 0
Result = Number

Case Is > 31
Result = 0

Case Else
If (Number And PowersOf2_(31)) = PowersOf2_(31) Then
Result = (Number And &H7FFFFFFF) \ PowersOf2_(Shift) Or PowersOf2_(31 - Shift)
Else
Result = Number \ PowersOf2_(Shift)
End If
End Select

RSh = Result
End Function


Public Function WSh(ByVal Number As Long, ByVal Shift As Long, Optional ByVal Bits As Integer = 32) As Long
Dim Result As Long

If Bits <= 0 Or Bits > 32 Then Err.Raise 6

If Bits < 32 Then
Bits = Bits - 1
Number = Number And (2 ^ Bits - 1)
End If

Select Case Shift
Case Is <= 0
Result = Number

Case Is > 31
If (Number And PowersOf2_(31)) = PowersOf2_(31) Then
Result = -1
Else
Result = 0
End If

Case Else
Result = Number \ PowersOf2_(Shift)
End Select

WSh = Result
End Function
End Class


Private Module Shifts
Option Explicit

Private Shift_ As New Shifter


Public Function LSh(ByVal Number As Long, ByVal Shift As Long, Optional ByVal Bits As Integer = 32) As Long
LSh = Shift_.LSh(Number, Shift, Bits)
End Function


Public Function RSh(ByVal Number As Long, ByVal Shift As Long, Optional ByVal Bits As Integer = 32) As Long
RSh = Shift_.RSh(Number, Shift, Bits)
End Function


Public Function WSh(ByVal Number As Long, ByVal Shift As Long, Optional ByVal Bits As Integer = 32) As Long
WSh = Shift_.WSh(Number, Shift, Bits)
End Function
End Module


Public Module Unsigned
Option Explicit


Rem Returns True if adding ULongs Augend and Addend overflows.
Public Function Ovf(ByVal Augend As Long, ByVal Addend As Long) As Boolean
If Augend = 0 OrElse Addend = 0 Then Exit Function
If Augend > 0 AndAlso Addend > 0 Then Exit Function
If Augend < 0 AndAlso Addend < 0 Then Exit True
Exit Augend + Addend >= 0
End Function


Rem Compare two ULongs
Public Function UCmp(ByVal LeftValue As Long, ByVal RightValue As Long) As Integer
Dim Result As Integer

If LeftValue = RightValue Then
Rem Result = 0

ElseIf LeftValue >= 0 AndAlso RightValue >= 0 Then
Result = IIf(LeftValue > RightValue, 1, -1)

ElseIf LeftValue < 0 AndAlso RightValue < 0 Then
Result = IIf(LeftValue > RightValue, 1, -1)

Else
Result = IIf(LeftValue < 0, 1, -1)
End If

Exit Result
End Function


Rem Roundtrip addition for ULongs
Public Function UAdd(ByVal Augend As Long, ByVal Addend As Long) As Long
If Augend < 0 AndAlso Addend < 0 Then
If -(MAX_LNG + Augend + 1) > Addend Then
Augend += MAX_LNG
Addend += MAX_LNG
Exit Augend + Addend + 2
Else
Exit Augend + Addend
End If
Else
If Augend >= 0 AndAlso Addend >= 0 Then
If MAX_LNG - Augend < Addend Then
Augend += MIN_LNG
Addend += MIN_LNG
End If
End If

Exit Augend + Addend
End If
End Function


Rem Roundtrip subtraction for ULongs
Public Function USub(ByVal Minuend As Long, ByVal Subtrahend As Long) As Long
If Minuend = 0 Then Exit Subtrahend
If Subtrahend = 0 Then Exit Minuend

If Minuend > 0 AndAlso Subtrahend < 0 Then
If Minuend > MAX_LNG + Subtrahend Then Exit MIN_LNG + Minuend - Subtrahend + MIN_LNG
Exit Minuend - Subtrahend

ElseIf Minuend < 0 AndAlso Subtrahend > 0 Then
If Minuend - MIN_LNG - Subtrahend > -1 Then Exit Minuend - Subtrahend
Exit Minuend - MIN_LNG - Subtrahend - MIN_LNG

Else
Exit Minuend - Subtrahend
End If
End Function
End Module



Public Class HpDbl
Public Value As Double
Public Offset As Double
End Class


Public Class HpSng
Public Value As Single
Public Offset As Single
End Class


Private Module Errol
Rem Based on work from Marc Andrysco, Ranjit Jhala, and Sorin Lerner found in https://github.com/marcandrysco/Errol/blob/master/lib/errol.c (errol0_dtoa)
Private Const ERROL0_EPSILON_DBL = 0.0000001
Private Const ERROL0_EPSILON_SNG = 0.0000001


Private Sub FpPnDbl(ByVal CurVal As Double, ByRef PrevVal As Double, ByRef NextVal As Double)
Dim Bits As LongLong
CopyMemory VarPtr(Bits), VarPtr(CurVal), LenB(CurVal)

Dim NextBits As LongLong = Bits
NextBits += 1
CopyMemory VarPtr(NextVal), VarPtr(NextBits), LenB(NextBits)

Dim PrevBits As LongLong = Bits
PrevBits -= 1
CopyMemory VarPtr(PrevVal), VarPtr(PrevBits), LenB(PrevBits)
End Sub


Private Sub FpPnSgn(ByVal CurVal As Single, ByRef PrevVal As Single, ByRef NextVal As Single)
Dim Bits As Long
CopyMemory VarPtr(Bits), VarPtr(CurVal), LenB(CurVal)

Dim NextBits As Long = Bits
NextBits += 1
CopyMemory VarPtr(NextVal), VarPtr(NextBits), LenB(NextBits)

Dim PrevBits As Long = Bits
PrevBits -= 1
CopyMemory VarPtr(PrevVal), VarPtr(PrevBits), LenB(PrevBits)
End Sub


Private Sub HpDiv10Dbl(ByVal HP As HpDbl)
Dim Value As Double = HP.Value

HP.Value /= 10
HP.Offset /= 10

Value -= HP.Value * 8
Value -= HP.Value * 2

HP.Offset += Value / 10

HpNormalizeDbl HP
End Sub


Private Sub HpDiv10Sng(ByVal HP As HpSng)
Dim Value As Single = HP.Value

HP.Value /= 10
HP.Offset /= 10

Value -= HP.Value * 8
Value -= HP.Value * 2

HP.Offset += Value / 10

HpNormalizeSng HP
End Sub


Private Sub HpMul10Dbl(ByVal HP As HpDbl)
Dim Value As Double = HP.Value

HP.Value *= 10
HP.Offset *= 10

Dim Offset As Double = HP.Value
Offset -= Value * 8
Offset -= Value * 2

HP.Offset -= Offset
HpNormalizeDbl HP
End Sub


Private Sub HpMul10Sng(ByVal HP As HpSng)
Dim Value As Single = HP.Value

HP.Value *= 10
HP.Offset *= 10

Dim Offset As Single = HP.Value
Offset -= Value * 8
Offset -= Value * 2

HP.Offset -= Offset
HpNormalizeSng HP
End Sub


Private Sub HpNormalizeDbl(ByVal HP As HpDbl)
Dim Value As Double = HP.Value
HP.Value += HP.Offset
HP.Offset += Value - HP.Value
End Sub


Private Sub HpNormalizeSng(ByVal HP As HpSng)
Dim Value As Single = HP.Value
HP.Value += HP.Offset
HP.Offset += Value - HP.Value
End Sub


Private Function CvByte(ByVal Value As Double) As Byte
Value = FixDbl(Value)
Exit DblToByt(Value)
End Function


Public Function FloatToString(ByVal Value As Variant, ByRef Exponent As Long, Optional ByRef IsSpecial As Boolean) As String
Select Case VarType(Value)
Case vbDouble
Exit DoubleToString(Value, Exponent, IsSpecial)

Case vbSingle
Exit SingleToString(Value, Exponent, IsSpecial)

Case Else
Err.Raise 13
End Select
End Function


Private Function DoubleToString(ByVal Value As Double, ByRef Exponent As Long, ByRef IsSpecial As Boolean) As String
Dim InHi As HpDbl
Dim InLo As HpDbl
Dim Middle As HpDbl
Dim HiDig As Byte
Dim LoDig As Byte
Dim MdDig As Byte
Dim Ten As Double
Dim Diff As Double
Dim PrevVal As Double
Dim NextVal As Double
Dim Result As String
' Output meaning:
' 1#QNAN Positive quiet NaN
'-1#QNAN Negative quiet NaN
' 1#IND Positive indefinite NaN
'-1#IND Negative indefinite NaN

If Value <> Value Then
IsSpecial = True
Exponent = 0
DoubleToString = "1#QNAN"
Exit Function
End If

If Value < 0 Then Result = "-"
Diff = Value - Value

If Diff <> Diff Then
IsSpecial = True
Exponent = 0
DoubleToString = Result & "1#IND"
Exit Function
End If

If Value = 0 Then
Exponent = 1
DoubleToString = "0"
Exit Function
End If

If Value < 0 Then Value = -Value

If Value = 1.7976931348623E+308 Then
Exponent = 309
DoubleToString = Result & "17976931348623157"
Exit Function
End If

Ten = 1
Exponent = 1
Set Middle = New HpDbl
Set InHi = New HpDbl
Set InLo = New HpDbl

Rem normalize the midpoint
Middle.Value = Value
Middle.Offset = 0

While Exponent < 308 AndAlso (Middle.Value > 10 OrElse Middle.Value = 10 AndAlso Middle.Offset >= 0)
Exponent += 1
HpDiv10Dbl Middle
Ten /= 10
Wend

While Exponent > -307 AndAlso (Middle.Value < 1 OrElse Middle.Value = 1 AndAlso Middle.Offset < 0)
Exponent -= 1
HpMul10Dbl Middle
Ten *= 10
Wend

FpPnDbl Value, PrevVal, NextVal
InHi.Value = Middle.Value
InHi.Offset = Middle.Offset + (NextVal - Value) * Ten / (2 + ERROL0_EPSILON_DBL)
InLo.Value = Middle.Value
InLo.Offset = Middle.Offset + (PrevVal - Value) * Ten / (2 + ERROL0_EPSILON_DBL)

HpNormalizeDbl InHi
HpNormalizeDbl InLo

Rem normalized boundaries
While InHi.Value > 10 OrElse InHi.Value = 10 AndAlso InHi.Offset >= 0
Exponent += 1
HpDiv10Dbl InHi
HpDiv10Dbl InLo
Wend

While InHi.Value < 1 OrElse InHi.Value = 1 AndAlso InHi.Offset < 0
Exponent -= 1
HpMul10Dbl InHi
HpMul10Dbl InLo
Wend

Rem Digit generation
Do While InHi.Value <> 0 OrElse InHi.Offset <> 0
HiDig = CvByte(InHi.Value)
If InHi.Value = HiDig AndAlso InHi.Offset < 0 Then HiDig -= 1

LoDig = CvByte(InLo.Value)
If InLo.Value = LoDig AndAlso InLo.Offset < 0 Then LoDig -= 1

If LoDig <> HiDig Then Exit Do

Result &= Result & BytToStr(HiDig)

InHi.Value -= HiDig
HpMul10Dbl InHi

InLo.Value -= LoDig
HpMul10Dbl InLo
Loop

MdDig = FixDbl((InHi.Value + InLo.Value) / 2 + 0.5)
Exit Result & BytToStr(MdDig)
End Function


Private Function SingleToString(ByVal Value As Single, ByRef Exponent As Long, ByRef IsSpecial As Boolean) As String
Dim InHi As HpSng
Dim InLo As HpSng
Dim Middle As HpSng
Dim HiDig As Byte
Dim LoDig As Byte
Dim MdDig As Byte
Dim Ten As Single
Dim Diff As Single
Dim PrevVal As Single
Dim NextVal As Single
Dim Result As String

Set Middle = New HpSng
Set InHi = New HpSng
Set InLo = New HpSng

' Output meaning:
' 1#QNAN Positive quiet NaN
'-1#QNAN Negative quiet NaN
' 1#IND Positive indefinite NaN
'-1#IND Negative indefinite NaN

If Value <> Value Then
IsSpecial = True
Exponent = 0
SingleToString = "1#QNAN"
Exit Function
End If

If Value < 0 Then Result = "-"
Diff = Value - Value

If Diff <> Diff Then
IsSpecial = True
Exponent = 0
SingleToString = Result & "1#IND"
Exit Function
End If

If Value = 0 Then
Exponent = 1
SingleToString = "0"
Exit Function
End If

If Value < 0 Then Value = -Value

If Value = 3.40282347E+38 Then
Exponent = 39
Result &= "340282347"
SingleToString = Result
Exit Function
End If

Ten = 1
Exponent = 1

Rem normalize the midpoint
Middle.Value = Value
Middle.Offset = 0

While ((Middle.Value > 10 OrElse Middle.Value = 10 AndAlso Middle.Offset >= 0)) AndAlso Exponent < 38
Exponent += 1
HpDiv10Sng Middle
Ten /= 10
Wend

While ((Middle.Value < 1 OrElse Middle.Value = 1 AndAlso Middle.Offset < 0)) AndAlso Exponent > -37
Exponent -= 1
HpMul10Sng Middle
Ten *= 10
Wend

FpPnSgn Value, PrevVal, NextVal
InHi.Value = Middle.Value
InHi.Offset = Middle.Offset + (NextVal - Value) * Ten / (2 + ERROL0_EPSILON_SNG)
InLo.Value = Middle.Value
InLo.Offset = Middle.Offset + (PrevVal - Value) * Ten / (2 + ERROL0_EPSILON_SNG)

HpNormalizeSng InHi
HpNormalizeSng InLo

Rem normalized boundaries
While InHi.Value > 10 OrElse InHi.Value = 10 AndAlso InHi.Offset >= 0
Exponent += 1
HpDiv10Sng InHi
HpDiv10Sng InLo
Wend

While InHi.Value < 1 OrElse InHi.Value = 1 AndAlso InHi.Offset < 0
Exponent -= 1
HpMul10Sng InHi
HpMul10Sng InLo
Wend

Rem Digit generation
Do While InHi.Value <> 0 OrElse InHi.Offset <> 0
HiDig = CvByte(InHi.Value)
If InHi.Value = HiDig AndAlso InHi.Offset < 0 Then HiDig -= 1

LoDig = CvByte(InLo.Value)
If InLo.Value = LoDig AndAlso InLo.Offset < 0 Then LoDig -= 1

If LoDig <> HiDig Then Exit Do

Result &= ByToStr(HiDig)

InHi.Value -= HiDig
HpMul10Sng InHi

InLo.Value -= LoDig
HpMul10Sng InLo
Loop

MdDig = FixDbl((InHi.Value + InLo.Value) / 2 + 0.5)
Exit Result & BytToStr(MdDig)
End Function
End Module