GDIplusCODE


'APIの関数宣言、構造体、定数省略
'参考
'http://www.developerfusion.com/code/7757/excel-vba-date-and-time-picker-using-winapi
'APIの関数、定数の一部はこちらを参考
'http://homepage2.nifty.com/nonnon/Win32Api/

Private hWnd As Long
Private Const CLASSNAME = "vbaKoneko"
Private files() As String

Sub test()
  Dim i As Long
  
  DisplayForm
  For i = LBound(files) To UBound(files)
    Cells(i + 1, 1).Value = files(i)
  Next i
End Sub

Private Sub DisplayForm()
    Const TITLE = "FormにファイルをD&D"
    Dim iccex As tagINITCOMMONCONTROLSEX
    Dim myCreate As CREATESTRUCT
    Dim myWinClass As WNDCLASSEX
    Dim myMessage As Msg
    Dim hexcel As Long
    Dim xlhinstance As Long
    Dim pos As POINTAPI
     
    With myWinClass
      .cbSize = Len(myWinClass)
      .style = CS_HREDRAW Or CS_VREDRAW Or CS_GLOBALCLASS
      .lpfnWndProc = FunctionPointer(AddressOf WindowProc)
      .cbClsExtra = 0&
      .cbWndExtra = 0&
      hexcel = FindWindow("XLMAIN", vbNullString)
       xlhinstance = GetWindowLong(hexcel, GWL_HINSTANCE)
      .hInstance = xlhinstance
      .hIcon = LoadIcon(xlhinstance, IDI_APPLICATION)
      .hCursor = LoadCursor(xlhinstance, IDC_ARROW)
      .hbrBackground = GetStockObject(WHITE_BRUSH)
      .lpszMenuName = 0&
      .lpszClassName = CLASSNAME
      .hIconSm = LoadIcon(xlhinstance, IDI_APPLICATION)
    End With
    RegisterClassEx myWinClass
    
    GetCursorPos pos
     '////// Windowの生成 //////
    hWnd = CreateWindowEx(WS_EX_TOPMOST Or WS_EX_WINDOWEDGE, CLASSNAME, TITLE _
      , WS_CHILD Or WS_POPUP Or WS_VISIBLE Or WS_BORDER Or WS_OVERLAPPEDWINDOW _
      , pos.x, pos.y, 250, 100, _
      0, 0, xlhinstance, 0)
    ShowWindow hWnd, SW_SHOWNORMAL
    UpdateWindow hWnd
    SetFocus hWnd
    Call DragAcceptFiles(hWnd, True)
    '////// メッセージループ //////
    Do While GetMessage(myMessage, 0&, 0&, 0&) <> 0
        TranslateMessage myMessage
        DispatchMessage myMessage
    Loop
End Sub

'////// ウィンドウプロシージャ //////
Private Function WindowProc(ByVal lhwnd As Long, ByVal tMessage As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lngResult As Long
    Dim hDrop   As Long
    Dim filecnt As Long
    Dim i       As Long
    Dim leng    As Long
    Dim buf     As String * 256

    Select Case tMessage
    Case WM_DESTROY
        DestroyWindow lhwnd
        PostQuitMessage 0&
        Exit Function
        
    Case WM_DROPFILES
            hDrop = wParam
            filecnt = DragQueryFile(hDrop, -1&, vbNullString, 0)
            ReDim files(filecnt - 1)
            For i = 0 To filecnt - 1
                buf = String(256, Chr(0))
                lngResult = DragQueryFile(hDrop, i, buf, 256)
                files(i) = Left$(buf, InStr(1, buf, Chr(0)) - 1)
            Next
            Call DragFinish(hDrop)
            Call PostMessage(hWnd, WM_CLOSE, 0, 0)
    End Select
    WindowProc = DefWindowProc(lhwnd, tMessage, wParam, lParam)
End Function

Private Function FunctionPointer(ByVal lPtr As Long) As Long
    FunctionPointer = lPtr
End Function
独自Windowでファイル名のリストを取得（D&Dによる）
