ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > E文精选 > Excel VBA > #第1期专题#如何运用VBA调用WINDOWS剪贴板

#第1期专题#如何运用VBA调用WINDOWS剪贴板

作者：绿色风 分类： 时间：2022-08-17 浏览：510
楼主
xmyjk		 一、        何为WINDOWS剪贴板

    剪贴板是内存中的一块连续可变的区域，使得在各种应用程序之间，实现数据交换和共享信息。在WINDOWS的运行窗口，键入clipbrd，可以弹出官方的“剪贴簿查看程序”，实现对剪贴板内数据的监控。如下图：


 

    它的工作原理和流程，用通俗的语言举例，例如我们在IE中复制了网页中我们喜欢的一张图片，那描述这张图片的数据，将存放在剪贴板所在的特定内存区域中。一旦，我们在WORD中黏贴了这张图片，其实是WORD这个应用程序，访问了剪贴板，读取了这张图片的数据，然后乾坤大挪移到我们的WORD文档中进行储存。因为都是在内存中操作，所以速度非常快。
2楼
xmyjk		 二、WINDOWS剪贴板的数据格式

      既然：剪贴板是用于多个应用程序之间交换数据的，那存放在剪贴板的数据，是怎样的呢？

      ◆首先，由于存放在全局内存中，他们是公开的，应用程序们可以访问到的，并能交换所需的数据的。

      ◆其次，既然是公共的数据，那这些数据是有规范标准，是系统/用户已经预先设定格式，可以在不同的应用程序中进行交换。
         例如我在网页复制了一段文字，既可以黏贴到记事本，也可黏贴到WORD。这说明了，这些数据是具有某些标准格式的，符合系统或程序间的设定的格式的。

       ◆进而，应用程序们都可以访问这些数据，那么，这些数据就必然是多元的。这就类似我们EXCEL的选择性黏贴。我们复制了单元格的一个公式，可以相对的黏贴这个公式，也可以仅黏贴值，还可以黏贴成图片。
          这说明了，剪贴板中是可以同时存放多种格式的数据。我们移交给剪贴板的某个数据或消息，将在剪贴板内，自动以尽可能多种的以预设过数据格式进行呈现（取决于发起复制或剪贴的应用程序，不同应用程序不同上下文环境，处理数据格式范围不同，放进剪贴板数据格式类别也不同）。微软建议，当向剪贴板中放入数据时，首先放入最能描述所要传递的信息的数据，因为它所包含的信息最接近原始数据所要表达的信息。当从剪贴板中读取数据时，将按顺序枚举所有的数据格式，如果该数据格式在目标应用程序可用，则进行黏贴，否则继续枚举，直至有可用数据。
         即使上传的数据结构自身就非常简单，就例如记事本的文本，剪贴板也能按照一些标准的预设格式，在内存中自动转换，生成多个剪贴板数据格式，以便多种程序的交换。就例如，我们仅仅在记事本复制了一小段文字，剪贴板也能按照如下几个格式，自动进行多样化存放。如下图：

 
         翻阅了下资料，有四类数据，剪贴板是自带转化功能的（剪贴板格式名称请参与下面的介绍）：
      （1）CF_TEXT、CF_UNICODETEXT与CF_OEMTEXT这三个文本格式相互之间；
      （2）CF_METAFILEPICT和CF_ENHMETAFILE这两个图元文件相互之间；
      （3）CF_BITMAP、CF_DIB与CF_DIBV5这三个位图数据格式相互之间；
      （4）如果CF_DIB与CF_DIBV5的数据格式，将自动转化CF_PALETTE的数据格式，这个是单向的，反之不成立。
   
        总之，剪贴板的数据是以多种数据格式进行呈现的。

        ◆最后，这些数据格式，是能被检索查询的，如果新的应用程序，需要新的数据格式，也可以使用API的RegisterClipboardFormat函数进行注册。这些已经预设或者注册过的，剪贴板存放过的数据格式，WINDOWS都会用一个长整形的编号，像字典一样，进行记录。通过这个编号，我们可以获取对应格式的数据。
