Injection de code RTF dans le Presse-papiers à coller dans MS Word en tant que texte RTF via une macro VBA

1
GMCB 2020-09-03 17:33.

Je cherche depuis un moment maintenant et je n'arrive pas à trouver une solution pour faire ce qui suit:

  1. Entrez un code RTF dans le presse-papiers (par exemple {\rtf1\ansi\ansicpg1252 TEST\sub 0\f1\lang1033\_\f2\lang18441 1\nosupersub\par}, qui comprend TEST0-1 dans le format souhaité
  2. Collez le contenu du presse-papiers dans un fichier Word à la sélection sélectionnée.

J'ai essayé ce qui suit:

Sub testpastertf()
    Dim strSelection As String
    
    strSelection = "{\rtf1\ansi\ansicpg1252 TEST\sub 0\f1\lang1033\_\f2\lang18441 1\nosupersub\par}"
    
    Set MyData = New DataObject

    MyData.SetText strSelection
    MyData.PutInClipboard
    
'Test1
    Selection.PasteAndFormat wdFormatOriginalFormatting
    Selection.TypeParagraph
'Test 2
    Selection.PasteAndFormat wdUseDestinationStylesRecovery
    Selection.TypeParagraph
'Test 3
    Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, Placement:= _
        wdInLine, DisplayAsIcon:=False

End Sub

Malheureusement, les deux premiers tests ne fonctionnent pas car le texte n'est collé que sous forme de "texte brut" qui est essentiellement le code RTF et le dernier génère une erreur

J'ai trouvé des sites avec du code qui, je pense, fonctionnerait, mais il me manque quelque chose car je ne parviens pas à faire fonctionner les explications indiquées:

  1. https://support.microsoft.com/en-sg/help/258513/how-to-paste-a-rich-text-format-string-into-word-with-visual-basic-aut (Selon toute vraisemblance, cela ne fonctionne pas car il fournit du code pour une application basée sur VBA)

  2. https://www.tek-tips.com/viewthread.cfm?qid=977792 (fichier manquant "Oopic_5.1.22 / Source / modClipboard.bas" lié dans ce message).

Je présume que ce que je veux faire est possible, mais je ne sais pas comment faire fonctionner cela. Merci d'avance pour l'aide.

2 answers

2
Noname 2020-09-04 00:16.

Personnellement, j'utiliserais probablement le code de Leigh Webber auquel @TimWilliams fait référence , tant que vous incluez également les mises à jour pour VBA7 64 bits fournies par quelqu'un d'autre dans ce fil.

Cependant, je pense que vous pouvez le faire simplement en utilisant DataObject. C'est juste que je n'ai pas testé cela à fond.

Les problèmes sont

une. Word doit voir un type de données appelé «Format de texte enrichi» dans le Presse-papiers. Vous pouvez vous assurer qu'il existe un format avec ce nom en passant le nom à PutInClipBoard

b. Si vous transmettez simplement strSelection à PutInClipBoard, il est en fait dans le mauvais format car les chaînes VBA sont des chaînes Unicode 16 bits. Donc, si vous essayez de coller cela dans WOrd, vous voyez simplement le RTF, plus ou moins avec beaucoup de caractères "_" supplémentaires). Vous pouvez résoudre ce problème en convertissant la chaîne en un tableau d'octets à la place. Cependant, vous devez également vous assurer qu'il est terminé par 0, sinon Word récupérera plus d'éléments du Presse-papiers qu'il ne le devrait.

Vous semblez donc être capable de faire ceci:

Sub testpastertf()
    Dim MyData As DataObject
    Dim i As Long
    Dim str As String
    Dim strSelectionB() As Byte
    
    str = "{\rtf1\ansi\ansicpg1252 TT\sub 0\f1\lang1033\_\f2\lang18441 1\nosupersub\par}"

    ReDim strSelectionB(0 To Len(str)) As Byte
    For i = 1 To Len(str)
      strSelectionB(i - 1) = Asc(Mid(str, i, 1))
    Next
    strSelectionB(Len(str)) = 0
    Set MyData = New DataObject
        
    mydata.SetText strSelectionB, "Rich Text Format"
    mydata.PutInClipboard
    
    ' Or you can just Selection.Paste
    Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, Placement:= _
        wdInLine, DisplayAsIcon:=False
End Sub

