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

Clipboard


【ファイル名】Clipboard.xlsm
【バージョン】Ver 1.0.0.1
【作成日】2021年05月03日
【更新日】2021年05月31日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】Clipboard.zip
【説明】Windows APIによるクリップボードのユニコードの文字列の取得と設定とクリアーのサンプルです。

クリップボードのフォーマットは、WinUser.h ファイルを参照しました。(C:\Program Files\Windows Kits\10\Include\10.0.19041.0\um\WinUser.h)
Windows SDK and emulator archiveからダウンロードしてます。

【外部リンク】Docs > Office VBA リファレンス > Access > 概念 > Windows API >  クリップボードに情報を送信する
【外部リンク】Windows > Apps > Win32 > API > Data Exchange > Winuser.h > OpenClipboardEmptyClipboardCloseClipboardIsClipboardFormatAvailableGetClipboardDataSetClipboardData
【外部リンク】Windows > Apps > Win32 > API > System Services > Winbase.h > GlobalAllocGlobalLockGlobalUnlockGlobalSize
【外部リンク】Windows > Apps > Win32 > API > Menus and Other Resources > Winbase.h > lstrcpyW

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="フォーム">
          <button id="ShowButton" label="表示(&amp;S)" supertip="フォームを表示します。" size="large" imageMso="WindowUnhide" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

UserForm1
Option Explicit

' クリップボードにユニコードの文字列を設定します。
Private Sub SetButton_Click()
  ClipboardModule.SetClipboardText TextBox1.Text
  TextBox1.Text = ""
End Sub

' クリップボードのユニコードの文字列を取得します。
Private Sub GetButton_Click()
  TextBox1.Text = ClipboardModule.GetClipboardText()
End Sub

' クリップボードを空にします。
Private Sub ClearButton_Click()
  ClipboardModule.ClearClipboard
  TextBox1.Text = ""
End Sub

' フォームを閉じます。
Private Sub ExitButton_Click()
  Unload Me
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
  
#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
#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 Sub ClearClipboard()
  OpenClipboard 0
  EmptyClipboard
  CloseClipboard
End Sub

' クリップボードにユニコードの文字列をコピーします。
Public Sub SetClipboardText(ByVal UnicodeText As String)
  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
  
  If OpenClipboard(0) = 0 Then
    Err.reaise 1000, "SetClipboardText", "クリップボードをオープンできません!"
    Exit Sub
  End If
  
  iLen = LenB(UnicodeText) + 2& ' 【注意】ヌルはユニコードなので2バイト必要です。
  iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen) ' グローバル メモリを0(ヌル)で初期化してから確保する
  iLock = GlobalLock(iStrPtr)                                 ' このメモリはシステムが解放するので自分では解放しない事!
  lstrcpy iLock, StrPtr(UnicodeText)
  GlobalUnlock iStrPtr
  
  EmptyClipboard
  SetClipboardData CF_UNICODETEXT, iStrPtr
  CloseClipboard
End Sub

' クリップボードのユニコードの文字列を取得します。
Public Function GetClipboardText() As String
  Dim UnicodeText As String
#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_UNICODETEXT) Then
    iStrPtr = GetClipboardData(CF_UNICODETEXT)
    
    If iStrPtr Then
      iLock = GlobalLock(iStrPtr)
      iLen = GlobalSize(iStrPtr)
      UnicodeText = String(CLng(iLen) \ 2 - 1, vbNullChar) ' 最後のヌルを除いたユニコードの文字数のメモリを確保する。
      lstrcpy StrPtr(UnicodeText), iLock
      GlobalUnlock iStrPtr
    End If
    
    GetClipboardText = UnicodeText
  End If
  
  CloseClipboard
End Function
'---------------------------------------------------------------------------------------------------------------
' 関数のテスト

Private Sub test_ClearClipboard()
  ClearClipboard
End Sub

Private Sub test_SetClipboardText()
  SetClipboardText "こんにちわ" & vbCrLf & "さようなら"
End Sub

Private Sub test_GetClipboardText()
  MsgBox Prompt:=GetClipboardText(), Buttons:=vbInformation, Title:="情報"
End Sub
このページの上

Module1
Option Explicit

Private rbRibbonUI As IRibbonUI   ' リボン

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

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "ShowButton"
      UserForm1.Show vbModal
    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 UserForm1_Show()
  UserForm1.Show vbModal
End Sub
このページの上