对于WINDOWS系统初始的标准格式，这个编号是固定的，如下图：

 
        
        如果是非系统标准格式的，允许运用RegisterClipboardFormat函数，用数据格式的名称，去注册这个格式，如果注册成功，将得到新的剪贴板数据格式对应的编号。如果重名，将直接返回已有这个数据格式名称对应的格式编号。
3楼
xmyjk		 三、获取剪贴板数据的套路和主要API的剪贴板函数简介

    一般而言，获取剪贴板数据的大致步骤如下（按需增减）：
   
    （一）用OpenClipboard打开剪贴板
  1. Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
参数hwnd：用来传递目前打开剪贴板的窗口的句柄。如果它修改了剪贴板内的数据，它就会成为剪贴板数据拥有窗口即ClipboardOwner，这样其他程序可以使用GetClipboardOwner去获取它。如果只是读取剪贴板内的数据，可以传递一个0&；如果要向剪贴板内写入数据，则必须指定有效的hwnd，否则不能成功调用SetClipboardData函数；
      
      如果调用成功，将返回剪贴板的句柄。失败返回0。

     （二）EnumClipboardFormats加while来循环出一个可用的剪贴板格式
  1. Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
参数：wFormat表示剪贴板内已知可用的标准剪贴板格式或注册剪贴板格式的编号。在枚举的最开始，向函数传入0值，将返回第一个可用的剪贴板格式编号，将该返回值传给下一次函数调用，将得到下一个可用的剪贴板格式编号。以此循环，直至  返回0，可以枚举所有的可用的数据格式。

      或用IsClipboardFormatAvailable或GetPriorityClipboardFormat判断可用格式的存在
  1. Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
参数：wFormat标准剪贴板格式或注册剪贴板格式的编号
      如果剪贴板中存在相应格式的数据，则返回一个非0值否则返回0。
      如果一个应用程序可以处理多种数据格式，运行传入数组的API函数：
  1. Declare Function GetPriorityClipboardFormat Lib "user32" (lpPriorityList As Long, ByVal nCount As Long) As Long
参数：lpPriorityList指向数组第一个元素的地址，这个数组中需按优先级别存放多个剪贴板格式编号；nCount表示数组内元素的个数；
      如果剪贴板内存在一种或多种数组中列出的格式，则返回优先级别靠前的剪贴板格式编号；如果剪贴板内有数据但不包含数组中列出的任何一种格式，则返回-1；如果剪贴板为空，则返回0。
  1. Dim arrf()
  2. Dim f As Long
  3. arrf = Array(49290, 49386, 1)
  4. f = GetPriorityClipboardFormat(arrf(0), 3)
（三）使用GetClipboardData获得剪贴板的内存块首地址
  1. Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
参数：wFormat表示将要取出的数据格式的编号；
      如果成功，返回剪贴板中以指定格式存放的数据对象的句柄；失败，返回0；
      
     一般而言，返回的内存对象的句柄，但是如果数据是一个图像格式，返回的将是一个GDI对象的句柄，例如，位图格式的返回位图GDI对象句柄，图元文件返回的是图元文件对象的句柄等。GDI对象另贴再解析。先按返回内存对象的句柄进行后续讲解。

      （四）用GlobalLock锁定剪贴板那内存块
  1. Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
参数hMem是内存对象的句柄；
      成功，返回值是内存对象所占用内存的第一个字节的内存地址；失败，返回0

     （五）GlobalSize可以用来获取该内存块的大小
  1. Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
参数hMem是内存对象的句柄；
      成功，返回是内存对象所占用内存的字节长度，失败返回值0

      （六）用CopyMemory将二进制数据取出来并赋值给字节数组
  1. Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