Cependant, cela ne fonctionne que parce que le RTF que nous avons utilisé ne contient que des caractères qui occuperaient un octet au format Unicode UTF8. OTTOMH Je ne me souviens pas de ce qu'implique l'utilisation de ansicp1252 en ce qui concerne, mais si vous pouvez avoir des caractères dans votre RTF qui ne peuvent pas être encodés en un seul octet, je pense que votre code devrait en fait faire plus de travail pour traduire 16- caractères de bits dans le tableau d'octets.

[Point supplémentaire des commentaires] Lorsque vous essayez de copier des morceaux HTML, vous devez fournir un en-tête avec quelques décalages - j'aurais bien regardé cet article SO et les documents liés à partir de là).

0
GMCB 2020-09-04 20:32.

Sur la base de la réponse de légèrement sarcastique et de son pointage vers ces messages:

  1. le code de Leigh Webber auquel @TimWilliams fait référence
  2. Texte dans le presse-papiers dans le problème VBA Windows 10

J'ai pu reconstituer une version fonctionnelle du code après quelques modifications.

En bref, voici le contenu des différentes classes et modules pour préparer le code de travail. Cela fonctionne bien pour coller des éléments RTF et HTLM

Le code de test se trouve ci-dessous:

  1. Classe vbaClipboard (vbaClipboard.cls)
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "vbaClipboard"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'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

'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

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPtr
    Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Any, ByVal lpString2 As Any) 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 LongPtr) As LongPtr
    Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As LongPtr, ByVal lpString As String, ByVal nMaxCount As Long) As LongPtr
    Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
#Else
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) 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
    'Note that we do not use the GetClipboardDataA declaration
    'Public Declare Function GetClipboardData Lib "user32" Alias "GetClipboardDataA" (ByVal wFormat As Long) As Long
    Private Declare Function GetClipBoardData Lib "user32" Alias "GetClipboardData" (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
    'NOTE: the lstrCpy declaration you get from the VB6 API Viewer is WRONG. It's version is this:
    'Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
    'the code from this thread, use:
    'Private Declare Function lstrCpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    'Replacing with that used in https://stackoverflow.com/questions/35416662/text-to-clipboard-in-vba-windows-10-issue
    Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Any, ByVal lpString2 As Any) 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 GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem 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.

