HOME > エクセルVBA > サンプル > RegisterClipboardFormat

RegisterClipboardFormat


【ファイル名】RegisterClipboardFormat.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年05月05日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】Anyを使用した例は、RegisterClipboardFormat.zip、Anyを使用しない例は、RegisterClipboardFormatType.zip
【説明】Windows APIでクリップボードに独自のフォーマットを登録しコピーと貼り付けするサンプルです。

クリップボードの新しいフォーマットを、Windows APIのRegisterClipboardFormatW関数で登録します。

このサンプルは、Any を使用してます。(非推奨)
Any はVBAで型を検査しません。多くの人が ByVal が必要なのに、ByVal を忘れたり型を間違えます。Excelが異常終了する場合があります。
  Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)

' ユーザー定義型は参照渡し(ByRef)ですが、グルーバルメモリは、ByVal が必要です。
  CopyMemory ByVal iLock, pRec, iLen
  CopyMemory pRec, ByVal iLock, iLen

Any を使わないで違う型にし、複数の関数の名前を宣言した方が安全です。
  Private Declare PtrSafe Sub CopyToMem Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, Source As TRec, ByVal Length As LongPtr)
  Private Declare PtrSafe Sub CopyFromMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As TRec, ByVal Source As LongPtr, ByVal Length As LongPtr)

【外部リンク】Docs > Office VBA リファレンス > Access > 概念 > Windows API >  クリップボードに情報を送信する
【外部リンク】Windows > Apps > Win32 > API > Data Exchange > Winuser.h >  RegisterClipboardFormatWOpenClipboardEmptyClipboardCloseClipboardIsClipboardFormatAvailableGetClipboardDataSetClipboardData
【外部リンク】Windows > Apps > Win32 > API > System Services > Winbase.h > GlobalAllocGlobalLockGlobalUnlockGlobalSize
【外部リンク】Windows > Apps > Win32 > API > Desktop Technologies > Developer Notes > RtlMoveMemory

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="クリップボード">
          <box id="box1" boxStyle="vertical">
            <checkBox id="checkBox1" label="チェック" keytip="B" onAction="checkBox_onAction" getPressed="getPressed" />
            <dropDown id="dropDown1" label="番号" supertip="番号を選択します。" keytip="N"
                      showItemLabel="true" showItemImage="true" getSelectedItemIndex="getSelectedItemIndex" onAction="dropDown_onAction">
              <item id="item1" label="1001" imageMso="_1" />
              <item id="item2" label="1002" imageMso="_2" />
              <item id="item3" label="1003" imageMso="_3" />
            </dropDown>
            <editBox id="editBox1" label="文字列" keytip="S" supertip="10文字以内で入力して、Enterキーを押してください。"
                     maxLength="10" sizeString="WWWWWMMMMM" getText="getText" onChange="onChange" />
          </box>
          <box id="box2" boxStyle="vertical">
            <button id="CopyButton" label="コピー" keytip="C" imageMso="Copy"
                    supertip="クリップボードにコピーします。" onAction="onAction" />
            <button id="PasteButton" label="貼り付け" keytip="P" imageMso="Paste"
                    supertip="クリップボードから貼り付けします。" onAction="onAction" />
            <button id="ClearButton" label="クリアー" keytip="D" imageMso="Delete"
                    supertip="入力をクリアーします。&#13;クリップボードには何もしません。" onAction="onAction" />
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

ThisWorkbook
Private Sub Workbook_Open()
  CF_MYRECDATA = ClipboardModule.RegisterClipboard("CF_MYRECDATA")  ' 新しいクリップボードのフォーマットを登録する
End Sub
このページの上

ClipboardModule
Option Explicit
' 【参考したサイト】
' Docs > Office VBA リファレンス > Access > 概念 > Windows API > クリップボードに情報を送信する
' https://docs.microsoft.com/ja-jp/office/vba/access/concepts/windows-api/send-information-to-the-clipboard

#If Win64 Then
' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-openclipboard
  Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As Long
' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-emptyclipboard
  Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-closeclipboard
  Private Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-isclipboardformatavailable
  Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As Long) As Long
' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-getclipboarddata
  Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As LongPtr
' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-setclipboarddata
  Private Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
' https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-globalalloc
  Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
' https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-globallock
  Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
' https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-globalunlock
  Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
' https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-globalsize
  Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
' https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-lstrcpyw
  Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As LongPtr
' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-registerclipboardformatw
  Private Declare PtrSafe Function RegisterClipboardFormat Lib "User32" Alias "RegisterClipboardFormatW" (ByVal lpString As LongPtr) As Long
' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-countclipboardformats
  Private Declare PtrSafe Function CountClipboardFormats Lib "User32" () As Long
' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-enumclipboardformats
  Private Declare PtrSafe Function EnumClipboardFormats Lib "User32" (ByVal wFormat As Long) As Long
  ' https://msdn.microsoft.com/en-us/library/windows/desktop/aa366788(v=vs.85).aspx
  ' 【注意】引数は Any で宣言したので、グローバルメモリの前には、ByVal を忘れない事!(配列、ユーザー定義型はByRefなので不要)
  Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
  
#Else
  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
  Private Declare Function RegisterClipboardFormat Lib "User32" Alias "RegisterClipboardFormatW" (ByVal lpString As Long) As Long
  Private Declare Function EnumClipboardFormats Lib "User32" (ByVal wFormat As Long) As Long
  Private Declare Function CountClipboardFormats Lib "User32" () As Long
  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If

' グローバル メモリ(WinBase.h)
Private Const GMEM_MOVEABLE As Long = &H2 ' 再配置可能なメモリ
Private Const GMEM_ZEROINIT As Long = &H40 ' 0で初期化する
Private Const GMEM_SHARE As Long = &H2000 ' 共有メモリ
Private Const GHND As Long = GMEM_MOVEABLE Or GMEM_ZEROINIT ' 再配置可能なメモリで、0で初期化する

