LongLong

[Elroy]

Okay, I've discovered that there's a much easier way to do this. To my surprise, the LongLong type is actually available to VB6. This may be dependent on the version of oleaut32.dll you have, but I'm on Win7-64, and it's working fine.

If anyone would want to test on an old true 32-bit machine, I'd be curious to see if this would all work.

Here's my latest LongLong class (posted in full, so use Notepad to save the module).

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "LongLong"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'
' A class that allows access to the LongLong type (signed).
'
' +, -, *       These all work as expected.
' /             Converts to a Double, with possible loss of precision.
' \, Mod        Works as expected.
' ^             Converts to a Double, with possible loss of precision.
' Int()         Works as expected.
' Fix()         Works as expected.
' Abs()         Works as expected.
' And, Or, etc  Works as expected.
' Sgn()         Works as expected, although return is an Integer.
' Sqr(), etc.   Most of these functions (including trig) return Double, not Decimal, so some precision may be lost.
'
Option Explicit
'
' https://msdn.microsoft.com/en-us/library/cc237865.aspx for all the types.
Private Declare Function VariantChangeTypeEx Lib "oleaut32" (ByRef pvargDest As Variant, ByRef pvarSrc As Variant, ByVal lcid As Long, ByVal wFlags As Integer, ByVal vt As Integer) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dst As Any, Src As Any, ByVal numbytes As Long)
'
Private Const VT_I8 As Integer = &H14
Private Const VT_ERROR As Integer = &HA
Private Const LOCALE_INVARIANT As Long = &H7F&
'
Private Const LLOverflow = "Overflow - In LongLong procedures"
Private Const LLTypeMismatch = "Type mismatch - In LongLong procedures"
Private Const LLApiTypeError = "VariantChangeTypeEx error - In LongLong procedures"
Private Const LLStrConst = "LongLong"
'
Dim mllValue As Variant  ' THIS is the "master" value.
'

Friend Function Ptr() As Long
    Ptr = VarPtr(mllValue) + 8 ' This points directly at the LongLong, and not the variant.
End Function

Public Property Get Value() As Variant
Attribute Value.VB_UserMemId = 0
Attribute Value.VB_MemberFlags = "200"
    Value = mllValue
End Property

Public Property Let Value(v As Variant)
    '
    ' Warning about strings with HEX in them.
    ' In "almost" all cases, using this method will work absolutely fine for these LongLong types.
    ' However, if your HEX string is 10 characters (8 characters of HEX, eg. "&Hffffffff"),
    ' and the Long (not LongLong) sign bit is on, the number will be interpreted as negative.
    ' To prevent this, do assignment with HexVal property.
    '
    Dim vt As Integer
    ' Make sure it's a type we can deal with.
    vt = VarType(v)
    If (vt = vbArray) Or _
       (vt = vbObject) Or _
       (vt = vbUserDefinedType) Or _
       (vt = vbEmpty) Or _
       (vt = vbNull) Or _
       (vt = vbError) Or _
       (vt = vbVariant) Or _
       (vt = vbDataObject) Then
            Err.Raise 13, LLStrConst, LLTypeMismatch
            Exit Property
    End If
    '
    If VarType(mllValue) <> VT_I8 Then SetToLongLongZero ' This should happen only if there's been an error.
    mllValue = v
    If VarType(mllValue) <> VT_I8 Then
        mllValue = Format$(mllValue) ' This helps with overflow, especially when it's a large Double.
        CheckForErrors VariantChangeTypeEx(mllValue, mllValue, LOCALE_INVARIANT, 0, VT_I8)
    End If
End Property

Friend Property Get HexVal() As String
    Dim lLo As Long
    Dim lHi As Long
    '
    If VarType(mllValue) <> VT_I8 Then Exit Sub ' This should happen only if there's been an error.
    '
    CopyMemory lHi, ByVal VarPtr(mllValue) + 12, 4
    CopyMemory lLo, ByVal VarPtr(mllValue) + 8, 4
    '
    If lHi = 0 Then
        HexVal = Hex$(lLo)
    Else
        HexVal = Hex$(lHi) & Right$("0000000" & Hex$(lLo), 8)
    End If
End Property

Friend Property Let HexVal(s As String)
    If UCase$(Left$(s, 2)) <> "&H" Then
        Err.Raise 13, LLStrConst, LLTypeMismatch
        Exit Property
    End If
    If Len(s) <> 10 Then
        mllValue = s
        CheckForErrors VariantChangeTypeEx(mllValue, mllValue, LOCALE_INVARIANT, 0, VT_I8)
    Else    ' We'll just go around the Long sign bit.
        mllValue = s & "0"
        CheckForErrors VariantChangeTypeEx(mllValue, mllValue, LOCALE_INVARIANT, 0, VT_I8)
        mllValue = mllValue \ &H10
    End If
End Property

Friend Property Get CurrNoDec() As Currency
    ' This one lets you return a Currency while ignoring the implicit 4th decimal place.
    If VarType(mllValue) <> VT_I8 Then SetToLongLongZero ' This should happen only if there's been an error.
    CopyMemory CurrNoDec, ByVal VarPtr(mllValue) + 8, 8
End Property

Friend Property Let CurrNoDec(c As Currency)
    ' This one lets you assign a Currency while ignoring the implicit 4th decimal place.
    CopyMemory mllValue, VT_I8, 2
    CopyMemory ByVal VarPtr(mllValue) + 8, c, 8