参数：Destination是要赋值的数组第一个元素的内存地址；Source是来源的第一个字节的内存地址；Length是要复制的数据的长度；

     （七）处理数据，转换数据格式等等
       呵呵，这个就按需处理了。文本的，转换成文本数据，图片的，转换成图片，二进制的转换16进制翻译，等等

      （八）使用GlobalUnlock解除锁定
  1. Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
参数hMem是内存对象的句柄；
      被解锁，则返回0

      （九）CloseClipboard关闭剪贴板
  1. Declare Function CloseClipboard Lib "user32"() As Long
成功，返回一个非0值；失败返回0

      有了上述的套路，我们就可以随意的读取剪贴板的相应数据了。
4楼
xmyjk		 简易剪贴板查看程序.zip

查看程序码源：
  1. Option Explicit

  3. Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
  4. Private Declare Function CloseClipboard Lib "user32" () As Long
  5. Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
  6. Private Declare Function EmptyClipboard Lib "user32" () As Long
  7. Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
  8. Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long

  10. Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  11. Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  12. Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
  13. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

  15. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  16. Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
  17. Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

  19. Private Type GUID
  20.     Data1 As Long
  21.     Data2 As Integer
  22.     Data3 As Integer
  23.     Data4(0 To 7) As Byte
  24. End Type
  25. Private Type uPicDesc
  26.     Size As Long
  27. Type As Long
  28.     hPic As Long
  29.     hPal As Long
  30. End Type

  32. Private Sub CommandButton1_Click()
  33.     ListBox1.Clear
  34.     TextBox1.Value = ""
  35.     Set Image1.Picture = Nothing
  36.     TextBox1.Visible = True
  37.     Image1.Visible = False
  38.     listclpformate
  39. End Sub

  41. Private Sub ListBox1_Click()
  42.     TextBox1.Visible = False
  43.     Image1.Visible = False
  44.     Dim hMem As Long, ClpData As Long, ClpSize As Long, byt() As Byte, clptext As String, fv As Long, hp As Long, f As Long
  45.     If ListBox1.ListIndex <> 0 Then
  46.         fv = ListBox1.List(ListBox1.ListIndex)
  47.         OpenClipboard 0&
  48.         Select Case fv
  49.         Case 1, 7, 13
  50.             hMem = GetClipboardData(1)
  51.             If hMem <> 0 Then
  52.                 ClpData = GlobalLock(hMem)
  53.                 ClpSize = GlobalSize(hMem)
  54.                 If ClpData <> 0 And ClpSize > 0 Then
  55.                     ReDim byt(0 To ClpSize - 1) As Byte
  56.                     CopyMemory byt(0), ByVal ClpData, ByVal ClpSize
  57.                     clptext = StrConv(byt, vbUnicode)
  58.                 End If
  59.                 GlobalUnlock hMem
  60.             End If
  61.             TextBox1.Visible = True
  62.             TextBox1.Text = clptext
  63.         Case 2, 8, 3, 14
  64.             Select Case fv
  65.             Case 2, 8
  66.                 f = 2
  67.                 hMem = GetClipboardData(2)
  68.                 hp = CopyImage(hMem, 0&, 0, 0, &H4)
  69.             Case Else
  70.                 f = 14
  71.                 hMem = GetClipboardData(14)
  72.                 hp = CopyEnhMetaFile(hMem, vbNullString)
  73.             End Select
  74.             If hMem <> 0 Then
  75.                 Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp
  76.                 With IID_IDispatch
  77.                     .Data1 = &H7BF80980
  78.                     .Data2 = &HBF32
  79.                     .Data3 = &H101A
  80.                     .Data4(0) = &H8B
  81.                     .Data4(1) = &HBB
  82.                     .Data4(2) = &H0
  83.                     .Data4(3) = &HAA
  84.                     .Data4(4) = &H0
  85.                     .Data4(5) = &H30
  86.                     .Data4(6) = &HC
  87.                     .Data4(7) = &HAB
  88.                 End With
  89.                 With uPicInfo
  90.                     .Size = Len(uPicInfo)
  91.                     .Type = IIf(f = 2, 1, 4)
  92.                     .hPic = hp
  93.                 End With
  94.                 OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
  95.                 Image1.Visible = True
  96.                 Set Image1.Picture = IPic
  97.             End If
  98.         Case Else
  99.             hMem = GetClipboardData(fv)
  100.             If hMem <> 0 Then
  101.                 ClpData = GlobalLock(hMem)
  102.                 ClpSize = GlobalSize(hMem)
  103.                 If ClpData <> 0 And ClpSize > 0 Then
  104.                     ReDim byt(0 To ClpSize - 1) As Byte
  105.                     CopyMemory byt(0), ByVal ClpData, ByVal ClpSize
  106.                     clptext = BinArrayToHex(byt)
  107.                 End If
  108.                 GlobalUnlock hMem
  109.             End If
  110.             clptext = clptext & vbCrLf & vbCrLf & "识别可能文本：" & vbCrLf & StrConv(byt, vbUnicode)
  111.             TextBox1.Visible = True
  112.             TextBox1.Text = clptext
  113.         End Select
  114.         CloseClipboard
  115.     End If
  116. End Sub

  118. Sub listclpformate()
  119.     Dim fname As String, f As Long, d
  120.     Set d = CreateObject("scripting.dictionary")
  121.     OpenClipboard 0&
  122.     f = EnumClipboardFormats(0)
  123.     Do While f <> 0
  124.         Select Case f
  125.         Case 1
  126.             fname = "文本"
  127.         Case 2
  128.             fname = "位图"
  129.         Case 3
  130.             fname = "MetaFilePict图片"
  131.         Case 4
  132.             fname = "SYLK"
  133.         Case 5
  134.             fname = "Dif"
  135.         Case 6
  136.             fname = "Tiff"
  137.         Case 7
  138.             fname = "OEM文本"
  139.         Case 8
  140.             fname = "DIB位图"
  141.         Case 9
  142.             fname = "Pallette"
  143.         Case 10
  144.             fname = "PenData"
  145.         Case 11
  146.             fname = "Riff"
  147.         Case 12
  148.             fname = "Wave"
  149.         Case 13
  150.             fname = "Unicode文字"
  151.         Case 14
  152.             fname = "增强型图元文件"
  153.         Case 15
  154.             fname = "HDrop"
  155.         Case 16
  156.             fname = "区域设置"
  157.         Case 17
  158.             fname = "DIBV5位图"
  159.         Case 18
  160.             fname = "Max"
  161.         Case 128
  162.             fname = "CF_OWNERDISPLAY"
  163.         Case 129
  164.             fname = "显示文本"
  165.         Case 130
  166.             fname = "CF_DSPBITMAP"
  167.         Case 131
  168.             fname = "CF_DSPMETAFILEPICT"
  169.         Case 142
  170.             fname = "CF_DSPENHMETAFILE"
  171.         Case 512
  172.             fname = "CF_PRIVATEFIRST"
  173.         Case 767
  174.             fname = "CF_PRIVATELAST"
  175.         Case 768
  176.             fname = "CF_GDIOBJFIRST"
  177.         Case 1023
  178.             fname = "CF_GDIOBJLAST"
  179.         Case Else:
  180.             fname = Space(255)
  181.             GetClipboardFormatName f, fname, 255
  182.             fname = Trim(fname)
  183.             If fname <> "" Then
  184.                 fname = Left(fname, Len(fname) - 1)
  185.             End If
  186.         End Select
  187.         d(fname) = f
  188.         f = EnumClipboardFormats(f)
  189.     Loop
  190.     CloseClipboard
  191.     If d.Count > 0 Then
  192.         Dim arr(), i&, k, it
  193.         ReDim arr(0 To d.Count, 0 To 1)
  194.         k = d.keys
  195.         it = d.items
  196.         arr(0, 0) = "格式编码"
  197.         arr(0, 1) = "格式名称"
  198.         For i = 1 To d.Count
  199.             arr(i, 0) = it(i - 1)
  200.             arr(i, 1) = k(i - 1)
  201.         Next
  202.         ListBox1.List = arr
  203.     End If
  204. End Sub

  206. Private Sub UserForm_Initialize()
  207.     TextBox1.Visible = True
  208.     Image1.Visible = False
  209.     listclpformate
  210. End Sub

  212. Private Function BinArrayToHex(Bin() As Byte) As String
  213.     Dim iLoop As Long
  214.     Dim sResult As String
  215.     Dim m&
  216.     m = 1
  217.     sResult = Space((UBound(Bin) - LBound(Bin) + 1) * 4)
  218.     For iLoop = LBound(Bin) To UBound(Bin)
  219.         Mid(sResult, (iLoop - LBound(Bin)) * 4 + 1, 2) = Right("0" & Hex(Bin(iLoop)), 2)
  220.         If m = 16 Then Mid(sResult, (iLoop - LBound(Bin)) * 4 + 3, 2) = vbCrLf: m = 0
  221.         m = m + 1
  222.     Next iLoop
  223.     BinArrayToHex = Trim(sResult)
  224. End Function