Public Property Get ClipboardFormatsAvailable() As Collection

    On Error GoTo ErrorHandler
    #If VBA7 Then 'Note: Adding this to support 64Bit
        Dim thisClipboardFormat As LongPtr
        Dim returnStringLength As LongPtr
    #Else
        Dim thisClipboardFormat As Long
        Dim returnStringLength As Long
    #End If

    Dim myCFAvailable As New Collection
    Dim clipBoardFormatName As String
    Dim clipboardFormat As clipboardFormat
    Dim success As Boolean
    
    success = OpenClipboard(0)
    If success Then
        thisClipboardFormat = 0
        thisClipboardFormat = EnumClipboardFormats(thisClipboardFormat)
        While thisClipboardFormat <> 0
            Set clipboardFormat = New clipboardFormat
            clipBoardFormatName = String$(NAME_MAX_LENGTH, vbNullChar) returnStringLength = GetClipboardFormatName(thisClipboardFormat, _ clipBoardFormatName, Len(clipBoardFormatName)) clipBoardFormatName = TrimNull(clipBoardFormatName) If clipBoardFormatName = "" Then clipBoardFormatName = BuiltInClipboardFormatName(CLngPtr(thisClipboardFormat)) 'Adding CLng() to suport 64Bit End If clipboardFormat.Name = clipBoardFormatName clipboardFormat.Number = CLng(thisClipboardFormat) 'Adding CLng() to suport 64Bit myCFAvailable.Add clipboardFormat, clipboardFormat.Name thisClipboardFormat = EnumClipboardFormats(thisClipboardFormat) Wend Set ClipboardFormatsAvailable = myCFAvailable CloseClipboard Else Set ClipboardFormatsAvailable = Nothing End If Exit Property ErrorHandler: On Error Resume Next CloseClipboard End Property Public Function GetClipboardText(ByVal aClipboardFormatNumber As Long) As String 'Do not handle errors - let them bubble up #If VBA7 Then Dim lpMemory As LongPtr Dim hMemory As LongPtr #Else Dim lpMemory As Long Dim hMemory As Long #End If Dim wLen As Integer Dim RetVal As Variant Dim haveMemoryLocked As Boolean Dim wClipAvail As Integer Dim szText As String Dim wSize As Long Dim clipBoardText As String clipBoardText = "" 'Before accessing the clipboard, find out if the requested format is available If IsClipboardFormatAvailable(aClipboardFormatNumber) = APINULL Then Err.Raise vbObjectError + 1, "vbaClipboard", "Requested clipboard format number " & aClipboardFormatNumber & " Is Not available On the clipboard." Exit Function End If Dim success As Boolean success = OpenClipboard(0) If success Then 'Get a handle to a memory structure containing the clipboard data in the requested format hMemory = GetClipboardData(aClipboardFormatNumber) CloseClipboard 'If the handle is null, something went wrong If hMemory = APINULL Then 'Throw an error Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To retrieve data from the Clipboard." End If 'The handle is good. How much data came back wSize = GlobalSize(hMemory) 'Fill our destination string with nulls clipBoardText = Space(wSize) 'Lock the memory 'Get a pointer to the locked memory area lpMemory = GlobalLock(hMemory) If lpMemory = APINULL Then 'CloseClipboard Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To lock clipboard memory." End If ' Copy the locked memory into our string RetVal = lstrcpy(clipBoardText, lpMemory) 'Unlock memory GlobalUnlock hMemory ' Get rid of trailing stuff. clipBoardText = Trim(clipBoardText) GetClipboardText = TrimNull(clipBoardText) Else Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To open Clipboard. Perhaps some other application Is using it." End If End Function Public Sub SetClipboardText(ByVal aText As String, ByVal aClipboardFormatName As String) #If VBA7 Then Dim lpMemory As LongPtr Dim hMemory As LongPtr #Else Dim lpMemory As Long Dim hMemory As Long #End If Dim wLen As Long 'Changing from Integer to Long as geting Overflow error Dim RetVal As Variant Dim memoryIsLocked As Boolean Dim memoryIsAllocated As Boolean Dim clipBoardIsOpen As Boolean memoryIsAllocated = False memoryIsLocked = False clipBoardIsOpen = False On Error GoTo ErrorHandler Select Case aClipboardFormatName Case "HTML Format" aText = addHTMLWraper(aText) End Select ' Get the length, including one extra for a CHR$(0) at the end.
    wLen = Len(aText) + 1
    'Add a null to the end
    aText = aText & Chr$(0)
    'Allocate some memory
    hMemory = GlobalAlloc(GHND, wLen + 1)
    If hMemory = APINULL Then
        Err.Raise vbObjectError + 1001, "vbaClipboard", "Unable To allocate memory."
    Else
        memoryIsAllocated = True
    End If
    lpMemory = GlobalLock(hMemory)
    If lpMemory = APINULL Then
        'Throw an error
        Err.Raise vbObjectError + 1001, "vbaClipboard", "Unable To lock memory."
    Else
        memoryIsLocked = True
    End If
    ' Copy our string into the locked memory.
    RetVal = lstrcpy(lpMemory, aText)
    ' Don't send clipboard locked memory.
    RetVal = GlobalUnlock(hMemory)
    'If the preceding throws an error, it will be handled in ErrorHandler
    memoryIsLocked = True
    If OpenClipboard(0&) = APINULL Then
        Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To open Clipboard. Perhaps some other application Is using it."
    Else
        clipBoardIsOpen = True
    End If
    'Is the requested format one of the Windows built-in formats
    Dim i As Integer
    Dim thisClipboardFormatNumber As Long
    thisClipboardFormatNumber = BuiltInClipboardFormatNumber(aClipboardFormatName)
    If thisClipboardFormatNumber = 0 Then
        'Nope. Register the format
        On Error Resume Next
        thisClipboardFormatNumber = CLng(RegisterClipboardFormat(aClipboardFormatName)) 'Note: Adding this to support 64Bit
        If Err.Number <> 0 Then
            Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To register clipboard format: " & aClipboardFormatName & _
            ". Error message: " & Err.description
        End If
        On Error GoTo ErrorHandler
        If thisClipboardFormatNumber = 0 Then
            Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To register clipboard format: " & aClipboardFormatName
        End If
    End If
    'Empty the clipboard
    If EmptyClipboard() = APINULL Then
        Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To Empty the clipboard."
    End If
    If SetClipboardData(thisClipboardFormatNumber, hMemory) = APINULL Then
        Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To Set the clipboard data."
    End If
    CloseClipboard
    GlobalFree hMemory
    Exit Sub
ErrorHandler:
    Dim description As String
    description = Err.description
    On Error Resume Next
    If memoryIsLocked Then GlobalUnlock hMemory
    If memoryIsAllocated Then GlobalFree hMemory
    If clipBoardIsOpen Then CloseClipboard
    On Error GoTo 0
    Err.Raise vbObjectError + 1, "vbaClipboard", description
