ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 EH云课堂直播课程免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 1222|回复: 1

在Windows8以后的系统中,只能使用VBA API操作剪贴板

[复制链接]

TA的精华主题

TA的得分主题

发表于 2016-9-20 15:20 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:Windows API应用

http://www.spreadsheet1.com/how- ... sing-excel-vba.html

Send Information To The Clipboard Using The MS-FORMS Library


Unfortunately, VBA does not offer a clipboard object, although Visual Basic 6 did. Luckily, the MS-Forms 2.0 DataObject object can be used by setting a reference to 'Microsoft Forms 2.0 Object' library. If your VBA project has a userform, then the reference has been already set.




The code snippets shown below work fine in Windows 7 and prior.
However, the code copies just two questions marks to the clipboard when used under Windows 8 and 10 (as tested in September 2015). Microsoft recommends using an API workaround.








Option ExplicitSub CopyTextToClipboardDemo()    ' Source: www.Spreadsheet1.com    ' Enable Forms Library: VBE>Tools> References>Microsoft Forms 2.0 Object Library>Check    Dim oClipboard As MSForms.DataObject        Set oClipboard = New MSForms.DataObject    oClipboard.SetText Now    'copy current date/time    oClipboard.PutInClipboardEnd SubFunction CopyToClipboard(sClipText As String) As Boolean    ' Source: www.Spreadsheet1.com    ' Late binding, no Forms Library reference required    Dim MSForms_DataObject As Object    On Error GoTo ErrorHandler_        Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")    MSForms_DataObject.SetText sClipText    MSForms_DataObject.PutInClipboard    CopyToClipboard = TrueExit FunctionErrorHandler_:    CopyToClipboard = FalseEnd FunctionSub Demo()    Debug.Print CopyToClipboard(Now)End SubSub GetTextFromClipboardDemo()    ' Source: www.Spreadsheet1.com    ' Enable Forms Library: VBE>Tools> References>Microsoft Forms 2.0 Object Library>Check    Dim oClipboard As MSForms.DataObject        Set oClipboard = New MSForms.DataObject    oClipboard.GetFromClipboard    Debug.Print oClipboard.GetTextEnd Sub





TA的精华主题

TA的得分主题

 楼主| 发表于 2016-9-20 15:21 | 显示全部楼层
本帖最后由 liucqa 于 2016-9-20 16:47 编辑

Use An API To Put Text In Windows Clipboard
To use Windows API calls to copy information to the Clipboard read this Microsoft article. The VBA code shown below is a modified version of Microsoft's snippet. The code seems to work just fine in Windows 8 and 10 as tested during September 2015. Error handling has been added to the function in order to return True (text copied) or False (an error occured) to the calling procedure.

The API declarations are compatible with both 32 and 64-bit versions of Office 2010, 2013, 2016.
Option Explicit

#If VBA7 Then
    Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr

    Declare PtrSafe Function LocalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As LongPtr) As LongPtr

    Declare PtrSafe Function CloseClipboard Lib "use*****" () As Long
    Declare PtrSafe Function OpenClipboard Lib "use*****" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function EmptyClipboard Lib "use*****" () As Long

    Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr

    Declare PtrSafe Function SetClipboardData Lib "use*****" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr

    Declare PtrSafe Function GetLastError Lib "kernel32" () As Long
#Else
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Declare Function CloseClipboard Lib "Use*****" () As Long
    Declare Function OpenClipboard Lib "Use*****" (ByVal hwnd As Long) As Long
    Declare Function EmptyClipboard Lib "Use*****" () As Long
    Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    Declare Function wstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    Declare Function SetClipboardData Lib "Use*****" (ByVal wFormat As Long, ByVal hMem As Long) As Long
#End If

Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096

Public Function ClipBoard_SetData(sPutToClip As String) As Boolean

    ' www.msdn.microsoft.com/en-us/library/office/ff192913.aspx

    Dim hGlobalMemory As Long
    Dim lpGlobalMemory As Long
    Dim hClipMemory As Long
    Dim X As Long
   
    On Error GoTo ExitWithError_

    ' Allocate moveable global memory
    hGlobalMemory = GlobalAlloc(GHND, Len(sPutToClip) + 1)

    ' Lock the block to get a far pointer to this memory
    lpGlobalMemory = GlobalLock(hGlobalMemory)

    ' Copy the string to this global memory
    lpGlobalMemory = lstrcpy(lpGlobalMemory, sPutToClip)

    ' Unlock the memory
    If GlobalUnlock(hGlobalMemory) <> 0 Then
        MsgBox "Memory location could not be unlocked. Clipboard copy aborted", vbCritical, "API Clipboard Copy"
        GoTo ExitWithError_
    End If

    ' Open the Clipboard to copy data to
    If OpenClipboard(0&) = 0 Then
        MsgBox "Clipboard could not be opened. Copy aborted!", vbCritical, "API Clipboard Copy"
        GoTo ExitWithError_
    End If

    ' Clear the Clipboard
    X = EmptyClipboard()

    ' Copy the data to the Clipboard
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
    ClipBoard_SetData = True
   
    If CloseClipboard() = 0 Then
        MsgBox "Clipboard could not be closed!", vbCritical, "API Clipboard Copy"
    End If
    Exit Function
ExitWithError_:
    On Error Resume Next
    If Err.Number > 0 Then MsgBox "Clipboard error: " & Err.Description, vbCritical, "API Clipboard Copy"
    ClipBoard_SetData = False

End Function
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-10-14 20:52 , Processed in 0.052019 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表