Нативный CopyMemory

'Attribute VB_Name = "RefTypes"
'================================================================================================================================'
' RefTypes  (edited By testuser2 07.25)                                                                                                                    '
'--------------------------------------------------------                                                                        '
' https://github.com/WNKLER/RefTypes                                                                                             '
'--------------------------------------------------------                                                                        '
' A VBA/VB6 Library for reading/writing intrinsic types at arbitrary memory addresses.                                           '
' Its defining feature is that this is achieved using truly native, built-in language features.                                  '
' It uses no API declarations and has no external dependencies.                                                                  '
'================================================================================================================================'
' MIT License                                                                                                                    '
'                                                                                                                                '
' Copyright (c) 2025 Benjamin Dovidio (WNKLER)                                                                                   '
'                                                                                                                                '
' Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated                   '
' documentation files (the "Software"), to deal in the Software without restriction, including without limitation                '
' the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software,                   '
' and to permit persons to whom the Software is furnished to do so, subject to the following conditions:                         '
'                                                                                                                                '
' The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. '
'                                                                                                                                '
' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO               '
' THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE                 '
' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,            '
' TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.       '
'================================================================================================================================'
' Option Private Module
Option Explicit
 
#If Win64 = 1 Then
    Private Const Win64 As Integer = 1
#Else
    Private Const Win64 As Integer = 0
    Public Type LongLong
        L0x0 As Long
        L0x4 As Long
    End Type
#End If
#If VBA7 = 0 Then
    Private Enum LONG_PTR: [_]: End Enum
     Public Enum LongPtr:  [_]: End Enum '// Must be Public for Enum-typed Public Property
#End If
Private Const LPTR_SIZE As Long = 4 + (Win64 * 4)
Private Const FADF_FIXEDSIZE_AUTO = &H11&
'*********************************************************************************'
' This section just sets up the array bounds according to the four `UserDefined`  '
' parameters. If you already know the correct bounds, you can just hardcode them. '
Private Const LPROXY_SIZE      As Long = 1         '// UserDefined (should be an integer divisor of <PTR_SIZE>)
Private Const LELEMENT_SIZE    As Long = LPTR_SIZE '// UserDefined (usually should be <PTR_SIZE>)
Private Const LSIZE_PROXIED    As Long = LELEMENT_SIZE - LPROXY_SIZE
Private Const LBLOCK_STEP_SIZE As Long = LELEMENT_SIZE * LSIZE_PROXIED
Private Const Proxy_Count = 19
Private Enum BOUNDS_HELPER:
  [_BLOCK_ALLOCATION_SIZE] = Proxy_Count * LPTR_SIZE      '// UserDefined (the size of the region being proxied)
  [_0x0_ADDRESS_ALIGNMENT] = 0                     '// UserDefined (<BLOCK_ALLOCATION_ADDRESS> Mod <PTR_SIZE>)
  [_SIZE_OF_ALIGNED_BLOCK] = ([_0x0_ADDRESS_ALIGNMENT] - LPTR_SIZE) * ([_0x0_ADDRESS_ALIGNMENT] > 0) + [_BLOCK_ALLOCATION_SIZE]
  [_ELEMENT_SIZE_OF_PROXY] = ([_SIZE_OF_ALIGNED_BLOCK] + LBLOCK_STEP_SIZE - 1) \ LBLOCK_STEP_SIZE
  [_ELEMENT_SIZE_OF_BLOCK] = ([_ELEMENT_SIZE_OF_PROXY] * (LELEMENT_SIZE \ LPROXY_SIZE)) - [_ELEMENT_SIZE_OF_PROXY]