End Sub

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 BuiltInClipboardFormatNumber(ByVal 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 LongPtr) 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
    Dim sData As String
    Const sContextStart = "<HTML><BODY><!--StartFragment -->"
    Const sContextEnd = "<!--EndFragment --></BODY></HTML>"
    Const sHtmlHeader = _
            "Version:1.0" & vbCrLf & _
            "StartHTML:<{]aaaaaaa" & vbCrLf & _
            "EndHTML:<{]bbbbbbb" & vbCrLf & _
            "StartFragment:<{]ccccccc" & vbCrLf & _
            "EndFragment:<{]dddddddd" + vbCrLf
    sData = sHtmlHeader & sContextStart & sHtmlElement & sContextEnd
    sData = Replace(sData, "<{]aaaaaaa", Format(Len(sHtmlHeader), "0000000000"))
    sData = Replace(sData, "<{]bbbbbbb", Format(Len(sData), "0000000000"))
    sData = Replace(sData, "<{]ccccccc", Format(Len(sHtmlHeader & sContextStart), "0000000000"))
    sData = Replace(sData, "<{]ddddddd", Format(Len(sHtmlHeader & sContextStart & sHtmlElement), "0000000000"))
    addHTMLWraper = sData
End Function
  1. Code pour la classe ClipboardFormat (ClipboardFormat.cls)
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ClipboardFormat"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private mNumber As Long
Private mName As String

Public Property Get Number() As Long
    Number = mNumber
End Property
Public Property Let Number(ByVal value As Long)
    mNumber = value
End Property

Public Property Get Name() As String
    Name = mName
End Property
Public Property Let Name(ByVal value As String)
    mName = value
End Property
  1. Code du module de test
Option Explicit
Sub test()
    'This routine tests the vbaClipboard object.
    'Before running this, copy some text from Word. This will place Rich Text Format data
    'on the clipboard. The test will preserve the RTF data, then use the clipboard
    'to manipulate some plain text ("CF_TEXT"). Finally, the test will put the
    'RTF data back on the clipboard. When the test is finished, you should be able
    'to go back into Word and hit Ctrl+V and paste your original copied text (with formatting).
    
    'Instantiate a vbaClipboard object
    Dim myClipboard As New vbaClipboard
    
    'The ClipboardFormat class encapsulates a clipboard format number and a name
    Dim clipboardFormat As clipboardFormat
    
    'Handle errors below
    On Error GoTo ErrorHandler
    
    'Show the currently available formats
    'The ClipboardFormatsAvailable property returns a collection of ClipboardFormat objects
    'representing all formats currently available on the clipboard.
    
    Debug.Print "===================================================================="
    
    For Each clipboardFormat In myClipboard.ClipboardFormatsAvailable
        Debug.Print clipboardFormat.Number, clipboardFormat.Name
    Next clipboardFormat
    
    'Preserve the RTF currently on the clipboard (you did copy some, right?)
    Dim oldRTF As String
    'Get the format number value for Rich Text Format
    Dim richTextFormatNumber As Long
    On Error Resume Next
    richTextFormatNumber = myClipboard.ClipboardFormatsAvailable("Rich Text Format").Number
    If Err.Number <> 0 Then
        On Error GoTo ErrorHandler
        Err.Raise vbObjectError + 1, , "The clipboard does Not have any Rich Text Format data."
    End If
    On Error GoTo ErrorHandler
    
    'Get the RTF data from the clipboard
    oldRTF = myClipboard.GetClipboardText(richTextFormatNumber)
    'Debug.Print oldRTF
    
    'Use the clipboard for something else
    Dim s As String
    s = "Hello, world!"
    myClipboard.SetClipboardText s, "CF_TEXT"
    
    'Get it back again
    Debug.Print myClipboard.GetClipboardText(1)
    
    'Show the currently available formats
    Debug.Print "===================================================================="
    For Each clipboardFormat In myClipboard.ClipboardFormatsAvailable
        Debug.Print clipboardFormat.Number, clipboardFormat.Name
    Next clipboardFormat
    
    'Now put back the RTF
    myClipboard.SetClipboardText oldRTF, "Rich Text Format"
    
    'Show the currently available formats
    Debug.Print "===================================================================="
    For Each clipboardFormat In myClipboard.ClipboardFormatsAvailable
        Debug.Print clipboardFormat.Number, clipboardFormat.Name
    Next clipboardFormat
    'You can now paste back into Word, and you'll get whatever text you selected
    Exit Sub
