Авторские программы, библиотеки, надстройки и шаблоны

Private MyCol As New Collection, KeyArray()
 
Public Sub Add(MyKey, MyItem)
    MyCol.Add MyItem, CStr(MyKey)
    ReDim Preserve KeyArray(1 To MyCol.Count)
    KeyArray(MyCol.Count) = CStr(MyKey)
End Sub
 
Public Property Get Count() As Long
    Count = MyCol.Count
End Property
 
Public Function Exists(MyKey) As Boolean
    On Error GoTo Err1
    MyCol.Add 0, CStr(MyKey)
    MyCol.Remove CStr(MyKey)
    Exists = False
    Exit Function
Err1:
    Err.Clear
    Exists = True
End Function
 
Public Property Get Item(Optional MyKey)
    ''Attribute Item.VB_UserMemId = 0
    Attribute Item.VB_UserMemId = 0
    If IsObject(MyCol(CStr(MyKey))) Then
       Set Item = MyCol(CStr(MyKey))
    Else
       Item = MyCol(CStr(MyKey))
    End If
End Property
 
Public Property Let Item(Optional MyKey, ByVal NewItem)
    ''Attribute Item.VB_UserMemId = 0
    Attribute Item.VB_UserMemId = 0
    On Error GoTo Err2
    MyCol.Add NewItem, CStr(MyKey)
    ReDim Preserve KeyArray(1 To MyCol.Count)
    KeyArray(MyCol.Count) = CStr(MyKey)
    Exit Property
Err2:
    Err.Clear
    MyCol.Remove CStr(MyKey)
    MyCol.Add NewItem, CStr(MyKey)
End Property
 
Public Function Items()
    Dim A(), i&, El
    ReDim A(1 To MyCol.Count)
    For Each El In MyCol
        i = i + 1
        If IsObject(El) Then
            Set A(i) = El
        Else
             A(i) = El
        End If
    Next
End Function
 
Public Property Let Key(MyKey)
    Dim OldItem
    If IsObject(MyCol(MyKey)) Then
        Set OldItem = MyCol(MyKey)
    Else
        OldItem = MyCol(MyKey)
    End If
    MyCol.Remove MyKey
    MyCol.Add OldItem, CStr(MyKey)
End Property
 
Public Function Keys()
    Keys = KeyArray
End Function
 
Public Sub Remove(MyKey)
    Dim i&, El, KeyArrayOld()
    KeyArrayOld() = KeyArray()
    MyCol.Remove CStr(MyKey)
    ReDim KeyArray(1 To MyCol.Count)
    For Each El In KeyArrayOld
        If El <> CStr(MyKey) Then
            i = i + 1
            KeyArray(i) = El
        End If
    Next
End Sub
 
Public Sub RemoveAll()
    Dim El
    For Each El In KeyArray
        MyCol.Remove El
    Next
    ReDim KeyArray(1)
End Sub

Sub Class_ScriptingDictionaryAnalog_Example()
    Dim vX, Dic As New ScriptingDictionaryAnalog
    Dic.Add "AA", 1
    Dic.Add "BB", 2
    Dic.Item("CC") = 3
    Dic("DD") = 4
    Debug.Print Dic.Exists("BB")
    Debug.Print Dic.Count
    For Each vX In Dic.Keys
       Debug.Print vX, Dic.Item(vX)
    Next
    Dic.Item("CC") = 30
    For Each vX In Dic.Keys
       Debug.Print vX, Dic(vX)
    Next
    Dic.Remove "AA"
    For Each vX In Dic.Keys
       Debug.Print vX, Dic(vX)
    Next
    Dic.RemoveAll
    Debug.Print Dic.Count
    Set Dic = Nothing
End Sub

Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Declare PtrSafe Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Src() As Any) As LongPtr
 
Type SAFEARRAYBOUND
    cCount              As Long
    lBound              As Long
End Type
Type SAFEARRAYBOUND2D
    Bounds(1)           As SAFEARRAYBOUND
End Type
#If Win64 Then
    Const ptrSz         As LongPtr = 8
    Const offsetBnds    As LongPtr = 24
#Else
    Const ptrSz         As Long    = 4
    Const offsetBnds    As Long    = 16