End Enum
Private Const LELEMENTS_LBOUND As Long = [_ELEMENT_SIZE_OF_PROXY] * -1
Private Const LELEMENTS_UBOUND As Long = [_ELEMENT_SIZE_OF_BLOCK] + (LELEMENTS_LBOUND < 0)
Private Const LBLOCK_OFFSET    As Long = [_ELEMENT_SIZE_OF_PROXY] * LELEMENT_SIZE '// Relative to VarPtr(<MemoryProxyVariable>)
Private Const LBLOCK_SIZE      As Long = [_ELEMENT_SIZE_OF_BLOCK] * LELEMENT_SIZE '
 
'*********************************************************************************'
 
Private Type ProxyElement               '// This could be anything. I have it as an array of bytes only for the
    ProxyAlloc(LPROXY_SIZE - 1) As Byte '// convenience of binding its size to a constant, and for maximum granularity.
End Type                                '// Although, be aware that this structure determines MemoryProxy alignment.
Private Type MemoryProxy                                           '// The declared type of `Elements()` can be any of
    Elements(LELEMENTS_LBOUND To LELEMENTS_UBOUND) As ProxyElement '// the following: Enum, UDT, or Alias (typedef)
End Type                                                           '// NOTE: A ProxyElement's Type must be smaller
 
'// than the Type of the Element it represents.
'******************************************************************'
' When passed to `InitByProxy()`, the `Initializer.Elements` array '
' provides access to fourteen, pointer-sized elements immmediately '
' following the `Initializer` variable's memory allocation.        '
 
Public Initializer   As MemoryProxy
' <Memory proxied by `Initializer`>
Public m_RefInt()    As Integer     '1 m_SA1
Public m_RefLng()    As Long
Public m_RefSng()    As Single
Public m_RefDbl()    As Double
Public m_RefCur()    As Currency
Public m_RefDate()   As Date
Public m_RefStr()    As String
Public m_RefObj()    As Object
Public m_RefBool()   As Boolean
Public m_RefVar()    As Variant
Public m_RefUnk()    As IUnknown
'Public m_RefDec()    As Variant
Public m_RefByte()   As Byte
Public m_RefLngLng() As LongLong
Public m_RefLngPtr() As LongPtr     '14
 
Public m_RefLngPtr2() As LongPtr    '15 m_SA2
 
Public iMap1() As Integer           '16 iMap1_SA мапперы строк
Public iMap2() As Integer           '17 iMap2_SA
Public bMap1() As Byte              '18 iMap1_SA
Public bMap2() As Byte              '19 iMap2_SA
 
' <End of proxied memory block>
'*******************************************************************'
                                                                                               
'*************************************************************************************************'
' Inspired by Cristian Buse's `VBA-MemoryTools` <https://github.com/cristianbuse/VBA-MemoryTools> '
' Arbitrary memory access is achieved via a carefully constructed SAFEARRAY `Descriptor` struct.  '
 
Public m_SA As SAFEARRAY1D, m_SA2 As SAFEARRAY1D
Public iMap1_SA As SAFEARRAY1D, iMap2_SA As SAFEARRAY1D, bMap1_SA As SAFEARRAY1D, bMap2_SA As SAFEARRAY1D
 
'*************************************************************************************************'
Private IsInitialized As Boolean
 