ErrorHandler:
    MsgBox Err.description
End Sub
Sub test2()
    'This tests stuffs some formatted text (RTF) onto the clipboard. Run the test, then
    'go into word and hit Ctrl+V to paste it in.
    Dim myClipboard As New vbaClipboard
    Dim text As String
    text = "{\rtf1\ansi\ansicpg1252\deff0\deftab720{\fonttbl" & _
           "{\f0\fswiss MS Sans Serif;}{\f1\froman\fcharset2 Symbol;}" & _
           "{\f2\froman\fprq2 Times New Roman;}}" & _
           "{\colortbl\red0\green0\blue0;\red255\green0\blue0;}" & _
           "\deflang1033\horzdoc{\*\fchars }{\*\lchars }" & _
           "\pard\plain\f2\fs24 This Is some \plain\f2\fs24\cf1" & _
           "formatted\plain\f2\fs24  text. }"
    
    myClipboard.SetClipboardText text, "Rich Text Format"
    Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, Placement:= _
        wdInLine, DisplayAsIcon:=False
    Selection.TypeParagraph

    'Testing with HTML
    text = "<i>" & text & "</i>"
    myClipboard.SetClipboardText text, "HTML Format"
    Selection.PasteSpecial Link:=False, DataType:=wdPasteHTML, Placement:= _
        wdInLine, DisplayAsIcon:=False
End Sub

Related questions

MORE COOL STUFF

Reba McEntire a révélé la tradition de Noël «amusante» qu'elle partage avec son fils Shelby Blackstock: «Nous rions beaucoup»

Reba McEntire a révélé la tradition de Noël «amusante» qu'elle partage avec son fils Shelby Blackstock: «Nous rions beaucoup»

Découvrez les traditions de Noël que Reba McEntire partage avec son fils, Shelby Blackstock, qui, selon elle, pourraient laisser certains confus.

Meghan Markle s'est liée avec Mariah Carey pour coiffer leurs cheveux naturels

Meghan Markle s'est liée avec Mariah Carey pour coiffer leurs cheveux naturels

Apprenez-en plus sur la façon dont Meghan Markle et Mariah Carey se sont liées sur leurs cheveux naturels dans un épisode du podcast "Archetypes" de Meghan.

Le prince Harry " garde espoir " de pouvoir arranger les choses avec sa famille : " Il aime son père et son frère "

Le prince Harry " garde espoir " de pouvoir arranger les choses avec sa famille : " Il aime son père et son frère "

Découvrez ce qu'une source a affirmé que le prince Harry espérait concernant les relations avec sa famille, en particulier le roi Charles et le prince William.

Brennon Lemieux, star de "Love Is Blind", répond aux accusations de violence conjugale

Brennon Lemieux, star de "Love Is Blind", répond aux accusations de violence conjugale

Un rapport de police accusant Brennon, star de "Love Is Blind", de violence domestique a récemment fait surface. Maintenant, Brennon a répondu aux réclamations.

Qui a dit ça? Le quiz des doubleurs

Qui a dit ça? Le quiz des doubleurs

Il y a le jeu d'acteur, puis il y a le doublage. Les deux sont difficiles à leur manière. Que savez-vous de ces légendes dans le domaine ?

Les Philippines organisent la plus longue fête de Noël au monde

Les Philippines organisent la plus longue fête de Noël au monde

Peut-être qu'aucun pays sur Terre n'aime Noël plus que les Philippines. Les résidents y célèbrent les vacances pendant quatre mois solides. Voici pourquoi.

L'intrication quantique est le phénomène le plus étrange de la physique, mais qu'est-ce que c'est ?

L'intrication quantique est le phénomène le plus étrange de la physique, mais qu'est-ce que c'est&nbsp;?

Einstein a qualifié ce phénomène d'"action effrayante à distance" et les physiciens viennent de remporter le prix Nobel pour leurs travaux, mais qu'est-ce que l'intrication quantique ?

The Secrets of Airline Travel Quiz

The Secrets of Airline Travel Quiz

Air travel is far more than getting from point A to point B safely. How much do you know about the million little details that go into flying on airplanes?

Un juge blanc condamné à la probation pour fraude électorale dans le même comté où une femme noire a reçu 5 ans

Un juge blanc condamné à la probation pour fraude électorale dans le même comté où une femme noire a reçu 5 ans