#End If
 
Sub RedimPreserve2D1ColumnVar(Arr(), newLBnd As Long, newUBnd As Long)
    Dim SABnd2D As SAFEARRAYBOUND2D
    RedimPreserve2D1ColumnVar_ Arr(), newLBnd, newUBnd, SABnd2D
End Sub
Sub RedimPreserve2D1ColumnVar_(Arr(), newLBnd As Long, newUBnd As Long, SABnd2D As SAFEARRAYBOUND2D, Optional ByVal stumb As Long)
    Dim tmpBnds As SAFEARRAYBOUND, pSA As LongPtr    
    CopyMemory pSA, ByVal ArrPtr(Arr), ptrSz
    CopyMemory ByVal VarPtr(stumb) - ptrSz, pSA + offsetBnds, ptrSz
    tmpBnds = SABnd2D.Bounds(0)
    SABnd2D.Bounds(0) = SABnd2D.Bounds(1)
    SABnd2D.Bounds(1) = tmpBnds
    ReDim Preserve Arr(SABnd2D.Bounds(1).lBound To UBound(Arr), SABnd2D.Bounds(0).lBound To newUBnd)
    SABnd2D.Bounds(1) = SABnd2D.Bounds(0)
    SABnd2D.Bounds(0) = tmpBnds
    SABnd2D.Bounds(0).lBound = newLBnd
End Sub
 
Sub ПримерИспользования()
    Dim Arr()
    ReDim Arr(1 To 5, 1 To 1)
    Arr(1, 1) = 2
    Arr(2, 1) = 5
    Arr(3, 1) = 7
    Stop 'см. Locals
    RedimPreserve2D1ColumnVar Arr, 1, 3
    Stop 'см. Locals
End Sub

'Class vbaClipboard
'Code edited from https://social.msdn.microsoft.com/Forums/office/en-US/ee9e0d28-0f1e-467f-8d1d-1a86b2db2878/a-clipboard-object-for-vba-including-microsoft-word?forum=worddev
'Moved to VB7 64 bit support https://stackoverflow.com/questions/35416662/text-to-clipboard-in-vba-windows-10-issue
'Improved by Tester to support Unicode, Utf8 and etc. 24-26.03.24 https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=163737&TITLE_SEO=163737-vba-chast-teksta-_poluzhirnyy_-v-bufer-obmena_-iz-peremennoy&MID=1293241#message1293241
Option Explicit
 
#If VBA7 Then
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function RegisterClipboardFormatW Lib "user32" (ByVal lpString As LongPtr) As Long 'Ptr
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function GetClipBoardData Lib "user32" Alias "GetClipboardData" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPtr
    Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function lstrcpyW Lib "kernel32" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As LongPtr
    'NOTE: These declarations are not provided in https://stackoverflow.com/questions/35416662/text-to-clipboard-in-vba-windows-10-issue
    Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function GetClipboardFormatNameW Lib "user32" (ByVal wFormat As Long, ByVal lpString As LongPtr, ByVal nMaxCount As Long) As Long 'Ptr
    Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As LongPtr, ByVal cchMultiByte As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long) As Long
    Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, ByVal lpMultiByteStr As LongPtr, ByVal cchMultiByte As Long, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As Long
