# VBForums CodeBank > CodeBank - Visual Basic 6 and earlier >  Make Decimal Type Arrays

## georgekar

This is a way to make array type of Decimals. VB6 has no variables as decimals, you have to use a Variant type. The problem is that the Variant type always get any type we place;

A Decimal type need 16bytes the same as a Variant type. But an array of Decimals has a significant value: First has automatic conversion to decimal and overflow control.

Just put this code in a module in a project without a form and execute it to see the results.



```
Private Declare Sub PutMem2 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Integer)
Function DecimalArray(size)
  Dim d
  ReDim d(size)
  DecimalArray = d
  PutMem2 VarPtr(DecimalArray), vbDecimal + vbArray
End Function
Sub Main()
Dim dArray
  dArray = DecimalArray(100)
  dArray(0) = 100  ' integer to decimal
  Debug.Print dArray(0), VarType(dArray(0)) = vbDecimal, TypeName$(dArray) = "Decimal()"
  On Error Resume Next
  dArray(1) = 1.1E+100
  If Err Then Debug.Print Err.Number = 6, Err.Description = "Overflow"
    ' if you make an array of variant
  Dim faultArray
  ReDim faultArray(10)
  faultArray(0) = CDec("123")
  Debug.Print faultArray(0), VarType(faultArray(0)) = vbDecimal, TypeName$(faultArray) = "Variant()"
  faultArray(1) = 1.1E+100
  Debug.Print faultArray(1), VarType(faultArray(1)) = vbDouble ' no overflow
End Sub
```

Merry Christmas and a happy new year;

----------


## georgekar

More difficult, because Long Long not supported. We can make array, but we can't read or write back values (we can if the array is Variant type). 

This example show how to make the long long array, how to write/read values, how to copy all values to new one, how to resize it.