Sub Initialize()
    If IsInitialized Then Exit Sub
    
    With m_SA
      .cDims = 1
      .fFeatures = FADF_FIXEDSIZE_AUTO
      .cLocks = 1
      .cbElements = 1
      .Bounds.cCount = 1
    End With
    With m_SA2
      .cDims = 1
      .fFeatures = FADF_FIXEDSIZE_AUTO
      .cLocks = 1
      .cbElements = ptrSz
      .Bounds.cCount = 1
    End With
    With iMap1_SA
      .cDims = 1
      .fFeatures = FADF_FIXEDSIZE_AUTO
      .cLocks = 1
      .cbElements = 2
      .Bounds.lBound = 1
    End With
    With iMap2_SA
      .cDims = 1
      .fFeatures = FADF_FIXEDSIZE_AUTO
      .cLocks = 1
      .cbElements = 2
      .Bounds.lBound = 1
    End With
    With bMap1_SA
      .cDims = 1
      .fFeatures = FADF_FIXEDSIZE_AUTO
      .cLocks = 1
      .cbElements = 1
      .Bounds.lBound = 1
    End With
    With bMap2_SA
      .cDims = 1
      .fFeatures = FADF_FIXEDSIZE_AUTO
      .cLocks = 1
      .cbElements = 1
      .Bounds.lBound = 1
    End With
    InitByProxy Initializer.Elements, VarPtr(m_SA), 14
    
    InitOneByProxy Initializer.Elements, 14, VarPtr(m_SA2)
    
    InitOneByProxy Initializer.Elements, 15, VarPtr(iMap1_SA)
    InitOneByProxy Initializer.Elements, 16, VarPtr(iMap2_SA)
    InitOneByProxy Initializer.Elements, 17, VarPtr(bMap1_SA)
    InitOneByProxy Initializer.Elements, 18, VarPtr(bMap2_SA)
    
    IsInitialized = True
End Sub
'*********************************************************************************'
' This is only possible because the compiler does not (or cannot?) discriminate   '
' between <Non-Intrinsic Array Argument> types passed to <Array Parameters> whose '
' <Declared Type> is an <Enum> or an <Alias> (a non-struct typdef).               '
' Such Array Parameters will accept any <UDT/Enum/Alias>-typed array argument.    '
'                                                                                 '
' Another key behavior is that (except for cDims, pvData, and Bounds) the array   '
' descriptor has no effect on indexing/reading/writing the array elements within  '
' the scope of the receiving procedure; indexing/reading/writing align with the   '
' declared type of the Array Parameter. (this behavior is not critical, but it    '
' greatly simplifies the implementation) NOTE: You cannot pass an element ByRef   '
' from inside the procedure. Doing so passes the address of its proxy.            '
'                                                                                 '
' Similarly, Array Parameters whose <Declared Type> is <Fixed-Length-String> will '
' accept ANY <Fixed-Length-String> array argument, regardless of Declared Length. '
' However, since Fixed-Length-Strings have no alignment, the starting position of '
' an element and the starting position of its proxy will always be the same.      '
'*********************************************************************************'
Private Sub InitByProxy(ProxyElements() As LONG_PTR, ByVal pSA As LongPtr, ByVal proxyCount&)
    Dim i As Long
    
    For i = 0& To proxyCount - 1
        ProxyElements(i) = pSA
    Next i
End Sub
Private Sub InitOneByProxy(ProxyElements() As LONG_PTR, ByVal num As Long, ByVal pSA As LongPtr)
    ProxyElements(num) = pSA
End Sub
 
Property Get RefInt(ByVal Target As LongPtr) As Integer
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefInt = m_RefInt(0&)
End Property
Property Let RefInt(ByVal Target As LongPtr, ByVal RefInt As Integer)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefInt(0&) = RefInt
End Property
Property Get RefLng(ByVal Target As LongPtr) As Long
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefLng = m_RefLng(0&)
End Property
Property Let RefLng(ByVal Target As LongPtr, ByVal RefLng As Long)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefLng(0&) = RefLng
End Property
 
Property Get RefSng(ByVal Target As LongPtr) As Single
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefSng = m_RefSng(0&)
End Property
Property Let RefSng(ByVal Target As LongPtr, ByVal RefSng As Single)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefSng(0&) = RefSng
End Property
Property Get RefDbl(ByVal Target As LongPtr) As Double
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefDbl = m_RefDbl(0&)
End Property
Property Let RefDbl(ByVal Target As LongPtr, ByVal RefDbl As Double)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefDbl(0&) = RefDbl
End Property
 
Property Get RefCur(ByVal Target As LongPtr) As Currency
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefCur = m_RefCur(0&)
End Property
Property Let RefCur(ByVal Target As LongPtr, ByVal RefCur As Currency)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefCur(0&) = RefCur
End Property
 