5楼
xmyjk		 四、如何监控剪贴板

（较难，作为拓展补充，以下涉及的知识，需要有WINDOWS消息传递机制和拦截WINDOWS消息的基础知识（或者再另贴讲吧）。涉及到相关的API，就不详细阐述，读者可自行查阅API手册。）

      WINDOWS剪贴板观察器（Clipboard Viewer）是一个显示剪贴板当前内容的窗口。剪贴板观察链（Clipboard Viewer Chain）是一系列相互独立的剪贴板观察窗口，是保存Clipboard   Viewer窗口以及他们之间的前后向关系的一个Windows系统链表，它们都能够监控并读取当前发送到剪贴板的内容。

      如何将我们的程序，注册成一个系统认可并可实时刷新的剪贴板监视程序呢？
      首先，使用SetClipboardViewer函数向剪贴板观察链中加入一个观察窗口。该函数需要传递的参数是观察窗口的句柄。返回值也是链条下一个窗口句柄。当一个窗口注册为Clipboard Viewer后，他会被加入Clipboard Viewer Chain，并得到链表中下一个Viewer窗口的句柄，该句柄必须保存以在响应消息时使用。Windows正是通过Clipboard Viewer Chain保证了所有Clipboard Viewer能接收和响应剪贴板变化消息。当剪贴板的内容发生变化时，该窗口会接收到一个WM_DRAWCLIPBOARD的消息。
      然后，响应WM_DRAWCLIPBOARD消息处理剪贴板内容的变化。
      最后，在程序退出或关闭时需要调用ChangeClipboardChain函数来将自己从观察链中删除。然后调用SendMessage函数把这些消息传递到观察链中的下一个观察窗口。

      另外，窗口都是有自己的窗口程序，来相应WINDOWS之间的消息传递，我们要把我们的窗体程序，注册成为相应剪贴板消息的监视程序，还需要如下步骤：
      首先，先用一个句柄，用GetWindowLong函数记录原来的窗口程序；
      然后，用SetWindowLong函数，设置相应剪贴板消息的监视程序和窗口进行绑定；
      接着，循环处理WINDOWS系统发来的消息，如果是剪贴板相关的消息，就来用我们写的剪贴板查看程序来处理，如果是非剪贴板查看的其他消息，就用CallWindowProc函数调用窗口原来的窗口程序处理消息。
      最后，当结束时，再次使用SetWindowLong将原窗口程序还原。
      
      不过，我做出来的程序，在WINDOWS XP的系统环境下，会造成EXCEL崩溃，但是在WIN7环境下，程序没有任何问题。或许我的理解在某方面还是有偏差的吧。待查证补充。也请大家指点。