End Property

'*****************************************************
'*****************************************************
' Everything is private from here down.
'*****************************************************
'*****************************************************
'
Private Sub Class_Initialize()
    SetToLongLongZero
End Sub

Private Sub SetToLongLongZero()
    mllValue = 0&
    VariantChangeTypeEx mllValue, mllValue, LOCALE_INVARIANT, 0, VT_I8
End Sub

Private Sub CheckForErrors(lRet As Long)
    Const S_OK = 0&
    Const DISP_E_BADVARTYPE = &H80020008
    Const DISP_E_OVERFLOW = &H8002000A
    Const DISP_E_TYPEMISMATCH = &H80020005
    Const E_INVALIDARG = &H80070057
    Const E_OUTOFMEMORY = &H8007000E
    '
    Select Case lRet
    Case S_OK
        ' Nothing to do here, all good.
    Case DISP_E_BADVARTYPE
        Err.Raise lRet, LLStrConst, LLApiTypeError
    Case DISP_E_OVERFLOW
        Err.Raise 6, LLStrConst, LLOverflow
    Case DISP_E_TYPEMISMATCH
        Err.Raise lRet, LLStrConst, LLApiTypeError
    Case E_INVALIDARG
        Err.Raise lRet, LLStrConst, LLApiTypeError
    Case E_OUTOFMEMORY
        Err.Raise lRet, LLStrConst, LLApiTypeError
    End Select
End Sub

And here's a bit of test code to throw into a Form1 (just paste this one into Form1 in IDE):

Option Explicit

Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime   As Currency
   ftLastAccessTime As Currency
   ftLastWriteTime  As Currency
   nFileSize        As Currency
   dwReserved       As Currency
   cFileName        As String * 260
   cAlternate       As String * 14
End Type
'
Private Type SYSTEMTIME
   wYear            As Integer
   wMonth           As Integer
   wDayOfWeek       As Integer
   wDay             As Integer
   wHour            As Integer
   wMinute          As Integer
   wSecond          As Integer
   wMilliseconds    As Integer
End Type
'
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FileTimeToSystemTimePtr Lib "kernel32" Alias "FileTimeToSystemTime" (lpFileTimePtr As Long, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As Currency, lpSystemTime As SYSTEMTIME) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dst As Any, Src As Any, ByVal numbytes As Long)
'

Private Sub Form_Load()
    Dim LL1 As New LongLong
    Dim LL2 As New LongLong
    Dim LL3 As New LongLong


    Const sLargeFileSpec = "C:\Users\Elroy\Desktop\test.txt"



    '
    ' Some simple tests.
    '
    LL1 = 5
    LL2 = LL1 And 4
    MsgBox LL2
    MsgBox LL1 + LL2
    MsgBox LL1 * LL2
    MsgBox LL1 / LL2 ' This will result in a Double.
    MsgBox LL1 \ LL2
    MsgBox LL1 ^ LL2
    LL3 = LL1 ^ LL2
    MsgBox LL3

    LL1.HexVal = "&Hffffffff8"
    MsgBox LL1
    MsgBox LL1.HexVal




    '
    ' Some more rigorous tests.
    '
    LL1 = "9223372036854775807" ' Largest LongLong value in VBA.
    MsgBox LL1
    'LL1 = LL1 + 1   ' This will be an overflow.

    LL1 = "-9223372036854775807" ' Smallest LongLong value in VBA.
    MsgBox LL1
    LL1 = LL1 - 1   ' This not overflow.
    MsgBox LL1
    'LL1 = LL1 - 1   ' This will be an overflow.

    Dim d As Double
    d = 9.22337203685477E+18
    LL1 = d
    MsgBox LL1
    'LL1 = LL1 * 2 ' This will overflow.



    '
    ' Test the use of the pointer with API calls.
    '
    Dim hSearch As Long
    Dim wfd As WIN32_FIND_DATA

    hSearch = FindFirstFile(sLargeFileSpec, wfd)
    FindClose hSearch

    LL1.CurrNoDec = SwapLow4AndHigh4(wfd.nFileSize) ' FileSize comes in with low 4 and high 4 reversed.  FileTime is correct.
    MsgBox "FileSize: " & LL1

    Dim st As SYSTEMTIME
    FileTimeToSystemTime wfd.ftCreationTime, st
    MsgBox "Old way, creation date: " & DateSerial(st.wYear, st.wMonth, st.wDay) + TimeSerial(st.wHour, st.wMinute, st.wSecond)

    LL1.CurrNoDec = wfd.ftCreationTime
    FileTimeToSystemTimePtr ByVal LL1.Ptr, st                 ' <---- This actually tests the use of the ptr property of the LongLong.
    MsgBox "Creation Date: " & DateSerial(st.wYear, st.wMonth, st.wDay) + TimeSerial(st.wHour, st.wMinute, st.wSecond)



    Unload Me
End Sub

Public Function SwapLow4AndHigh4(c As Currency) As Currency
    CopyMemory SwapLow4AndHigh4, ByVal VarPtr(c) + 4, 4
    CopyMemory ByVal VarPtr(SwapLow4AndHigh4) + 4, c, 4
End Function

I've also attached it as a ZIP file.

Enjoy, and let me know what you think,
Elroy