#Else
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function RegisterClipboardFormatW Lib "user32" (ByVal lpString As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function GetClipBoardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    'the code from this thread, use:
    'Replacing with that used in https://stackoverflow.com/questions/35416662/text-to-clipboard-in-vba-windows-10-issue
    Private Declare Function lstrcpyW Lib "kernel32" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
    'NOTE: These declarations are not provided in https://stackoverflow.com/questions/35416662/text-to-clipboard-in-vba-windows-10-issue
    Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function GetClipboardFormatNameW Lib "user32" (ByVal wFormat As Long, ByVal lpString As Long, ByVal nMaxCount As Long) As Long
    Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
'    Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal olestr As Long, ByVal BLen As Long) As Long
'    Private Declare Function SysAllocStringLen Lib "oleaut32" (ByVal olestr As Long, ByVal BLen As Long) As Long
#End If
 
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT) 'Use for hwnd
Private Const NAME_MAX_LENGTH = 1024
Private Const APINULL = 0
Private Const CF_TEXT = 1               'Text format. Each line ends with a carriage return/linefeed (CR-LF) combination. A null character signals the end of the data. Use this format for ANSI text.
Private Const CF_BITMAP = 2             'A handle to a bitmap (HBITMAP).
Private Const CF_METAFILEPICT = 3       'Handle to a metafile picture format as defined by the METAFILEPICT structure. When passing a CF_METAFILEPICT handle by means of DDE, the application responsible for deleting hMem should also free the metafile referred to by the CF_METAFILEPICT handle.
Private Const CF_SYLK = 4               'Microsoft Symbolic Link (SYLK) format.
Private Const CF_TIFF = 6               'Tagged-image file format.
Private Const CF_DIF = 5                'Software Arts' Data Interchange Format.
Private Const CF_OEMTEXT = 7            'Text format containing characters in the OEM character set. Each line ends with a carriage return/linefeed (CR-LF) combination. A null character signals the end of the data.
Private Const CF_DIB = 8                'A memory object containing a BITMAPINFO structure followed by the bitmap bits.
Private Const CF_PALETTE = 9            'Handle to a color palette. Whenever an application places data in the clipboard that depends on or assumes a color palette, it should place the palette on the clipboard as well.
Private Const CF_PENDATA = 10           'Data for the pen extensions to the Microsoft Windows for Pen Computing.
Private Const CF_RIFF = 11              'Represents audio data more complex than can be represented in a CF_WAVE standard wave format.
Private Const CF_WAVE = 12              'Represents audio data in one of the standard wave formats, such as 11 kHz or 22 kHz PCM.
Private Const CF_UNICODETEXT = 13       'Unicode text format. Each line ends with a carriage return/linefeed (CR-LF) combination. A null character signals the end of the data.
Private Const CF_ENHMETAFILE = 14       'A handle to an enhanced metafile (HENHMETAFILE).
Private Const CF_HDROP = 15             'A handle to type HDROP that identifies a list of files. An application can retrieve information about the files by passing the handle to the DragQueryFile function.
Private Const CF_LOCALE = 16            'The data is a handle to the locale identifier associated with text in the clipboard. When you close the clipboard, if it contains CF_TEXT data but no CF_LOCALE data, the system automatically sets the CF_LOCALE format to the current input language. You can use the CF_LOCALE format to associate a different locale with the clipboard text.
Private Const CF_DIBV5 = 17             'A memory object containing a BITMAPV5HEADER structure followed by the bitmap color space information and the bitmap bits.
Private Const CF_DSPBITMAP = &H82       'Bitmap display format associated with a private format. The hMem parameter must be a handle to data that can be displayed in bitmap format in lieu of the privately formatted data.
Private Const CF_DSPENHMETAFILE = &H8E  'Enhanced metafile display format associated with a private format. The hMem parameter must be a handle to data that can be displayed in enhanced metafile format in lieu of the privately formatted data.
Private Const CF_DSPMETAFILEPICT = &H83 'Metafile-picture display format associated with a private format. The hMem parameter must be a handle to data that can be displayed in metafile-picture format in lieu of the privately formatted data.
Private Const CF_DSPTEXT = &H81         'Text display format associated with a private format. The hMem parameter must be a handle to data that can be displayed in text format in lieu of the privately formatted data.
Private Const CF_GDIOBJFIRST = &H300    'Start of a range of integer values for application-defined GDI object clipboard formats. The end of the range is CF_GDIOBJLAST.
Private Const CF_GDIOBJLAST = &H3FF     'See CF_GDIOBJFIRST.
Private Const CF_OWNERDISPLAY = &H80    'Owner-display format. The clipboard owner must display and update the clipboard viewer window, and receive the WM_ASKCBFORMATNAME, WM_HSCROLLCLIPBOARD, WM_PAINTCLIPBOARD, WM_SIZECLIPBOARD, and WM_VSCROLLCLIPBOARD messages. The hMem parameter must be NULL.
Private Const CF_PRIVATEFIRST = &H200   'Start of a range of integer values for private clipboard formats. The range ends with CF_PRIVATELAST. Handles associated with private clipboard formats are not freed automatically; the clipboard owner must free such handles, typically in response to the WM_DESTROYCLIPBOARD message.
Private Const CF_PRIVATELAST = &H2FF    'See CF_PRIVATEFIRST.
Private Const CP_UTF8 As Long = 65001
Public Enum CharsetFlags
    vbUnic = 0 'double-byte
    vbAnsi = 1 'single-byte
    vbUtf8 = 2