6楼
xmyjk		 简易剪贴板监视查看程序.zip

剪贴板监视工具，标准模块代码：
  1. Option Explicit
  2. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  3. Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  4. Private Const WM_DRAWCLIPBOARD = &H308
  5. Private Const WM_CHANGECBCHAIN = &H30D
  6. Public PrevProc As Long
  7. Public hwnd As Long
  8. Public hwndNextViewer As Long

  10. Sub lo()
  11.     UserForm1.Show 0
  12. End Sub

  14. Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  15.     Select Case uMsg
  16.     Case WM_CHANGECBCHAIN
  17.         If wParam = hwndNextViewer Then
  18.             hwndNextViewer = lParam
  19.         ElseIf hwndNextViewer <> 0 Then
  20.             SendMessage hwndNextViewer, uMsg, wParam, lParam
  21.         End If
  22.     Case WM_DRAWCLIPBOARD
  23.         UserForm1.ListBox1.Clear
  24.         UserForm1.TextBox1.Value = ""
  25.         Set UserForm1.Image1.Picture = Nothing
  26.         UserForm1.TextBox1.Visible = True
  27.         UserForm1.Image1.Visible = False
  28.         UserForm1.listclpformate
  29.         SendMessage hwndNextViewer, uMsg, wParam, lParam
  30.     End Select
  31.     WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)

  33. End Function

