Excelの小技３

---

Excelで選択セルの内容をクリップボードにコピーするVBA
●方法１
Option Explicit

' 現在のセルの文字列や数値のみをコピーする
Sub CopyActiveCellValueToClipboard()
   Dim xDataObject As Object
   Set xDataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

   With xDataObject
       .SetText ActiveCell.Value
       .PutInClipboard
   End With
End Sub

●方法２
#If VBA7 Then
   Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
   Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
   Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
   Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
   Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
   Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
   Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
   Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As LongPtr, ByVal lpString2 As String) As LongPtr
#Else
   ' 32bit版の宣言（必要なら追加）
#End If

Const CF_TEXT = 1
Const GHND = &H42

Sub CopyToClipboardAPI()
   Dim sText As String
   Dim hGlobalMemory As LongPtr
   Dim lpGlobalMemory As LongPtr

   ' 選択セルの内容を取得（複数セル対応）
   Dim cell As Range
   For Each cell In Selection
       sText = sText & cell.Text & vbTab
   Next cell
   If Len(sText) > 0 Then sText = Left(sText, Len(sText) - 1) ' 最後のタブ削除
   sText = sText & vbNullChar ' null終端を追加

   If OpenClipboard(0&) Then
       EmptyClipboard
       hGlobalMemory = GlobalAlloc(GHND, LenB(sText) + 1) ' ← ここが重要！バイト数で確保
       lpGlobalMemory = GlobalLock(hGlobalMemory)
       lstrcpy lpGlobalMemory, sText
       GlobalUnlock hGlobalMemory
       SetClipboardData CF_TEXT, hGlobalMemory
       CloseClipboard
   End If
End Sub