Oscar Sun

                    Sub 書名號篇名號檢查()
Dim s As Long, rng As Range, e, trm As String, ans
Static x() As String, i As Integer
On Error GoTo eH
Do
    Selection.Find.Execute "〈", , , , , , True, wdFindAsk
    Set rng = Selection.Range
    rng.MoveEndUntil "〉"
    trm = Mid(rng, 2)
    
    For Each e In x()
        If StrComp(e, trm) = 0 Then GoTo 1
    Next e
2   ans = MsgBox("是否略過「" & trm & "」？" & vbCr & vbCr & vbCr & "結束請按 NO[否]", vbExclamation + vbYesNoCancel)
    Select Case ans
        Case vbYes
            ReDim Preserve x(i) As String
            x(i) = trm
            i = i + 1
        Case vbNo
            Exit Sub
    End Select
1
Loop
Exit Sub
eH:
Select Case Err.Number
    Case 92 '沒有設定 For 迴圈的初始值 陣列尚未有值
        GoTo 2
End Select
End Sub

                  

                    Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _ 
   As Long 
Declare Function CloseClipboard Lib "User32" () 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 
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ 
   ByVal lpString2 As Any) As Long 
 
Public Const GHND = &H42 
Public Const CF_TEXT = 1 
Public Const MAXSIZE = 4096

'將以下程式碼貼入標準模組中。
Function ClipBoard_GetData() 
   Dim hClipMemory As Long 
   Dim lpClipMemory As Long 
   Dim MyString As String 
   Dim RetVal As Long 
 
   If OpenClipboard(0&) = 0 Then 
      MsgBox "Cannot open Clipboard. Another app. may have it open" 
      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 "Could not allocate memory" 
      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 "Could not lock memory to copy string from." 
   End If 
 
OutOfHere: 
 
   RetVal = CloseClipboard() 
   ClipBoard_GetData = MyString 
 
End Function
'https://msdn.microsoft.com/zh-tw/library/office/ff194373.aspx
                  

                    Option Explicit
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long

Public Sub SetClipboard(sUniText As String)
    Dim iStrPtr As Long
    Dim iLen As Long
    Dim iLock As Long
    Const GMEM_MOVEABLE As Long = &H2
    Const GMEM_ZEROINIT As Long = &H40
    Const CF_UNICODETEXT As Long = &HD
    OpenClipboard 0&
    EmptyClipboard
    iLen = LenB(sUniText) + 2&
    iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
    iLock = GlobalLock(iStrPtr)
    lstrcpy iLock, StrPtr(sUniText)
    GlobalUnlock iStrPtr
    SetClipboardData CF_UNICODETEXT, iStrPtr
    CloseClipboard
End Sub

Public Function GetClipboard() As String
    Dim iStrPtr As Long
    Dim iLen As Long
    Dim iLock As Long
    Dim sUniText As String
    Const CF_UNICODETEXT As Long = 13&
    OpenClipboard 0&
    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
        iStrPtr = GetClipboardData(CF_UNICODETEXT)
        If iStrPtr Then
            iLock = GlobalLock(iStrPtr)
            iLen = GlobalSize(iStrPtr)
            sUniText = String$(iLen \ 2& - 1&, vbNullChar)
            lstrcpy StrPtr(sUniText), iLock
            GlobalUnlock iStrPtr
        End If
        GetClipboard = sUniText
    End If
    CloseClipboard
End Function

'https://msdn.microsoft.com/zh-tw/library/office/ff192913.aspx
                  

                    例如我的工作表裡面的內容如下圖：



工作表我已框選A1:B4的範圍，並複製起來

此時，執行以下程式：

Sub Day22_取得剪貼簿內容()
    Dim data As New DataObject
    Dim strData  As String

    data.GetFromClipboard
    strData = data.GetText(1)

    Debug.Print strData
End Sub
此程式收集了剪貼簿的內容後，貼到即時運算視窗內，在該視窗將會呈現：



第二個程式，資料如同第一個程式，但為收集A2:A4範圍內的資料，然後寫入剪貼簿中，再用PasteSpecial方法貼到除存格中。

Sub Day22_寫入剪貼簿()
    Dim data As New DataObject
    Dim strData As String
    
    For Each Rng In Range("A2:B4")
        strData = strData & Rng
    Next
    
    data.SetText strData '寫入DataObject
    data.PutInClipboard  '寫入剪貼簿
    
    '同Range("D1").PasteSpecial xlPasteAll
    [D1].PasteSpecial xlPasteAll
End Sub
這裡要提到的是，[D1]這樣的寫法，看起來更簡單，寫起來也方便，但我不是很推薦，若你寫的程式需要再多國語言狀態下使用，有些語系的似乎是不支援，但如果都在同樣語系下使用，就沒什麼差別。

以下為呈現出來的結果：



以下是透過SetText方法塞入空值，達到清除剪貼簿的目的。

Sub Day22_清除剪貼簿內容()
    Dim data As New DataObject
    Set data = New DataObject
    data.SetText ""
    data.PutInClipboard
End Sub
若你有大量資料需要重別處複製過來，但須加工後才能使用，那可以試著用這方法，將剪貼簿內容取出後，透過程式處理完，再貼到特定位置，達到更有效率的目的，以上分享，希望對各位有所助益。

http://ithelp.ithome.com.tw/articles/10159745
                  

                    #If VBA7 Then
  Private Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
  Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If

http://stackoverflow.com/questions/29723694/excel-2013-windows-class-names
http://www.jkp-ads.com/articles/apideclarations.asp
http://phorum.study-area.org/index.php?topic=49537.0;wap