'Class vbaCleapboard
'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
'optimized by the Tester to support Unicode, Utf8 and etc. 24/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 key, formats(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