Property Get RefDate(ByVal Target As LongPtr) As Date
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefDate = m_RefDate(0&)
End Property
Property Let RefDate(ByVal Target As LongPtr, ByVal RefDate As Date)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefDate(0&) = RefDate
End Property
Property Get RefStr(ByVal Target As LongPtr) As String
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefStr = m_RefStr(0&)
End Property
Property Let RefStr(ByVal Target As LongPtr, ByRef RefStr As String)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefStr(0&) = RefStr
End Property
Property Get RefObj(ByVal Target As LongPtr) As Object
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    Set RefObj = m_RefObj(0&)
End Property
Property Set RefObj(ByVal Target As LongPtr, ByVal RefObj As Object)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    Set m_RefObj(0&) = RefObj
End Property
Property Get RefBool(ByVal Target As LongPtr) As Boolean
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefBool = m_RefBool(0&)
End Property

Property Let RefBool(ByVal Target As LongPtr, ByVal RefBool As Boolean)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefBool(0&) = RefBool
End Property
Property Get RefVar(ByVal Target As LongPtr) As Variant
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefVar = m_RefVar(0&)
End Property
Property Let RefVar(ByVal Target As LongPtr, ByRef RefVar As Variant)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefVar(0&) = RefVar
End Property
Property Set RefVar(ByVal Target As LongPtr, ByRef RefVar As Variant)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    Set m_RefVar(0&) = RefVar
End Property
Property Get RefUnk(ByVal Target As LongPtr) As IUnknown
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    Set RefUnk = m_RefUnk(0&)
End Property
Property Set RefUnk(ByVal Target As LongPtr, ByVal RefUnk As IUnknown)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    Set m_RefUnk(0&) = RefUnk
End Property
Property Get RefDec(ByVal Target As LongPtr) As Variant
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefDec = m_RefDec(0&)
End Property
Property Let RefDec(ByVal Target As LongPtr, ByVal RefDec As Variant)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefDec(0&) = RefDec
End Property '_
Property Get RefByte(ByVal Target As LongPtr) As Byte
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefByte = m_RefByte(0&)
End Property
Property Let RefByte(ByVal Target As LongPtr, ByVal RefByte As Byte)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefByte(0&) = RefByte
End Property
Property Get RefLngLng(ByVal Target As LongPtr) As LongLong
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefLngLng = m_RefLngLng(0&)
End Property
#If Win64 = 0 Then
Property Let RefLngLng(ByVal Target As LongPtr, ByRef RefLngLng As LongLong)
#Else
Property Let RefLngLng(ByVal Target As LongPtr, ByVal RefLngLng As LongLong)
#End If
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefLngLng(0&) = RefLngLng
End Property
Property Get RefLngPtr(ByVal Target As LongPtr) As LongPtr
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    RefLngPtr = m_RefLngPtr(0&)
End Property
Property Let RefLngPtr(ByVal Target As LongPtr, ByVal RefLngPtr As LongPtr)
    If IsInitialized Then Else Initialize
    m_SA.pvData = Target
    m_RefLngPtr(0&) = RefLngPtr
End Property
 
Property Get RefLngPtr2(ByVal Target As LongPtr) As LongPtr
    If IsInitialized Then Else Initialize
    m_SA2.pvData = Target
    RefLngPtr = m_RefLngPtr(0&)
End Property
Property Let RefLngPtr2(ByVal Target As LongPtr, ByVal RefLngPtr2 As LongPtr)
    If IsInitialized Then Else Initialize
    m_SA2.pvData = Target
    m_RefLngPtr2(0&) = RefLngPtr2
End Property
Private Sub TestMovePtr()
    Dim sAr1$(), sAr2$(), pSA As LongPtr
    
    Initialize
    
    ReDim sAr1(2): sAr1(1) = "fasfsad"
    
    Stop 'см. Immediate
    MovePtr VarPtr(pSA) + LenB(pSA) * 2, VarPtr(pSA) + LenB(pSA)
    Stop