窗体代码：
  1. Option Explicit

  3. Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
  4. Private Declare Function CloseClipboard Lib "user32" () As Long
  5. Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
  6. Private Declare Function EmptyClipboard Lib "user32" () As Long
  7. Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
  8. Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long

  10. Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  11. Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  12. Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
  13. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

  15. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  16. Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
  17. Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

  19. Private Type GUID
  20.     Data1 As Long
  21.     Data2 As Integer
  22.     Data3 As Integer
  23.     Data4(0 To 7) As Byte
  24. End Type
  25. Private Type uPicDesc
  26.     Size As Long
  27. Type As Long
  28.     hPic As Long
  29.     hPal As Long
  30. End Type

  32. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  33. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  34. Private Declare Function SetClipboardViewer Lib "user32" (ByVal hwnd As Long) As Long
  35. Private Declare Function ChangeClipboardChain Lib "user32" (ByVal hwnd As Long, ByVal hWndNext As Long) As Long

  37. Const GWL_WNDPROC = (-4)

  39. Private Sub ListBox1_Click()
  40.     TextBox1.Visible = False
  41.     Image1.Visible = False
  42.     Dim hMem As Long, ClpData As Long, ClpSize As Long, byt() As Byte, clptext As String, fv As Long, hp As Long, f As Long
  43.     If ListBox1.ListIndex <> 0 Then
  44.         fv = ListBox1.List(ListBox1.ListIndex)
  45.         OpenClipboard 0&
  46.         Select Case fv
  47.         Case 1, 7, 13
  48.             hMem = GetClipboardData(1)
  49.             If hMem <> 0 Then
  50.                 ClpData = GlobalLock(hMem)
  51.                 ClpSize = GlobalSize(hMem)
  52.                 If ClpData <> 0 And ClpSize > 0 Then
  53.                     ReDim byt(0 To ClpSize - 1) As Byte
  54.                     CopyMemory byt(0), ByVal ClpData, ByVal ClpSize
  55.                     clptext = StrConv(byt, vbUnicode)
  56.                 End If
  57.                 GlobalUnlock hMem
  58.             End If
  59.             TextBox1.Visible = True
  60.             TextBox1.Text = clptext
  61.         Case 2, 8, 3, 14
  62.             Select Case fv
  63.             Case 2, 8
  64.                 f = 2
  65.                 hMem = GetClipboardData(2)
  66.                 hp = CopyImage(hMem, 0&, 0, 0, &H4)
  67.             Case Else
  68.                 f = 14
  69.                 hMem = GetClipboardData(14)
  70.                 hp = CopyEnhMetaFile(hMem, vbNullString)
  71.             End Select
  72.             If hMem <> 0 Then
  73.                 Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp
  74.                 With IID_IDispatch
  75.                     .Data1 = &H7BF80980
  76.                     .Data2 = &HBF32
  77.                     .Data3 = &H101A
  78.                     .Data4(0) = &H8B
  79.                     .Data4(1) = &HBB
  80.                     .Data4(2) = &H0
  81.                     .Data4(3) = &HAA
  82.                     .Data4(4) = &H0
  83.                     .Data4(5) = &H30
  84.                     .Data4(6) = &HC
  85.                     .Data4(7) = &HAB
  86.                 End With
  87.                 With uPicInfo
  88.                     .Size = Len(uPicInfo)
  89.                     .Type = IIf(f = 2, 1, 4)
  90.                     .hPic = hp
  91.                 End With
  92.                 OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
  93.                 Image1.Visible = True
  94.                 Set Image1.Picture = IPic
  95.             End If
  96.         Case Else
  97.             hMem = GetClipboardData(fv)
  98.             If hMem <> 0 Then
  99.                 ClpData = GlobalLock(hMem)
  100.                 ClpSize = GlobalSize(hMem)
  101.                 If ClpData <> 0 And ClpSize > 0 Then
  102.                     ReDim byt(0 To ClpSize - 1) As Byte
  103.                     CopyMemory byt(0), ByVal ClpData, ByVal ClpSize
  104.                     clptext = BinArrayToHex(byt)
  105.                 End If
  106.                 GlobalUnlock hMem
  107.             End If
  108.             TextBox1.Visible = True
  109.             TextBox1.Text = clptext
  110.         End Select
  111.         CloseClipboard
  112.     End If
  113. End Sub

  115. Sub listclpformate()
  116.     Dim fname As String, f As Long, d
  117.     Set d = CreateObject("scripting.dictionary")
  118.     OpenClipboard 0&
  119.     f = EnumClipboardFormats(0)
  120.     Do While f <> 0
  121.         Select Case f
  122.         Case 1
  123.             fname = "文本"
  124.         Case 2
  125.             fname = "位图"
  126.         Case 3
  127.             fname = "MetaFilePict图片"
  128.         Case 4
  129.             fname = "SYLK"
  130.         Case 5
  131.             fname = "Dif"
  132.         Case 6
  133.             fname = "Tiff"
  134.         Case 7
  135.             fname = "OEM文本"
  136.         Case 8
  137.             fname = "DIB位图"
  138.         Case 9
  139.             fname = "Pallette"
  140.         Case 10
  141.             fname = "PenData"
  142.         Case 11
  143.             fname = "Riff"
  144.         Case 12
  145.             fname = "Wave"
  146.         Case 13
  147.             fname = "Unicode文字"
  148.         Case 14
  149.             fname = "增强型图元文件"
  150.         Case 15
  151.             fname = "HDrop"
  152.         Case 16
  153.             fname = "区域设置"
  154.         Case 17
  155.             fname = "DIBV5位图"
  156.         Case 129
  157.             fname = "显示文本"
  158.         Case Else:
  159.             fname = Space(255)
  160.             GetClipboardFormatName f, fname, 255
  161.             fname = Trim(fname)
  162.             If fname <> "" Then
  163.                 fname = Left(fname, Len(fname) - 1)
  164.             End If
  165.         End Select
  166.         d(fname) = f
  167.         f = EnumClipboardFormats(f)
  168.     Loop
  169.     CloseClipboard
  170.     If d.Count > 0 Then
  171.         Dim arr(), i&, k, it
  172.         ReDim arr(0 To d.Count, 0 To 1)
  173.         k = d.keys
  174.         it = d.items
  175.         arr(0, 0) = "格式编码"
  176.         arr(0, 1) = "格式名称"
  177.         For i = 1 To d.Count
  178.             arr(i, 0) = it(i - 1)
  179.             arr(i, 1) = k(i - 1)
  180.         Next
  181.         ListBox1.List = arr
  182.     End If
  183. End Sub

  185. Sub UserForm_Initialize()
  186.     TextBox1.Visible = True
  187.     Image1.Visible = False
  188.     listclpformate
  189.     hwnd = FindWindow(vbNullString, Me.Caption)
  190.     hwndNextViewer = SetClipboardViewer(hwnd)
  191.     PrevProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)

  193. End Sub

  195. Private Function BinArrayToHex(Bin() As Byte) As String
  196.     Dim iLoop As Long
  197.     Dim sResult As String
  198.     Dim m&
  199.     m = 1
  200.     sResult = Space((UBound(Bin) - LBound(Bin) + 1) * 4)
  201.     For iLoop = LBound(Bin) To UBound(Bin)
  202.         Mid(sResult, (iLoop - LBound(Bin)) * 4 + 1, 2) = Right("0" & Hex(Bin(iLoop)), 2)
  203.         If m = 16 Then Mid(sResult, (iLoop - LBound(Bin)) * 4 + 3, 2) = vbCrLf: m = 0
  204.         m = m + 1
  205.     Next iLoop
  206.     BinArrayToHex = Trim(sResult)
  207. End Function

  209. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  210.     ChangeClipboardChain hwnd, hwndNextViewer
  211.     SetWindowLong hwnd, GWL_WNDPROC, PrevProc
  212. End Sub
