Безопасные указатели

#If Win64 Then
    Const ptrSz As LongPtr = 8
    Const varSz As LongPtr = 24
#Else
    #If Not VBA7 Then
        Private Enum LongPtr
            [_]
        End Enum
    #End If
    Const ptrSz As LongPtr = 4
    Const varSz As LongPtr = 16
#End If
Private Declare PtrSafe Function ArrPtr Lib "VBE7" Alias "VarPtr" (var() As Any) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As LongPtr = ptrSz)
Private Type tpVariant
    vt As Integer
    r1 As Integer
    r2 As Integer
    r3 As Integer
    pt As LongPtr
    r4 As LongPtr
End Type
Private Enum vt
    VT_RefInt = &H4002 '16386
    VT_RefLng = &H4003 '16387
    VT_RefSng = &H4004 '16388
    VT_RefDbl = &H4005 '16389
    VT_RefCur = &H4006 '16390
    VT_RefStr = &H4008 '16392
    VT_RefByt = &H4011 '16401
    VT_RefLngLng = &H4014 '16404
#If Win64 Then
    VT_RefPtr = VT_RefLngLng
#Else
    VT_RefPtr = VT_RefLng
#End If
End Enum
 
Private blInit As Boolean
Private vLnk(1)
 
Sub Пример()
    If Not blInit Then
        InitVarLink vLnk(0), vLnk(1), VT_RefInt
        blInit = True
    End If
    testtest vLnk(0), vLnk(1)
End Sub
 
Sub testtest(ByRef vPtr1 As Variant, ByRef vPtr2 As Variant)
    Dim s$
    
    s = "abcd"
    
    vPtr1 = StrPtr(s) + 2 * 2 'установка указателя на 3 буву в строке s
    
    Stop
End Sub
 
Sub InitVarLink(v1, v2, tp%)
    MakeVarLink 0, v2, tp                     'создание вариантной ссылки нужног типа
    MakeVarLink VarPtr(v2) + 8, v1, VT_RefPtr 'создание ссылки на указатель первой (v2) ссылки
End Sub
Sub MakeVarLink(ByVal ptr As LongPtr, ByRef vLnk As Variant, ByVal vt As Integer)
    Dim tpVar As tpVariant
    tpVar.vt = vt
    tpVar.pt = ptr
    CopyMemory vLnk, tpVar, varSz
End Sub

Sub test(Optional v)
    Dim i%
    i = 2
    Stop
    MakeVarLink2 i, v
    i = 10
    Stop
    v = 6
    Stop
    i = 15
    Stop
End Sub
Sub MakeVarLink2(v1, v2)
    CopyMemory v2, v1, varSz
End Sub

Sub test22()
    Dim lp As LongPtr '(LongLong)
    
    testLongLongInVariant lp
End Sub
 
Sub testLongLongInVariant(vll)
    vll = VarPtr(vll)
End Sub

Sub Пример()
    If Not blInit Then
        InitVarLink vLnk(0), vLnk(1), VT_RefInt
        blInit = True
    End If
    testtest vLnk(0), vLnk(1)
End Sub
 
Sub testtest(ByRef vPtr1 As Variant, ByRef vPtr2 As Variant)
    Dim s$
    
    s = "abcd"
    
    vPtr1 = (StrPtr(s) + 2 * 2) * 0.0001 'установка указателя на 3 буву в строке s
    Debug.Print s
    vPtr2 = 120 'меняем код символа
    Debug.Print s
    Stop
End Sub
 
Sub InitVarLink(v1, v2, tp%)
    MakeVarLink 0, v2, tp                     'создание вариантной ссылки нужног типа
    MakeVarLink VarPtr(v2) + 8, v1, VT_RefCur 'создание ссылки на указатель первой (v2) ссылки
End Sub
Sub MakeVarLink(ByVal ptr As LongPtr, ByRef vLnk1 As Variant, ByVal vt As Integer)
    Dim tpVar As tpVariant
    tpVar.vt = vt
    tpVar.pt = ptr
    CopyMemory vLnk1, tpVar, varSz
End Sub

Sub testStrArray()
    Dim s$
    s = "abcdefg"
    testStrArray_ s
End Sub
Sub testStrArray_(s$)
    Dim l&, sArr() As String
    Dim pSA&
    
    ReDim sArr(0)
    GetMem4 ByVal VarPtr(l) - 4, pSA 'получаем указатель SA массива sArr
    GetMem4 &H80, ByVal pSA + 2      'ставим флаг FADF_HAVEVARTYPE в структуру SA
    
    GetMem4 StrPtr(s), ByVal VarPtr(sArr(0)) 'создаем ссылку на строку s в sArr(0)
    
End Sub

Private Type tPointer                                                           ' Индекс в таблице объектов
    Hash As Integer                                                             ' Хэш
    Index As Integer                                                            ' Индекс
End Type
Private Type tElement                                                           ' Колонка хэш таблицы
    Key As String                                                               ' Ключ
    Value As Variant                                                            ' Значение
    Next As tPointer                                                            ' Индекс следующего элемента
    Prev As tPointer                                                            ' Индекс предыдущего элемента
End Type
Private Type tItem                                                              ' Строка хэш таблицы
    ElementsCount As Long                                                       ' Количество коллизий+1
    Elements() As tElement                                                      ' Элементы
End Type
 
Sub UdtWithString()
    Dim s$
    s = "abcdef"
    UdtWithString_ s
End Sub
 
Sub UdtWithString_(s$)
    Dim ti() As tItem, emp() As tItem, pSA&
    
    ReDim ti(0)
    ReDim ti(0).Elements(0)
    
    GetMem4 StrPtr(s), ByVal VarPtr(ti(0).Elements(0).Key)
    
    GetMem4 ByVal ArrPtr(ti), pSA
    GetMem2 &H80, ByVal pSA + 2 'FADF_HAVEVARTYPE 
    
    ti = emp       
'    Erase ti
End Sub

Sub Пример(Optional vLnk)
    Dim v, i&, s$
    
    s = "abcd"
    MakeVarLink s, vLnk
    Stop
    vLnk = "ifgh"
    Stop
    
    v = 32432
    MakeVarLink v, vLnk
    Stop
    vLnk = 5555
    Stop
    
    v = CDec(35353522522.3423)
    MakeVarLink v, vLnk
    Stop
    vLnk = 234324.2343332 'vLnk = CDec(234324.2343332)
    Stop
    
    v = #3/1/2024#
    MakeVarLink v, vLnk
    Stop
    vLnk = Now
    Stop
End Sub
 
Sub MakeVarLink(Var, Lnk)
'    VT_Ref = &H4000
    Dim vt%
    GetMem2 Var, vt
    If vt < 18 Then
        On vt GoTo 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 2, 3, 2, 2, 1
        GoTo 2
1       GetMem2 VT_Ref Xor vt, Lnk  'не ссылка
        GetMem4 VarPtr(Var) + 8, ByVal VarPtr(Lnk) + 8
    Else
2       If (vt Xor VT_Ref) = VBObject Then 'ссылка
            Set Lnk = Var           'ссылка на объект
        Else
            CopyMemory Lnk, Var, varSz
        End If
    End If
    Exit Sub
3   GetMem2 VT_Ref Xor vt, Lnk      'decimal
    GetMem4 VarPtr(Var), ByVal VarPtr(Lnk) + 8
End Sub

Private Type tagDEC 'decimal
    vt As Integer   'wReserved
    scale As Byte
    sign As Byte
    Hi32 As Long
    Lo64 As Currency
End Type