End Enum
Public Enum ClearFlags
    ClearClip = True
    NotClearClip = False
End Enum
 
Public Property Get ClipboardFormatsAvailable() 'As Dictionary
    Const maxlen As Long = 50
    Dim FormatNum As Long
    Dim ln As Long
    Dim FormatName As String
    On Error GoTo ErrorHandler
        
    Set ClipboardFormatsAvailable = CreateObject("Scripting.Dictionary")
    OpenClipboard 0
    FormatNum = EnumClipboardFormats(FormatNum)
    While FormatNum <> 0
        FormatName = String(maxlen, vbNullChar)
        ln = GetClipboardFormatNameW(FormatNum, StrPtr(FormatName), maxlen)
        FormatName = Left(FormatName, ln)
        If FormatName = vbNullString Then
            FormatName = BuiltInClipboardFormatName(FormatNum)
        End If
        
        ClipboardFormatsAvailable.Add FormatName, FormatNum
                
        FormatNum = EnumClipboardFormats(FormatNum)
    Wend
    CloseClipboard
    
    Exit Property
ErrorHandler:
    On Error Resume Next
    CloseClipboard
End Property
 
Public Property Get GetText(Format, Optional ByVal Charset As CharsetFlags) As String
#If VBA7 Then
    Dim hMemory As LongPtr
'    Dim iLock As LongPtr
#Else
    Dim hMemory As Long
'    Dim iLock As Long
#End If
    Dim wSize As Long
    Dim FormatName As String
    Dim FormatNumb As Long
    
    Select Case VarType(Format)
    Case vbString
        FormatName = Format
        FormatNumb = BuiltInClipboardFormatNumber(FormatName)
        If FormatNumb = vbEmpty Then
            FormatNumb = GetFormatNumber(FormatName)
            If FormatNumb = 0 Then Exit Property 'формат отсутствует в б/о
        End If
    Case vbInteger To vbDouble
        FormatNumb = Format
        If IsClipboardFormatAvailable(FormatNumb) = APINULL Then Exit Property
    '        Err.Raise vbObjectError + 1, "vbaClipboard", "Requested clipboard format number " & FormatNumb & " Is Not available On the clipboard."
    '    End If
    Case Else: Exit Property                'если формат не строка и не число, завершаем функцию
    End Select
    
    OpenClipboard vbEmpty
    hMemory = GetClipBoardData(FormatNumb)  'получение текст из буфера
    CloseClipboard
    If hMemory = vbEmpty Then Exit Property
'        Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To retrieve data from the Clipboard."
'    End If
    
    wSize = CLng(GlobalSize(hMemory))       'копирование текста в переменную
    If wSize = vbEmpty Then Exit Property
'    iLock = GlobalLock(hMemory)
    GetText = String(wSize / 2, vbNullChar)
    lstrcpyW StrPtr(GetText), hMemory 'iLock
'    GlobalUnlock hMemory
    
    If Charset = vbAnsi Then                'преобразование кодировки (при необходимости)
        GetText = StrConv(GetText, vbUnicode)
    ElseIf Charset = vbUtf8 Then
        GetText = FromUTF8(GetText)
    End If
End Property
 
Public Sub SetText(sText As String, Format, Optional ByVal Charset As CharsetFlags, Optional ByVal ClearFlag As ClearFlags)
#If VBA7 Then
    Dim iStrPtr As LongPtr
    Dim iLock As LongPtr
#Else
    Dim iStrPtr As Long
    Dim iLock As Long