```
Global Const vbLongLong = 20
Private Declare Sub PutMem2 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal AsInteger)
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long)
Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, retval As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
  (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function SafeArrayRedim Lib "oleaut32" (ByVal saPtr As Long, ByVal saBound As Long) As Long

Private Type SAFEARRAYBOUND
cElements                   As Long
lLbound                     As Long
End Type
Private Type Dec_Hdr
DecType     As Integer
DecScale    As Byte
DecSign     As Byte
End Type
Property Get ArrPtr(anArray) As Long
Dim lptr            As Long
Const VT_BYREF      As Long = &H4000
If Not IsArray(anArray) Then Exit Property
GetMem4 ((VarPtr(anArray) Xor &H80000000) + 8) Xor &H80000000, lptr
If (Peek(VarPtr(anArray)) And VT_BYREF) <> 0 Then
lptr = Peek(lptr)
End If
If lptr = 0 Then Exit Property
GetMem4 ((lptr Xor &H80000000) + 12) Xor &H80000000, lptr
ArrPtr = lptr
End Property
Public Function Peek(ByVal lptr As Long) As Long
GetMem4 lptr, Peek
End Function
Function Elements(anArray, SafeArrayPtr As Long) As Long
Const VT_BYREF      As Long = &H4000
If Not IsArray(anArray) Then Exit Function
GetMem4 ((VarPtr(anArray) Xor &H80000000) + 8) Xor &H80000000, SafeArrayPtr
If (Peek(VarPtr(anArray)) And VT_BYREF) <> 0 Then
SafeArrayPtr = Peek(SafeArrayPtr)
End If
If SafeArrayPtr = 0 Then Exit Function
     
Elements = Peek(((SafeArrayPtr Xor &H80000000) + 16) Xor &H80000000)
End Function

Function RedimLongLong(SafeArrayPtr, newElelements As Long) As Boolean
Dim PadDim As SAFEARRAYBOUND
PadDim.cElements = newElelements
If SafeArrayRedim(ByVal SafeArrayPtr, VarPtr(PadDim)) <> 0& Then Exit Function
RedimLongLong = True
End Function

Property Get ReadLongLong(LLArray, index) As Variant
Dim LLArrayPtr As Long
LLArrayPtr = ArrPtr(LLArray)
If LLArrayPtr = 0 Then Err.Raise 5
CopyMemory ByVal ((VarPtr(ReadLongLong) Xor &H80000000) + 8) Xor &H80000000, ByVal ((LLArrayPtr Xor &H80000000) + 8 * CLng(index)) Xor &H80000000, 8
PutMem2 ByVal VarPtr(ReadLongLong), 20
End Property
Property Let WriteLongLong(LLArray, index, AnyValue)
Dim LLArrayPtr As Long
LLArrayPtr = ArrPtr(LLArray)
If LLArrayPtr = 0 Then Err.Raise 5
If Not VarType(AnyValue) = vbLongLong Then
AnyValue = cInt64(AnyValue)
End If
If Not VarType(AnyValue) = vbLongLong Then Err.Raise 6 ' overflow
CopyMemory ByVal ((LLArrayPtr Xor &H80000000) + 8 * CLng(index)) Xor &H80000000, ByVal ((VarPtr(AnyValue) Xor &H80000000) + 8) Xor &H80000000, 8
End Property
Function LongLongArray(size)
Dim d
ReDim d(size)
LongLongArray = d
PutMem2 VarPtr(LongLongArray), vbLongLong + vbArray
End Function
Sub Main()
Dim dArray, retPtr As Long, i As Long
Dim CopyA
dArray = LongLongArray(100)

WriteLongLong(dArray, 0) = -1000000  ' long to long long
Debug.Print ReadLongLong(dArray, 0), VarType(ReadLongLong(dArray, 0)) = vbLongLong
WriteLongLong(dArray, 1) = cInt64(CDec("123456789012345678"))
WriteLongLong(dArray, 2) = cInt64("123456789012345678")
WriteLongLong(dArray, 3) = cInt64("&H7FFFFFFFFFFFFFFF")
For i = 1 To 3
Debug.Print ReadLongLong(dArray, i), VarType(ReadLongLong(dArray, i)) = vbLongLong
Next i
Dim elem As Long, ok As Boolean, dummy As Long
elem = Elements(dArray, (0))
Debug.Print elem
CopyA = LongLongArray(Elements(dArray, (0)) - 1)
CopyMemory ByVal ArrPtr(CopyA), ByVal ArrPtr(dArray), elem * 8
    
Debug.Print "CopyA has " & Elements(CopyA, (0)) & " elements"
    
    
On Error Resume Next
WriteLongLong(dArray, 3) = 1.1E+100
If Err Then Debug.Print Err.Number = 6, Err.Description = "Overflow"

If Elements(dArray, retPtr) Then
If RedimLongLong(retPtr, 200) Then
Debug.Print "dArray now has " & Elements(dArray, (0)) & " elements"
Debug.Print "CopyA has " & Elements(CopyA, (0)) & " elements"
End If
End If
For i = 1 To 3
Debug.Print ReadLongLong(CopyA, i) = ReadLongLong(dArray, i), "compare array items"
Next i
End Sub
Public Function cInt64(v As Variant) As Variant
Dim DecHdr As Dec_Hdr, m As Long
On Error GoTo er111
cInt64 = CDec(v)
If VarType(v) = vbString Then
If InStr(1, v, "&h", vbTextCompare) = 1 Then
Do
m = Len(v)
v = Replace(v, "&H0", "&H", , , vbTextCompare)
Loop Until Len(v) = m Or m < 5
If m = 10 Then
If cInt64 < 0 Then
cInt64 = CDec("&H100000000") + cInt64
End If
End If
            
End If
End If
CopyMemory DecHdr, ByVal VarPtr(cInt64), LenB(DecHdr)
If DecHdr.DecScale Then
cInt64 = Fix(cInt64)
End If
GetMem4 VarPtr(cInt64) + 12, m
If VarType(v) = vbString Then If m < 0 And Len(v) <= 10 Then GoTo er111
PutMem4 VarPtr(cInt64), vbLongLong
If (DecHdr.DecSign <> 0) And (cInt64 > 0) Then cInt64 = -cInt64
If (VarType(cInt64) <> vbLongLong) Then Err.Raise 6
Exit Function
er111:
Err.Raise 6
End Function
```

----------


## Elroy

Interesting trick.  Basically, you've got an array in a Variant (as opposed to an array OF Variants) ... and you're changing the type of the parent Variant.  This seems dangerous, but it appears to work in the case of a Decimal.

----------


## georgekar

You can do ReDim without problem : ReDim dArray(5000)

----------

