ファイルをコピーするだけの処理

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal uFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal uFlags 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 Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As LongPtr, ByRef Source As Any, ByVal Length As LongPtr)
#Else
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function SetClipboardData Lib "user32" (ByVal uFormat As Long, ByVal hMem As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long

    Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByRef Source As Any, ByVal Length As Long)
#End If

Private Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_ZEROINIT As Long = &H40
Private Const GHND          As Long = GMEM_MOVEABLE Or GMEM_ZEROINIT
Private Const CF_HDROP      As Long = 15

' DROPFILES 構造体（32bit幅で定義：DWORD/POINT/BOOL/BOOL）
Private Type DROPFILES
    pFiles As Long   ' 先頭からのバイトオフセット
    ptX    As Long   ' 未使用（0でOK）
    ptY    As Long   ' 未使用（0でOK）
    fNC    As Long   ' 非クライアント領域（0でOK）
    fWide  As Long   ' Unicodeなら1
End Type

'==========================
' 公開API
'==========================
Public Function CopyFileToClipboard(ByVal FileFullPath As String) _
                                                       As Boolean
' 単一ファイルをクリップボードへ（エクスプローラーに対してCtrl+V可能な「コピー」状態）
'20250926

'引数
'FileFullPath・・・コピーするファイルのフルパス

    Dim FilePathList(1 To 1) As String: FilePathList(1) = FileFullPath
    CopyFileToClipboard = CopyFilesToClipboard(FilePathList)
    
End Function

Public Function CopyFilesToClipboard(ByVal FilePathList As Variant) _
                                                        As Boolean
'' 複数ファイル対応：Variant(配列) か String() を渡せます
'20250926

'引数
'FilePathList・・・ファイルのフルパスが入った一次元配列またはフルパス単体の文字列

    On Error GoTo EH
    
    '--- UnicodeのダブルNULL区切り文字列を作成（末尾はさらにNULLで二重終端）
    Dim S As String
    Dim I As Long
    For I = LBound(FilePathList) To UBound(FilePathList)
        ' 存在チェックはお好みでコメントアウト可
        If Dir$(FilePathList(I), vbNormal Or vbReadOnly Or vbArchive Or vbHidden Or vbSystem) = "" Then
            Err.Raise vbObjectError + 1, , "ファイルが見つかりません: " & FilePathList(I)
        End If
        S = S & FilePathList(I) & vbNullChar
    Next
    S = S & vbNullChar  ' 二重終端

    '--- メモリブロックサイズ＝DROPFILES + パス列（Unicode, LenBでバイト数）
    Dim df As DROPFILES
    df.pFiles = LenB(df) ' 構造体直後にパス列
    df.fWide = 1         ' Unicode

    Dim cbStruct As LongPtr: cbStruct = LenB(df)
    Dim cbPaths  As LongPtr: cbPaths = LenB(S)
    Dim cbTotal  As LongPtr: cbTotal = cbStruct + cbPaths

    '--- グローバルメモリ確保＆ロック
    Dim hMem As LongPtr: hMem = GlobalAlloc(GHND, cbTotal)
    If hMem = 0 Then GoTo EH
    Dim pMem As LongPtr: pMem = GlobalLock(hMem)
    If pMem = 0 Then GoTo EH

    '--- 先頭にDROPFILES構造体を書き込み
    RtlMoveMemory pMem, df, cbStruct
    '--- 直後にパス文字列（Unicode, 二重終端）を書き込み
    RtlMoveMemory pMem + cbStruct, ByVal StrPtr(S), cbPaths

    '--- クリップボードへ投入
    If OpenClipboard(0) = 0 Then GoTo EH
    Call EmptyClipboard
    #If VBA7 Then
        If SetClipboardData(CF_HDROP, hMem) = 0 Then
            Call CloseClipboard
            GoTo EH
        End If
    #Else
        If SetClipboardData(CF_HDROP, hMem) = 0 Then
            Call CloseClipboard
            GoTo EH
        End If
    #End If
    Call CloseClipboard

    ' 注意：SetClipboardDataへ渡すと所有権はOS側に移るため GlobalFreeは不要/不可
    Call GlobalUnlock(hMem)

    CopyFilesToClipboard = True
    Exit Function
EH:
    On Error Resume Next
    If pMem <> 0 Then Call GlobalUnlock(hMem)
    ' 失敗時は呼び出し側で False を確認
End Function

'※※※※※※※※※※※※※※※※※※※※※※※※※※
'テスト用
Private Sub Test__CopyFileToClipboard()
    Dim FilePath As String: FilePath = "C:\Temp\test.xlsx"
    If CopyFileToClipboard(FilePath) = True Then
        MsgBox "クリップボードにコピーしました。エクスプローラーで Ctrl+V してください。", vbInformation
    Else
        MsgBox "失敗しました。", vbExclamation
    End If
End Sub

Private Sub Test__CopyFilesToClipboard()
    Dim FilePath1    As String: FilePath1 = "C:\Temp\test1.xlsx"
    Dim FilePath2    As String: FilePath2 = "C:\Temp\test2.xlsx"
    Dim FilePathList As Variant
    FilePathList = Array(FilePath1, FilePath2)
    
    If CopyFilesToClipboard(FilePathList) = True Then
        MsgBox "クリップボードにコピーしました。エクスプローラーで Ctrl+V してください。", vbInformation
    Else
        MsgBox "失敗しました。", vbExclamation
    End If
End Sub