#End If
    Dim iLen As Long
    Dim FormatName As String
    Dim FormatNumber As Long
    
    If ClearFlag Then OpenClipboard 0: EmptyClipboard: CloseClipboard 'опциональная очистка б/о
    
    Select Case VarType(Format)
    Case vbString
        FormatName = Format
        FormatNumber = BuiltInClipboardFormatNumber(FormatName)
        If FormatNumber = 0 Then
            FormatNumber = GetFormatNumber(FormatName) 'если в б/о существует формат, используем его.
            If FormatNumber = 0 Then
                FormatNumber = RegisterClipboardFormatW(StrPtr(FormatName)) 'Nope. Register the format
            End If
        End If
        Select Case FormatName
          Case "HTML Format"
            sText = addHTMLWraper(sText) 'преобразуется в Ansi (1byte) по умолчанию
            iLen = LenB(sText) + 1
            GoTo 1
        End Select
    Case vbInteger To vbDouble
        FormatNumber = Format
    Case Else: Exit Sub               'если тип переменной Format не число и не строка, завершаем процедуру
    End Select
        
    If Charset = vbAnsi Then          '1byte
        sText = StrConv(sText, vbFromUnicode)
    ElseIf Charset = vbUtf8 Then
        sText = ToUTF8(sText)
    End If
    iLen = LenB(sText) + 2
    
1   iStrPtr = GlobalAlloc(GHND, iLen) 'выделение глобального блока памяти и копирование туда текста
    iLock = GlobalLock(iStrPtr)
    lstrcpyW iLock, StrPtr(sText)
    GlobalUnlock iStrPtr
    
    OpenClipboard 0
    SetClipboardData FormatNumber, iStrPtr 'запись в б/о
    GlobalFree iStrPtr                'освобождение памяти
    CloseClipboard
End Sub
 
Public Sub Clear()                    'очистка б/о
    OpenClipboard 0
    EmptyClipboard
    CloseClipboard
End Sub
 
Public Function GetFormatNumber(FormatName As String) As Long
    Const maxlen As Long = 50
    Dim sName As String
    Dim ln As Long
    
    OpenClipboard 0
    GetFormatNumber = EnumClipboardFormats(GetFormatNumber)
    Do While GetFormatNumber '<> 0
        sName = String$(maxlen, vbNullChar)
        ln = GetClipboardFormatNameW(GetFormatNumber, StrPtr(sName), maxlen)
        If ln Then
            sName = Left(sName, ln)
        Else
            sName = BuiltInClipboardFormatName(GetFormatNumber)
        End If
        
        If sName = FormatName Then Exit Do
                
        GetFormatNumber = EnumClipboardFormats(GetFormatNumber)
    Loop
    CloseClipboard
End Function
Private Function BuiltInClipboardFormatNumber(aClipboardFormatName As String) As Long
    Dim result As Long
    Select Case UCase(aClipboardFormatName)
    Case "CF_TEXT": result = 1
    Case "CF_BITMAP": result = 2
    Case "CF_METAFILEPICT": result = 3
    Case "CF_SYLK": result = 4
    Case "CF_DIF": result = 5
    Case "CF_TIFF": result = 6
    Case "CF_OEMTEXT": result = 7
    Case "CF_DIB": result = 8
    Case "CF_PALETTE": result = 9
    Case "CF_PENDATA": result = 10
    Case "CF_RIFF": result = 11
    Case "CF_WAVE": result = 12
    Case "CF_UNICODETEXT": result = 13
    Case "CF_ENHMETAFILE": result = 14
    Case "CF_HDROP": result = 15
    Case "CF_LOCALE": result = 16
    Case "CF_DIBV5": result = 17
    Case "CF_DSPBITMAP": result = &H82
    Case "CF_DSPENHMETAFILE": result = &H8E
    Case "CF_DSPMETAFILEPICT": result = &H83
    Case "CF_DSPTEXT": result = &H81
    Case "CF_GDIOBJFIRST": result = &H300
    Case "CF_GDIOBJLAST": result = &H3FF
    Case "CF_OWNERDISPLAY": result = &H80
    Case "CF_PRIVATEFIRST": result = &H200
    Case "CF_PRIVATELAST": result = &H2FF
    Case Else: result = 0
    End Select
    BuiltInClipboardFormatNumber = result