7楼
xmyjk		 五、其他补遗

（一）剪贴板数据格式注册函数
Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
参数lpString表示指定要注册的剪贴板格式的名称
注册成功，则返回该剪贴板格式所对应的编号，失败，则返回0；        如果被注册的剪贴板格式名称已经存在，并不会重新注册一个新的剪贴板格式，而是返回原有的同名剪贴板格式编号。

（二）获取剪贴板数据格式名称的API函数
Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
参数：wFormat表示剪贴板格式的编码；lpString表示用于接收剪贴板格式名称的缓冲字符串；nMaxCount：缓冲字符串的字节长度，超出部分将被截去。
成功， 返回lpString中储存相关格式名称的字节数，否则返回0

（三）将数据上传剪贴板的API函数
Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
参数：wFormat表示剪贴板格式的编码；hMem表示上传的数据对象的句柄

（四）其他功能函数
CountClipboardFormats：返回剪贴板可用数据格式的个数
EmptyClipboard：清空剪贴板
GetClipboardOwner：获取当前剪贴板是属于哪一个窗口的句柄
GetClipboardSequenceNumber：返回剪贴板序号
GetClipboardViewer：返回剪贴板监控程序所属窗口的句柄
GetOpenClipboardWindow：返回打开剪贴板的那个窗口句柄

(五) 另外，如果是纯文本格式数据对剪贴板的访问，可以使用DATAOBJECT，可参阅我以前写过的一个帖子。
如何运用VBA实现复制指定选择的单元格区域的数据，使粘贴到QQ后出现的是文本形式的
http://www.exceltip.net/thread-26337-1-1.html

8楼
bishunbiao		 只能仰视啦，收藏下
9楼
herelazy		 太牛啦**！仰望中！
10楼
千年一梦遥		 太牛啦**！仰望中！
11楼
xyf2210		 太牛啦**！仰望中！
12楼
CheryBTL		 哇～～～师傅太牛了****


13楼
YESS95		 烧香，膜拜，……
14楼
水星钓鱼		 仰望，膜拜，精华
15楼
yjzstar		 仰望加收藏
16楼
白米饭		 仰望中，有点晕
17楼
冬冬WarmUp		 太牛啦**！仰望中！
18楼
dhf327		 好东西,学习学习

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap