关于 Application.CutCopyMode = False

everbest2015

ykcbf1100 发表于 2025-6-17 11:58
８楼代码还不行的话，再试试使用 Windows API 清空剪贴板

感谢大佬  实测没效果  依然感谢

everbest2015

perfect1313 发表于 2025-6-17 11:49
用 htmlfile 清空

感谢,测试貌似没效果 有可能是没太懂怎么用

lujkhua

ISS001大师所说要利用IUIAutomationCilent

1. Sub 清空office剪贴板() '添加引用：IUIAutomationCilent
   
2.     On Error Resume Next
   
3.     ThisWorkbook.VBProject.References.AddFromFile "UIAutomationCore.dll"
   
4.     Call ClearClip '清空Office剪贴板
   
5. End Sub
   
6. Sub ClearClip()
   
7.     'On Error Resume Next
   
8.     Dim AutomationObj As IUIAutomation
   
9.     Dim WindowElement As IUIAutomationElement
   
10.     Dim clearButton As IUIAutomationElement
    
11.     Application.ScreenUpdating = True
    
12.     Application.DisplayClipboardWindow = True
    
13.     Set ExcelSheet = CreateObject("Excel.Sheet")
    
14.     ExcelSheet.Application.Visible = True
    
15.     Set AutomationObj = New CUIAutomation
    
16.     Set WindowElement = AutomationObj.ElementFromHandle(ByVal Application.hwnd)
    
17.     Dim iCond As IUIAutomationCondition
    
18.     Set iCond = AutomationObj.CreatePropertyCondition(UIA_NamePropertyId, "全部清空")
    
19.     Set clearButton = WindowElement.FindFirst(TreeScope_Subtree, iCond)
    
20.     Dim InvokePattern As IUIAutomationInvokePattern
    
21.     If clearButton.CurrentName = "全部清空" Then
    
22.         Set InvokePattern = clearButton.GetCurrentPattern(UIA_InvokePatternId)
    
23.         InvokePattern.Invoke
    
24.     End If
    
25.     Application.Wait Now + TimeSerial(0, 0, 2)
    
26.     ExcelSheet.Close
    
27. End Sub

复制代码

方法是对的

perfect1313

everbest2015 发表于 2025-6-17 14:54
感谢,测试貌似没效果 有可能是没太懂怎么用

得谷歌

everbest2015

perfect1313 发表于 2025-6-17 18:52
得谷歌

优秀!!!!!!!!!!!!!!!!!!!!!!!!!1

lss001

[quote]

ggmmlol

模拟手工清空Office剪贴板，简单粗暴了点，

1. Type POINTAPI
   
2.     x As Long
   
3.     y As Long
   
4. End Type
   
5. Type RECT
   
6.     Left As Long
   
7.     Top As Long
   
8.     Right As Long
   
9.     Bottom As Long
   
10. End Type
    
11. #If VBA7 Then
    
12.     Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As LongPtr, ByVal hWndChildAfter As LongPtr, ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
    
13.     Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    
14.     Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
    
15.     Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As LongPtr)
    
16. #Else
    
17.     Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
    
18.     Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    
19.     Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
    
20.     Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
    
21. #End If
    
22. 
    
23. Sub ClearClipboard()
    
24.     #If VBA7 Then
    
25.         Dim hwnd As LongPtr
    
26.     #Else
    
27.         Dim hwnd As Long
    
28.     #End If
    
29.     Dim blVisible As Boolean
    
30.     Application.ScreenUpdating = True
    
31.     With Application.CommandBars("Office Clipboard")
    
32.         blVisible = .Visible
    
33.         If Not blVisible Then .Visible = True: DoEvents
    
34.         hwnd = FindClipboardWindow()
    
35.         If hwnd = 0 Then Exit Sub
    
36.         Dim RECT As RECT, pt As POINTAPI
    
37.         GetWindowRect hwnd, RECT
    
38.         ' 计算"全部清空"按钮坐标（左上角偏移）
    
39.         
    
40.         If RECT.Right - RECT.Left > 220 Then
    
41.             '"全部清空"按钮水平排列在"全部粘贴"按钮的右侧
    
42.             pt.x = RECT.Left + 140
    
43.             pt.y = RECT.Top + 20
    
44.         Else
    
45.             '"全部清空"按钮纵向排列在"全部粘贴"按钮的下方
    
46.             pt.x = RECT.Left + 62
    
47.             pt.y = RECT.Top + 53
    
48.         End If
    
49.         '    模拟鼠标单击"全部清空"按钮
    
50.         LeftClickOnPoint pt
    
51.         .Visible = blVisible
    
52.     End With
    
53. End Sub
    
54. #If VBA7 Then
    
55. Private Function FindClipboardWindow() As LongPtr
    
56.     Dim hwnd As LongPtr
    
57. #Else
    
58. Private Function FindClipboardWindow() As Long
    
59.     Dim hwnd As Long
    
60. #End If
    
61.     hwnd = FindWindow("XLMAIN", ThisWorkbook.Application.Caption)
    
62.     hwnd = FindWindowEx(hwnd, 0, "EXCEL2", vbNullString)
    
63.     hwnd = FindWindowEx(hwnd, 0, "MsoCommandBar", "Office 剪贴板")
    
64.     hwnd = FindWindowEx(hwnd, 0, "MsoWorkPane", vbNullString)
    
65.     FindClipboardWindow = hwnd
    
66. End Function

复制代码

ggmmlol

上面落下了一个子过程，补丁一下：

1. Private Sub LeftClickOnPoint(pt As POINTAPI)
   
2.     SetCursorPos pt.x, pt.y
   
3.     mouse_event &H2, 0, 0, 0, 0 ' MOUSEEVENTF_LEFTDOWN
   
4.     mouse_event &H4, 0, 0, 0, 0 ' MOUSEEVENTF_LEFTUP
   
5.     DoEvents
   
6. End Sub

复制代码

lss001

ggmmlol 发表于 2025-6-19 10:48
上面落下了一个子过程，补丁一下：

建议看看以下博客文章
https://www.cnblogs.com/wangminbai/archive/2008/04/25/1169808.html