' クリップボードのフォーマット(WinUser.h)
Private Const CF_TEXT As Long = 1 ' ANSIの文字
Private Const CF_OEMTEXT As Long = 7 ' OEMキャラセット(MS-DOS)
Private Const CF_UNICODETEXT As Long = 13 ' ユニコードの文字列

Public CF_MYRECDATA As Long ' このサンプル独自のクリップボードのフォーマット

' 新しいクリップボードのフォーマットを登録する
' Workbook_Open で開いた時に実行します。
Function RegisterClipboard(ClipboardFormat As String) As Long
  RegisterClipboard = RegisterClipboardFormat(StrPtr(ClipboardFormat))
End Function

' クリップボードにコピーします。
Public Sub SetClipboard(pRec As TRec)
  Dim iLen As Long
#If Win64 Then
  Dim iStrPtr As LongPtr
  Dim iLock As LongPtr
#Else
  Dim iStrPtr As Long
  Dim iLock As Long
#End If
  
  iLen = LenB(pRec)
  iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen) ' グローバル メモリを0(ヌル)で初期化してから確保する
  iLock = GlobalLock(iStrPtr)
  CopyMemory ByVal iLock, pRec, iLen
  GlobalUnlock iStrPtr
  
  OpenClipboard 0
  EmptyClipboard
  SetClipboardData CF_MYRECDATA, iStrPtr
  CloseClipboard
End Sub

' クリップボードから取得します。
Public Sub GetClipboard(pRec As TRec)
  Dim i As Long
#If Win64 Then
  Dim iStrPtr As LongPtr
  Dim iLock As LongPtr
  Dim iLen As LongPtr
#Else
  Dim iStrPtr As Long
  Dim iLock As Long
  Dim iLen As Long
#End If
  
  OpenClipboard 0
  
  If IsClipboardFormatAvailable(CF_MYRECDATA) = 0 Then
    MsgBox Prompt:="クリップボードにデーターがありません。", Buttons:=vbCritical + vbSystemModal, Title:="警告"
  Else
    iStrPtr = GetClipboardData(CF_MYRECDATA)
    
    If iStrPtr Then
      iLock = GlobalLock(iStrPtr)
      iLen = GlobalSize(iStrPtr)
      CopyMemory pRec, ByVal iLock, iLen
      GlobalUnlock iStrPtr
    End If
    
  End If
  
  CloseClipboard
End Sub
このページの上

Module1
Option Explicit

Public Type TRec
  Check As Boolean
  Number As Integer
  Text(0 To 19) As Byte ' ユニコードなので、文字数 10 * 2 のバイト数が必要
End Type

Private rbRibbonUI As IRibbonUI   ' リボン
Private rbText As String ' editBoxの文字列
Private rbRec As TRec

Sub InitRibbon() ' リボンをクリアー
  rbRec.Check = False ' チェックボックスのチェック
  rbRec.Number = 0 ' DropDownの1番目の項目を選択します(0で始まるため)
  rbText = "" ' 文字列のテキストボックスを空にします
  rbRibbonUI.Invalidate ' リボンの表示を更新する
End Sub

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  InitRibbon
End Sub

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "CopyButton"
      ClipboardModule.SetClipboard rbRec
    Case "PasteButton"
      ClipboardModule.GetClipboard rbRec
      rbText = StrVBA(rbRec.Text)
      rbRibbonUI.Invalidate ' リボンの表示を更新する
    Case "ClearButton"
      InitRibbon ' リボンをクリアー
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
  End Select
  
  Exit Sub
'-------------------------------------------------------------------------------------------------------------------------
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub

Sub getPressed(control As IRibbonControl, ByRef returnedVal) ' チェックボックスにチェックを設定する
  returnedVal = rbRec.Check
End Sub

Sub checkBox_onAction(control As IRibbonControl, pressed As Boolean) ' チェックボックスのクリック処理
  rbRec.Check = pressed
End Sub

Sub getSelectedItemIndex(control As IRibbonControl, ByRef index) ' DropDownの項目の選択を設定
  index = rbRec.Number
End Sub

Sub dropDown_onAction(control As IRibbonControl, itemID As String, index As Integer) ' DropDownのクリックした処理
  rbRec.Number = index
End Sub

Sub getText(control As IRibbonControl, ByRef returnedVal) ' editBoxに文字列を代入する
  returnedVal = rbText
End Sub

Sub onChange(control As IRibbonControl, Text As String) ' editBoxで[Enter]キーを押したか、他のコントロールに移動した場合のイベント
  Dim arr() As Byte
  Dim i As Long
  
  ReDim arr(LBound(rbRec.Text) To UBound(rbRec.Text))
  
  For i = LBound(arr) To UBound(arr) ' 配列をクリアーする
    arr(i) = 0
    rbRec.Text(i) = 0
  Next
  
  arr = Text ' 文字列から固定配列に代入する前に、動的な配列に代入する
  
  For i = LBound(arr) To UBound(arr)
    rbRec.Text(i) = arr(i) ' 配列の代入
  Next
End Sub

' 指定したヌルで終わる文字列から、vbNullCharの左側の文字列を取得します。
Public Function StrVBA(ByVal EndNullString As String) As String
  Dim p As Long
  
  p = InStr(1, EndNullString, vbNullChar)
  If p > 0 Then
    StrVBA = Left(EndNullString, p - 1)
  Else
    StrVBA = EndNullString ' ■ vbNullCharがない場合は引数をそのまま返します。
'    StrVBA = vbNullString ' ■ 必要に応じて変更してください。
  End If
End Function
このページの上