Russ Casey En ce moment, il y a une femme noire assise en prison, lisant l'histoire d'un juge texan qui a été reconnu coupable du même crime qu'elle a commis. Elle a probablement remarqué que le juge avait été condamné à cinq ans de probation dans le même comté qui l'avait condamnée à cinq ans de prison.

Meh Car Monday: voici le vide tranquille de la Toyota Avalon

Meh Car Monday: voici le vide tranquille de la Toyota Avalon

Normalement, les voitures que je choisis pour Meh Car Monday n'ont jamais été conçues à l'origine pour être meh, en tant que telles. Mehness leur est juste arrivé.

Mettez un couvercle dessus. En fait, mettez un couvercle sur tout. Obtenez 12 couvercles de cuisine extensibles en silicone pour 14 $. [Exclusif]

Mettez un couvercle dessus. En fait, mettez un couvercle sur tout. Obtenez 12 couvercles de cuisine extensibles en silicone pour 14 $. [Exclusif]

Lot de 12 couvercles extensibles en silicone Tomorrow's Kitchen | 14 $ | Amazone | Code promo 20OFFKINJALids sont essentiellement les chaussettes de la cuisine ; se perd toujours, laissant des conteneurs orphelins qui ne pourront plus jamais être refermés. Mais que se passerait-il si vos couvercles pouvaient s'étirer et s'adapter à tous vos restes de récipients, casseroles, poêles et même de gros fruits tranchés ? Vous n'aurez plus jamais à vous soucier de perdre ce couvercle très spécifique.

Dites-nous vos meilleurs hacks à Washington, DC

Dites-nous vos meilleurs hacks à Washington, DC

Nous avons piraté quelques villes industrielles dans cette colonne, comme Los Angeles et Las Vegas. Il est maintenant temps pour une ville complexe militaro-industrielle.

Le patinage artistique américain "frustré" par l'absence de décision finale dans l'épreuve par équipe, demande une décision équitable

Le patinage artistique américain "frustré" par l'absence de décision finale dans l'épreuve par équipe, demande une décision équitable

L'équipe attend les médailles qu'elle a remportées aux Jeux olympiques d'hiver de 2022 à Pékin, alors qu'un cas de dopage impliquant la patineuse artistique russe Kamila Valieva est en cours de règlement.

Les acheteurs d'Amazon disent qu'ils dorment «comme un bébé choyé» grâce à ces taies d'oreiller en soie qui coûtent aussi peu que 10 $

Les acheteurs d'Amazon disent qu'ils dorment «comme un bébé choyé» grâce à ces taies d'oreiller en soie qui coûtent aussi peu que 10 $

Des milliers d'acheteurs Amazon recommandent la taie d'oreiller en soie Mulberry, et elle est en vente en ce moment. La taie d'oreiller en soie est disponible en plusieurs couleurs et aide à garder les cheveux doux et la peau claire. Achetez les taies d'oreiller en soie alors qu'elles sont jusqu'à 46% de réduction sur Amazon

Un professeur de l'Université Purdue arrêté pour avoir prétendument vendu de la méthamphétamine et proposé des femmes pour des faveurs sexuelles

Un professeur de l'Université Purdue arrêté pour avoir prétendument vendu de la méthamphétamine et proposé des femmes pour des faveurs sexuelles

Le département de police de Lafayette a commencé à enquêter sur un professeur de l'Université Purdue en décembre après avoir reçu plusieurs plaintes concernant un "homme suspect s'approchant de femmes".

Concept Drift : le monde change trop vite pour l'IA

Concept Drift : le monde change trop vite pour l'IA

Tout comme le monde qui nous entoure, la langue est en constante évolution. Alors que dans les époques précédentes, les changements de langue se produisaient sur des années, voire des décennies, cela peut maintenant se produire en quelques jours, voire quelques heures.

L'Inde me botte le cul

L'Inde me botte le cul

Je suis de retour pour la première fois en six ans. Je ne peux pas vous dire depuis combien de temps j'attends ça.

Precios accesibles, nuestro aprendizaje desde la perspectiva iOS

Precios accesibles, nuestro aprendizaje desde la perspectiva iOS

Cómo mejoramos la accesibilidad de nuestro componente de precio, y cómo nos marcó el camino hacia nuevos saberes para nuestro sistema de diseño. Por Ana Calderon y Laura Sarmiento Leer esta historia en inglés.

ℝ

“And a river went out of Eden to water the garden, and from thence it was parted and became into four heads” Genesis 2:10. ? The heart is located in the middle of the thoracic cavity, pointing eastward.

Language