trash-area.com ≫ blog ≫ EXCELVBAでドラッグ&ドロップ

2012年05月18日 1

探してみたんですけどなかなか時間かかったので。
VBAでドラッグ&ドロップのドロップをシミュレートします。

まぁ用途はあまり無いんですけどね。
ファイル名がリストされてるテキストをインプットにできないアプリで使用しました。

Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type DROPFILES
    pFiles As Long
    pt As POINTAPI
    fNC As Long
    fWide As Long
End Type
 
Private Const WM_DROPFILES = &H233
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
 
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem 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 Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 
Public Sub drop_test()
 
    Dim files As Variant, v As Variant
    files = Array( _
          , "D:\work\test1.vbs" _
          , "D:\work\test2.vbs" _
          , "C:\Documents and Settings\hoge\デスクトップ\新規テキスト ドキュメント (3).txt" _
          , "C:\Documents and Settings\hoge\デスクトップ\新規テキスト ドキュメント (4).txt" _
          )
 
    Dim tDropFiles As DROPFILES, DROPFILE_SIZE As Long
    DROPFILE_SIZE = LenB(tDropFiles)
 
    Dim fileNamesSize As Long
 
    ' ファイル名の長さを計算
    ' (ファイル名+\0)+(ファイル名+\0)+...+(ファイル名+\0)+(\0)
    For Each v In files
        fileNamesSize = fileNamesSize + lstrlen(v) + 1
    Next
    fileNamesSize = fileNamesSize + 1
 
    ' メモリの確保(DROPFILESのサイズ+ファイル名の長さ分)
    Dim hMem As Long
    hMem = GlobalAlloc(GHND, DROPFILE_SIZE + fileNamesSize)
 
    tDropFiles.pFiles = DROPFILE_SIZE
 
    Dim pDropFiles As Long
    pDropFiles = GlobalLock(hMem)
 
    ' ファイル名を除いた分をコピー
    Call CopyMemory(ByVal pDropFiles, tDropFiles, DROPFILE_SIZE)
 
    ' ファイル名部分のコピー
    pDropFiles = pDropFiles + DROPFILE_SIZE
    For Each v In files
        Call lstrcpy(pDropFiles, ByVal CStr(v))
        pDropFiles = pDropFiles + lstrlen(v) + 1
    Next
 
    Call GlobalUnlock(hMem)
 
    ' メッセージをポスト
    Dim hwnd As Long
    hwnd = &H480810    'とりあえず直書き
    
    Call PostMessage(hwnd, WM_DROPFILES, hMem, 0)
 
    Call GlobalFree(hMem)
 
End Sub
ソーシャルブックマーク
はてな Livedoor del.icio.us
関連してそうな記事
同じカテゴリーの別の記事
タグ
, , , ,
トラックバックURL
コメント
1件のコメント
  1. かもい

    2013.06.22 @ 5:22 AM

    すいません。
    記述場所とか使い方がさっぱりわかりません。

    どこにドロップしたら、どう反応するのかも…

    もう少し詳しく解説願えませんか?

Comment RSS

コメントをどうぞ

*反映されるまでに時間がかかることがあります。
*メールアドレスはアバターの使用に使います。