在剪贴板中注入 RTF 代码以通过 VBA 宏粘贴到 MS Word 作为 RTF 文本
Injecting RTF code in the Clipboard to paste into MS Word as RTF text via a VBA macro
我已经找了一段时间了，但似乎无法找到执行以下操作的解决方案：
- 在剪贴板中输入一些 RTF 代码（例如
{\rtf1\ansi\ansicpg1252 TEST\sub 0\f1\lang1033\_\f2\lang18441 1\nosupersub\par}，其中包括所需格式的 TEST0-1
- 将剪贴板内容粘贴到word文件中选中的位置。
我试过以下方法：
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
不幸的是，前两个测试不起作用，因为文本仅粘贴为“纯文本”，本质上是 RTF 代码，最后一个会引发错误
我找到了一些我认为可以使用的代码的网站，但我一定是遗漏了一些东西，因为我无法得到显示有效的解释：
https://support.microsoft.com/en-sg/help/258513/how-to-paste-a-rich-text-format-string-into-word-with-visual-basic-aut（这很可能不起作用，因为它为基于 VBA 的应用程序提供了代码）
https://www.tek-tips.com/viewthread.cfm?qid=977792（缺少链接在 post 中的文件“Oopic_5.1.22/Source/modClipboard.bas”）。
我想我想做的是可能的，但我不知道如何实现。在此先感谢您的帮助。
就个人而言，我可能会使用 the code by Leigh Webber that @TimWilliams references，只要您还在该线程中包含其他人提供的 64 位 VBA7 更新。
不过，我相信您只需使用 DataObject 就可以做到这一点。只是我没有彻底测试过。
问题是
一个。 Word 需要在剪贴板中看到一种名为“Rich Text Format”的数据类型。您可以通过将名称传递给 PutInClipBoard
来确保存在具有该名称的格式
b。如果只是把strSelection传给PutInClipBoard，其实是格式错误，因为VBA字符串是16位的Unicode字符串。因此，如果您尝试将其粘贴到 WOrd 中，您只会看到 RTF，其中或多或少带有许多额外的“_”字符）。您可以通过将字符串转换为 Byte 数组来解决这个问题。但是，您还需要确保它以 0 结尾，否则 Word 将从剪贴板中检索的内容超出应有的范围。
所以你似乎可以做到这一点：
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
但是，这只是因为我们使用的 RTF 仅包含在 Unicode UTF8 格式中占用一个字节的字符。 OTTOMH 就此而言，我不记得使用 ansicp1252 意味着什么，但是如果你的 RTF 中有不能编码为单个字节的字符，我认为你的代码实际上需要做更多的工作来翻译 16-位字符到字节数组中。
[来自评论的附加点] 当试图复制 HTML 块时，你必须提供一个带有一些偏移量的 header - 我会好好看看 this SO article 和从那里链接的文档）。
根据 slightly snarky 的回答以及他向我指出的这个帖子：
经过几次修改后，我能够拼凑出代码的工作版本。
简而言之，这里是为不同的类和模块准备工作代码的内容。 这适用于粘贴 RTF 和 HTLM 元素
测试代码如下：
- Class 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
'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
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
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
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
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
- Class 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
- 测试模块代码
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
我已经找了一段时间了，但似乎无法找到执行以下操作的解决方案：
- 在剪贴板中输入一些 RTF 代码（例如
{\rtf1\ansi\ansicpg1252 TEST\sub 0\f1\lang1033\_\f2\lang18441 1\nosupersub\par}，其中包括所需格式的 TEST0-1 - 将剪贴板内容粘贴到word文件中选中的位置。
我试过以下方法：
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
不幸的是，前两个测试不起作用，因为文本仅粘贴为“纯文本”，本质上是 RTF 代码，最后一个会引发错误
我找到了一些我认为可以使用的代码的网站，但我一定是遗漏了一些东西，因为我无法得到显示有效的解释：
https://support.microsoft.com/en-sg/help/258513/how-to-paste-a-rich-text-format-string-into-word-with-visual-basic-aut（这很可能不起作用，因为它为基于 VBA 的应用程序提供了代码）
https://www.tek-tips.com/viewthread.cfm?qid=977792（缺少链接在 post 中的文件“Oopic_5.1.22/Source/modClipboard.bas”）。
我想我想做的是可能的，但我不知道如何实现。在此先感谢您的帮助。
就个人而言，我可能会使用 the code by Leigh Webber that @TimWilliams references，只要您还在该线程中包含其他人提供的 64 位 VBA7 更新。
不过，我相信您只需使用 DataObject 就可以做到这一点。只是我没有彻底测试过。
问题是
一个。 Word 需要在剪贴板中看到一种名为“Rich Text Format”的数据类型。您可以通过将名称传递给 PutInClipBoard
来确保存在具有该名称的格式b。如果只是把strSelection传给PutInClipBoard，其实是格式错误，因为VBA字符串是16位的Unicode字符串。因此，如果您尝试将其粘贴到 WOrd 中，您只会看到 RTF，其中或多或少带有许多额外的“_”字符）。您可以通过将字符串转换为 Byte 数组来解决这个问题。但是，您还需要确保它以 0 结尾，否则 Word 将从剪贴板中检索的内容超出应有的范围。
所以你似乎可以做到这一点：
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
但是，这只是因为我们使用的 RTF 仅包含在 Unicode UTF8 格式中占用一个字节的字符。 OTTOMH 就此而言，我不记得使用 ansicp1252 意味着什么，但是如果你的 RTF 中有不能编码为单个字节的字符，我认为你的代码实际上需要做更多的工作来翻译 16-位字符到字节数组中。
[来自评论的附加点] 当试图复制 HTML 块时，你必须提供一个带有一些偏移量的 header - 我会好好看看 this SO article 和从那里链接的文档）。
根据 slightly snarky 的回答以及他向我指出的这个帖子：
经过几次修改后，我能够拼凑出代码的工作版本。
简而言之，这里是为不同的类和模块准备工作代码的内容。 这适用于粘贴 RTF 和 HTLM 元素
测试代码如下：
- Class 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
'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
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
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
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
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
- Class 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
- 测试模块代码
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