End Function
Private Function BuiltInClipboardFormatName(ByVal aIndex As Long) As String 'Note: Adding LongPtr this to support 64Bit
    Dim n As String
    Select Case aIndex
    Case 1: n = "CF_TEXT"
    Case 2: n = "CF_BITMAP"
    Case 3: n = "CF_METAFILEPICT"
    Case 4: n = "CF_SYLK"
    Case 5: n = "CF_DIF"
    Case 6: n = "CF_TIFF"
    Case 7: n = "CF_OEMTEXT"
    Case 8: n = "CF_DIB"
    Case 9: n = "CF_PALETTE"
    Case 10: n = "CF_PENDATA"
    Case 11: n = "CF_RIFF"
    Case 12: n = "CF_WAVE"
    Case 13: n = "CF_UNICODETEXT"
    Case 14: n = "CF_ENHMETAFILE"
    Case 15: n = "CF_HDROP"
    Case 16: n = "CF_LOCALE"
    Case 17: n = "CF_DIBV5"
    Case &H82: n = "CF_DSPBITMAP"
    Case &H8E: n = "CF_DSPENHMETAFILE"
    Case &H83: n = "CF_DSPMETAFILEPICT"
    Case &H81: n = "CF_DSPTEXT"
    Case &H300: n = "CF_GDIOBJFIRST"
    Case &H3FF: n = "CF_GDIOBJLAST"
    Case &H80: n = "CF_OWNERDISPLAY"
    Case &H200: n = "CF_PRIVATEFIRST"
    Case &H2FF: n = "CF_PRIVATELAST"
    End Select
    BuiltInClipboardFormatName = n
End Function
Private Function addHTMLWraper(ByVal sHtmlElement As String) As String
    Const sHtmlHeader = "Version:1.0" & vbCrLf & _
            "StartHTML:0000000105" & vbCrLf & _
            "EndHTML:0000000000" & vbCrLf & _
            "StartFragment:0000000138" & vbCrLf & _
            "EndFragment:0000000000" & vbCrLf & _
            "<HTML><BODY><!--StartFragment -->"
    Const sContextEnd = "<!--EndFragment --></BODY></HTML>"
    sHtmlElement = StrConv(ToUTF8(sHtmlElement), vbUnicode)
    addHTMLWraper = sHtmlHeader & sHtmlElement & sContextEnd
    Mid$(addHTMLWraper, 44) = Format(Len(addHTMLWraper), "0000000000")
    Mid$(addHTMLWraper, 94) = Format(138 + Len(sHtmlElement), "0000000000") '138 = Len(sHtmlHeader)
    addHTMLWraper = StrConv(addHTMLWraper, vbFromUnicode) ',vbNarrow??
End Function
 
Private Function TrimNull(ByVal aString As String) As String
    Dim nullAt As Long
    nullAt = InStr(1, aString, vbNullChar)
    If nullAt > 0 Then
        TrimNull = Left(aString, nullAt - 1)
    Else
        TrimNull = aString
    End If
End Function
Private Function ToUTF8(sText As String) As String 'unicode(2byte) to utf8(1byte)
    Dim ln As Long
    ln = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), 0, 0, 0, 0)
    If ln Then
        ToUTF8 = MidB$(String$(ln \ 2 + 1, vbNullChar), 1, ln)
        WideCharToMultiByte CP_UTF8, 0, StrPtr(sText), Len(sText), StrPtr(ToUTF8), ln, 0, 0
    End If
End Function
Public Function FromUTF8(sText As String) As String 'utf8(1byte) to unicode(2byte)
    Dim ln As Long
    ln = MultiByteToWideChar(CP_UTF8, 0, StrPtr(sText), LenB(sText), 0, 0)
    If ln Then
        FromUTF8 = String(ln, vbNullChar)
        MultiByteToWideChar CP_UTF8, 0, StrPtr(sText), LenB(sText), StrPtr(FromUTF8), ln
    End If
End Function