End Sub
Sub MovePtr(ByVal pDst As LongPtr, ByVal pSrc As LongPtr)
    If IsInitialized Then Else Initialize
    m_SA.pvData = pDst
    m_SA2.pvData = pSrc
    m_RefLngPtr2(0&) = m_RefLngPtr(0&)
    m_RefLngPtr(0&) = 0
End Sub
Private Sub TestStrCompVBA()
    Dim s1$, s2$, lres&, lres2&
    s1 = "abcd"
    s2 = "abc"
    lres = StrCompVBA(s2, s1)
    lres2 = StrComp(s2, s1)
End Sub
Private Function StrCompVBA(str1$, str2$) As Long
    Dim len1&, len2&, lenMin&
    Dim i&, dif&
    If IsInitialized Then Else Initialize
    
    len1 = Len(str1) + 1: len2 = Len(str2) + 1
    If len1 > len2 Then lenMin = len2 Else lenMin = len1
    iMap1_SA.pvData = StrPtr(str1)
    iMap1_SA.Bounds.cCount = lenMin
    iMap2_SA.pvData = StrPtr(str2)
    iMap2_SA.Bounds.cCount = lenMin
    
    For i = 1 To lenMin
        dif = iMap1(i) - iMap2(i)
        If dif Then Exit For
    Next
    
    StrCompVBA = dif
End Function
Private Sub TestInStrRev2()
    Dim sCheck$, sMatch$, lres&, lres2&
    sCheck = "rtoiutpoipkj"
    sMatch = "tpoi"
    lres = InStrRev2(sCheck, sMatch, 10, 5)
    lres2 = InStrRev2B(sCheck, sMatch, 18, 10)
    Stop
End Sub
Function InStrRev2(sCheck$, sMatch$, Optional ByVal lStart As Long = -1, Optional ByVal lStop As Long = 1) As Long
    Dim i&, j&, k&, lenCheck&, lenMatch&
    If IsInitialized Then Else Initialize
    
    lenCheck = Len(sCheck)
    lenMatch = Len(sMatch)
    If lStart = -1 Then lStart = lenCheck
    
    iMap1_SA.pvData = StrPtr(sCheck)
    iMap1_SA.Bounds.cCount = lenCheck
    iMap2_SA.pvData = StrPtr(sMatch)
    iMap2_SA.Bounds.cCount = lenMatch
    
    j = lenMatch
    For i = lStart To lStop + lenMatch - 1 Step -1
        If iMap1(i) <> iMap2(j) Then
        Else
            k = i
            For j = j - 1 To 1 Step -1
                k = k - 1
                If iMap1(k) = iMap2(j) Then
                Else
                    j = lenMatch
                    GoTo skip
                End If
            Next
            InStrRev2 = k: Exit Function
        End If
skip:
    Next
End Function
Function InStrRev2B(sCheck$, sMatch$, Optional ByVal lStart As Long = -1, Optional ByVal lStop As Long = 1) As Long
    Dim i&, j&, k&, lenCheck&, lenMatch&
    If IsInitialized Then Else Initialize
    
    lenCheck = LenB(sCheck)
    lenMatch = LenB(sMatch)
    If lStart = -1 Then lStart = lenCheck
    
    bMap1_SA.pvData = StrPtr(sCheck)
    bMap1_SA.Bounds.cCount = lenCheck
    bMap2_SA.pvData = StrPtr(sMatch)
    bMap2_SA.Bounds.cCount = lenMatch
    
    j = lenMatch
    For i = lStart To lStop + lenMatch - 1 Step -1
        If bMap1(i) <> bMap2(j) Then
        Else
            k = i
            For j = j - 1 To 1 Step -1
                k = k - 1
                If bMap1(k) = bMap2(j) Then
                Else
                    j = lenMatch
                    GoTo skip
                End If
            Next
            InStrRev2B = k: Exit Function
        End If
skip:
    Next
End Function