2016年10月30日 星期日

Excel VBA清除剪貼簿內容

近期為了解決一個在Excel上進行大量複製時而發生記憶體空間不足的問題，想說要將清除剪貼簿內容，但始終不得其門而入，後來將程式改寫另一種優化方法克服。
這裡將先將找到清除剪貼簿內容先做一紀錄，等未來找到更好解法再行補充。
透過VBA清除剪貼簿的程式碼
程式碼1 
Const DATAOBJECT_BINDING As String = "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"
Sub 清除剪貼簿內容()
    With CreateObject(DATAOBJECT_BINDING)
        .Clear
    End With
End Sub
程式碼2 
#If VBA7 Then
    Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
    Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
    Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As Long
#Else
    Declare Function CloseClipboard Lib "User32" () As Long
    Declare Function EmptyClipboard Lib "User32" () As Long
    Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
#End If

Sub EmptyCB()
    OpenClipboard (GetClipboardOwner)
    EmptyClipboard
    CloseClipboard
End Sub

這裡請注意，上面的程式碼並無法有效將 Excel 剪貼簿內容清除，只能將複製時的暫存內容做清除，要把系統剪貼簿的內容作清除，恐怕還要再找實驗研究了

取得剪貼簿資資料內容
#If VBA7 Then
    Declare PtrSafe Function GetClipboardOwner Lib "User32" () As Long
    Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
    Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
    Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As Long
    
    Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As LongPtr) As Long
    Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As LongPtr) As Long
    Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long
#Else
    Declare Function GetClipboardOwner Lib "User32" () As Long
    Declare Function CloseClipboard Lib "User32" () As Long
    Declare Function EmptyClipboard Lib "User32" () As Long
    Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
    Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
    Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
#End If
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 
Public Const GHND = &H42
Public Const CF_TEXT = 2
Public Const MAXSIZE = 4096
 
Function 取得剪貼簿內容()
   Dim hClipMemory As Long
   Dim lpClipMemory As Long
   Dim MyString As String
   Dim RetVal As Long
 
   If OpenClipboard(GetClipboardOwner) = 0 Then
      MsgBox "無法開啟剪貼簿"
      Exit Function
   End If
          
   ' Obtain the handle to the global memory
   ' block that is referencing the text.
   hClipMemory = GetClipboardData(CF_TEXT)
   If IsNull(hClipMemory) Then
      MsgBox "無法配置記憶體空間"
      GoTo OutOfHere
   End If
 
   ' Lock Clipboard memory so we can reference
   ' the actual data string.
   lpClipMemory = GlobalLock(hClipMemory)
   If Not IsNull(lpClipMemory) Then
      MyString = Space$(MAXSIZE)
      RetVal = lstrcpy(MyString, lpClipMemory)
      RetVal = GlobalUnlock(hClipMemory)
       
      ' Peel off the null terminating character.
      MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
   Else
      MsgBox "無法取得字串內容"
   End If
 
OutOfHere:
   RetVal = CloseClipboard()
   ClipBoard_GetData = MyString 
End Function


於