Sub ПримерИспользования()
    Dim myClp As New vbaClipboard, key
    Dim formats 'as Dictionary
    
    'Перечисление всех форматов в б/о
    Set formats = myClp.ClipboardFormatsAvailable
    For Each key In formats
        Debug.Print formats(key), key
    Next
    Stop
    
    'поместить форматированный текст в б/о
    myClp.SetText "Простой текст1", 13, ClearFlag:=True 'помещаем строку в б/о без преобразований
    Stop
    myClp.SetText "Простой текст2", "CF_TEXT", vbAnsi 'c преобразованием в Ansi
    Stop
'    myClp.Clear
    myClp.SetText "<b>Жирный текст</b>, не жирный текст", "HTML Format" 'преобразуется в utf8 по умолчанию
    Stop
    
    MsgBox "Скопируйте какой-нибудь текст в браузере"
    Stop
    'получить текст из б/о
    Debug.Print myClp.GetText(1, vbAnsi)              'получить с преобразованием из Ansi
    Stop
    Debug.Print myClp.GetText("CF_UNICODETEXT")       'без преобразования (из юникода)
    Stop
    Debug.Print myClp.GetText("HTML Format", vbUtf8)  'с преобразованием из Utf8
    Stop
End Sub

Option Explicit
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cbCopy As LongPtr)
Private Type tpVariant
    tp As Integer
    r1 As Integer
    r2 As Integer
    r3 As Integer
    Ptr As LongPtr
    r4 As LongPtr
End Type
#If Win64 Then
    Private Const varSz As LongPtr = 24
    Private Const ptrSz As LongPtr = 8
#Else
    Private Const varSz As Long = 16
    Private Const ptrSz As Long = 4
#End If
Private Const VT_Ref = &H4000
Private vArr
 
Public Sub Add(A)
    Dim vt As Integer
    Dim tVar As tpVariant
    If IsArray(A) = False Then Exit Sub
    
    CopyMemory vt, ByVal VarPtr(A), 2
    If vt > VT_Ref Then
        CopyMemory ByVal VarPtr(vArr), ByVal VarPtr(A), varSz
    Else
        tVar.tp = vt Xor VT_Ref
        tVar.Ptr = VarPtr(A) + 8
        CopyMemory ByVal VarPtr(vArr), tVar, varSz
    End If
End Sub
 
Public Property Get Ar(Optional ByVal ind1& = -1, Optional ByVal ind2& = -1)
'    Attribute Item.VB_UserMemId = 0
    If ind2 > -1 Then
        If ind1 > -1 Then Ar = vArr(ind1, ind2)
    ElseIf ind1 > -1 Then
        Ar = vArr(ind1)
    Else
        CopyMemory ByVal VarPtr(Ar), ByVal VarPtr(vArr), varSz
    End If
End Property
 
Public Property Let Ar(Optional ByVal ind1& = -1, Optional ByVal ind2& = -1, inp)
'    Attribute Item.VB_UserMemId = 0
    If ind2 > -1 Then
        vArr(ind1, ind2) = inp
    ElseIf ind1 > -1 Then
        vArr(ind1) = inp
    End If
End Property
 
Public Function GetCopy()
    GetCopy_ GetCopy, vArr
End Function
Private Sub GetCopy_(Dst, Src)
    Dst = Src
End Sub

Sub Example()
    Dim arr@(), arrRef, arrCopy
    Dim coll As New VBA.Collection
    
    ReDim arr(3): arr(0) = 111: arr(1) = 222: arr(2) = 125
   
    coll.Add New ArrayContainer 'добавляем экземпляр класса в коллекцию
    coll(1).Add arr2            'добавляем массив в "контейнер"
    arrRef = coll(1)            'получаем ссылку на массив из контейнера
    Stop
    arrCopy = coll(1).GetCopy   'получить копию на массив из контейнера
    Stop
    Debug.Print coll(1).Ar()(2) 'получаем значение массива способ 1
    Stop
    Debug.Print coll(1)(2)      'способ 2
    Stop
    ReDim Preserve arrRef(7)    'редимим с испльзованием ссылки
    Stop
    ReDim Preserve coll(1).Ar(5) 'редимим массив в контейнере
    Stop
    coll(1).Ar(3) = 123         'изменяем  значения массива в контейнере
    coll(1)(4) = 321
    Debug.Print coll(1)(3); coll(1)(4)   'проверяем измененное значение
    Stop
End Sub