[[20181211140007]]　『64bitExcelでフォームにD&Dしたファイルパスの取刀x（ぷー）　ページの最後に飛ぶ

『64bitExcelでフォームにD&Dしたファイルパスの取得方法』（ぷー）

はじめまして。

タイトルのような「D&Dしたファイルパスの取得」動作を
以前はユーザーフォームにListViewオブジェクトを貼り付けて
OLEDragDropを使用して取得していました。

新しいパソコンの環境がWindows10(64bit)とExcel2013(64bit)に
なってしまい、上記方法が取れなくなってしまいました。
※ListViewが標準で使えなくなった様子。

(質問)
Windows10(64bit)とExcel2013(64bit)の環境で、
フォームにドラッグ＆ドロップしたファイルの
ファイルパスを取得する方法はありませんか？

『「ファイルを開く」ダイアログボックス』でやればええやんとの
声も聞こえますが、使いづらいので何か方法や手段があれば教えて頂きたく。

以上、よろしく御願いします。

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

ListViewコントロールは、32bitしかない時代のVB6.0に付属していたものですから、64bitには全く対応していません。 Excel標準のコントロールには同様のイベントを拾えるものがないので、諦めたほうがよいでしょう。

一応、64bitのVB.NET等でコントロールを自作するという手もありますが、難しいでしょうね。
https://social.msdn.microsoft.com/Forums/ja-JP/071aeae7-5d9e-415c-8902-8c7cfe666505/win86412398excel20136412391listview1243420351123561238312356?forum=vbajp
（???） 2018/12/11(火) 14:25

VBAのコントロールをサブクラス化してドラッグドロップに対応する方法が無い事もないですが、クラッシュしやすいので利用にはとても注意が必要です。

ブレークポイントを入れたり、例外が発生しようものならエクセルごと落ちます（笑）
挑戦するならどうぞ。

参考
http://gdipluscode.sakura.ne.jp/etc/dandd2textbox.html
http://gdipluscode.sakura.ne.jp/gdip/dragndroppicture.html

記憶が曖昧ですが64bit版でも手直しすれば確か動いたと思います。
（名無し） 2018/12/11(火) 16:41

 エクセルに拘らないのなら、HTAという方法もあります。

 参考まで。
https://ameblo.jp/jackleman/entry-10888787227.html

 ※Excel：Excel2013、使用 OS：Windows10 の環境で使えるかは
 未検証です。
（カリーニン） 2018/12/11(火) 17:40

 ↑はJscriptですが、VBscriptに作り替えたものを家のパソコン
 で使っています。今外出中なので、どういうコードだったかはわか
 りません。
（カリーニン） 2018/12/11(火) 18:06

???さん >>
それができたら苦労しないというやつなのです。

名無しさん >>
さすがにExcel巻き込んで大☆爆☆発するような
爆弾は仕込めないので挑戦はやめておきます。

カリーニンさん >>
HTAからExcelに返値するやり方がぱっと見で見つけられなかったので
VBScriptで何とかする方向で考えてみます。

ALL >>
回答ありがとうございました。
最終的にはワークシート上に表示させる必要があるのでVBAからは脱却できませんが、
「VBSを使って～」のような他の方法を知っている方がいればアドバイス御願いします。
（ぷー） 2018/12/12(水) 09:07

おはようございます。

64bit版のExcelを使っていないので確認がとれず、はずす可能性が大ですが。。

フォームにWebBrowserコントロールを配置するのはどうでしょうか？
64bit版のエクセルでListView・TreeViewが使えない！という記事は
目にした事がありますが、WebBrowerコントロールが使えなくなったという記事を
自分は見かけていません(^^)

WebBrowerコントロールはListView同様にDrag&Dropを受け付けます。
ファイルをWebBrowerにDrag&Dropすると
BeforeNavigate2イベントが発生します。
そのURLにドロップされたファイルパスが格納されているので後は煮るなり焼くなりですね(^^)

Private Sub WebBrowser1_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)

    Debug.Print URL
    Cancel = True '' CancelをTrueにしないとWebBrower上でそのファイルは開かれてしまいます。
End Sub

もしDrag&DropをしようとWebBrowser上にマウスを持っていった時に
禁止マークのままならこちらのページが参考になると思います。
http://pasofaq.jp/program/internetexplorer/ie7protectionmode.htm
但し、これはセキュリティ上問題があるということであれば
この手は使えないかもしれませんね^^;

こちらで確認出来ていない話で申し訳ありませんが
トライする価値はあるかな？と思います。
（みそじのおじさん） 2018/12/12(水) 09:23

 WebBrowserコントロールをEXCEL2013で使おうとする場合、以下の問題があるようだ。

https://support.microsoft.com/ja-jp/help/2793374/cannot-insert-certain-scriptable-activex-ontrols-into-office-2013-doc
（ねむねむ） 2018/12/12(水) 09:36

今のOfficeをアンインストールして、32bit版をインストールし直す訳にはいかないのですかね？ 64bitOS下でも32bit版Officeは普通に動きますし、むしろMSの推奨は32bit版だったりします。（64bit版を作ったのは良いが、どうやっても安定性が低いため、32bit推奨したらしいですが、2016になっても同じでしたし、2019はほぼ2016なので変わらないでしょうし、OS側の根本に関わる問題なのでしょう）

頑張ってコントロール側をどうにかしても安定性が悪いなら意味ないですし、誰でも安心して使えるようにするには、今はこれが最善だと思いますよ。
（???） 2018/12/12(水) 09:43

私が提案した方法は、家で試したところダメでした。
前使っていたパソコンにはVBがインストールされていたのか
VBscriptに置き換えたコードが使えましたが、
今使っているパソコンは買い換えて間もないので
環境整備が進んでなくVBはインストールして
いません。そのためだと思いますが、前のパソコン
のコードをそのまま使ってもダメでした。
どのようにダメだったかは今また外出中で覚えてません。
参考にならなくてすみません。
（カリーニン） 2018/12/12(水) 10:20

 Excel関係なくなるけど、VBSでファイル作ってそのファイルにD&Dしてクリップボードにパス入れる。ってのはダメかな？
 自分がその方法なんだけどね。

http://logicalerror.seesaa.net/article/118290363.html

 このリンク先は右クリックして出てくるメニューの「送る」に入れる方法だけど、記載されているVBSファイルにD&Dしても、パスはコピーできるよ。

 ま、参考になれば。

（1111） 2018/12/12(水) 11:21

 Drag&DropのキーパーツはIDropTargetです。

 IDropTargetは呼ばれるだけなので、こちらから反応する仕組みを用意する必要がありますが。
 ユーザーフォームに付属するWindowをRegisterDragDrop関数で登録しておき、
 あとはDropされた時点でファイル名を取得することです。

 時間をみてソースを提示したいと思います。
（Abyss） 2018/12/12(水) 17:35

 では、ソースです。
 とりあえず、32bit版＆64bit版に対応したつもりです。

 （標準モジュール） IDropTarget interfaceとして使用
 '--------------------------------------------------------------------
 Public Type TDragDrop
     pfn As LongPtr
     fn(6) As LongPtr
     rt(3) As Long
     hClient As LongPtr
     ctl As IControl
 End Type

 Private Const E_NOTIMPL = &H80004001
 Private Const E_NOINTERFACE = &H80004002
 Private Const GA_ROOT = 2&
 Private Const GW_CHILD = 5&

 #If Win64 Then
 Private Const PTR_GAP = 8&
 Private Declare PtrSafe Function PtInRect& Lib "User32" _
     (ByVal lprc As LongPtr, _
      ByVal pt As LongPtr)
 #Else
 Private Const PTR_GAP = 4&
 Private Declare PtrSafe Function PtInRect& Lib "User32" _
     (ByVal lprc As LongPtr, _
      ByVal ptX As Long, ByVal ptY As Long)
 #End If

 Private Declare PtrSafe Sub MoveMemory Lib "Kernel32" Alias "RtlMoveMemory" _
     (Destination As Any, _
      Source As Any, _
      Optional ByVal Length As Long = PTR_GAP)
 Private Declare PtrSafe Function RegisterDragDrop& Lib "Ole32" _
     (ByVal Hwnd As LongPtr, _
      ByVal pDropTarget As LongPtr)
 Private Declare PtrSafe Function RevokeDragDrop& Lib "Ole32" _
     (ByVal Hwnd As LongPtr)
 Private Declare PtrSafe Function SHGetIDListFromObject& Lib "Shell32" _
     (ByVal pUnk As LongPtr, _
      ByRef ppidl As LongPtr)
 Private Declare PtrSafe Function SHGetPathFromIDListW& Lib "Shell32" _
     (ByVal pidl As LongPtr, _
      ByVal pszPath As LongPtr)
 Private Declare PtrSafe Function IUnknown_GetWindow& Lib "Shlwapi" Alias "#172" _
     (ByVal pUnk As LongPtr, _
      ByRef phwnd As LongPtr)
 Private Declare PtrSafe Function GetAncestor Lib "User32" _
     (ByVal Hwnd As LongPtr, _
      ByVal gaFlags As Long) As LongPtr
 Private Declare PtrSafe Function GetWindow Lib "User32" _
     (ByVal Hwnd As LongPtr, _
      ByVal uCmd As Long) As LongPtr

 Public Sub InitDragDrop(This As TDragDrop, ByVal ctl As IControl)
     Dim buf As Object

     With This
         'IDropTarget Interface自作
         .pfn = VarPtr(.fn(0))
         MoveMemory .fn(0), AddressOf QI
         MoveMemory .fn(1), AddressOf AR
         .fn(2) = .fn(1)
         MoveMemory .fn(3), AddressOf DragEnter
         MoveMemory .fn(4), AddressOf DragOver
         MoveMemory .fn(5), AddressOf DragLeave
         MoveMemory .fn(6), AddressOf Drop

         Set .ctl = ctl: Set buf = ctl

         Do
             IUnknown_GetWindow ObjPtr(buf), .hClient
             If .hClient Then Exit Do
             Set buf = buf.Parent
         Loop

         If GetAncestor(.hClient, GA_ROOT) = .hClient Then
             .hClient = GetWindow(.hClient, GW_CHILD)
         End If

         RegisterDragDrop .hClient, VarPtr(.pfn)

     End With

 End Sub

 Public Sub TerminateDragDrop(This As TDragDrop)
     With This
         If .hClient = 0 Then Exit Sub
         RevokeDragDrop .hClient
     End With

 End Sub

 Private Function QI&(ByVal pThis As LongPtr, _
                      ByVal riid As LongPtr, _
                      ByRef pObj As LongPtr)
     'このメソッドは呼ばれない
     QI = E_NOINTERFACE
 End Function

 Private Function AR&(ByVal pThis As LongPtr)
     '呼ばれるため必要
 End Function

 #If Win64 Then
 Private Function DragEnter&(This As TDragDrop, _
                             ByVal pDataObj As LongPtr, _
                             ByVal grfKeyState As Long, _
                             ByVal pt As LongPtr, _
                             ByRef pdwEffect As Long)
 #Else
 Private Function DragEnter&(This As TDragDrop, _
                             ByVal pDataObj As LongPtr, _
                             ByVal dummy As Variant)
 #End If
     Dim acc As IAccessible
     With This
         Set acc = .ctl
         acc.accLocation .rt(0), .rt(1), .rt(2), .rt(3)
         .rt(2) = .rt(2) + .rt(0)
         .rt(3) = .rt(3) + .rt(1)
     End With

 End Function

 #If Win64 Then
 Private Function DragOver&(This As TDragDrop, _
                            ByVal grfKeyState As Long, _
                            ByVal pt As LongPtr, _
                            ByRef pdwEffect As Long)
     If PtInRect(VarPtr(This.rt(0)), pt) = 0 Then
         DragOver = E_NOTIMPL
     End If

 End Function
 #Else
 Private Function DragOver&(This As TDragDrop, _
                            ByVal grfKeyState As Long, _
                            ByVal ptX As Long, _
                            ByVal ptY As Long, _
                            ByRef pdwEffect As Long)
     If PtInRect(VarPtr(This.rt(0)), ptX, ptY) = 0 Then
         DragOver = E_NOTIMPL
     End If

 End Function
 #End If

 Private Function DragLeave&(ByVal pThis As LongPtr)
     DragLeave = E_NOTIMPL
 End Function

 #If Win64 Then
 Private Function Drop&(This As TDragDrop, _
                        ByVal pDataObj As LongPtr, _
                        ByVal grfKeyState As Long, _
                        ByVal pt As LongPtr, _
                        ByRef pdwEffect As Long)
 #Else
 Private Function Drop&(This As TDragDrop, _
                        ByVal pDataObj As LongPtr, _
                        ByVal grfKeyState As Long, _
                        ByVal ptX As Long, _
                        ByVal ptY As Long, _
                        ByRef pdwEffect As Long)
 #End If

     Dim pidl As LongPtr, buf$, hr&

     hr = SHGetIDListFromObject(pDataObj, pidl)
     If hr < 0 Then
         buf = "$(error)"
     Else
         buf = String$(256, 0)
         If SHGetPathFromIDListW(pidl, StrPtr(buf)) Then
             buf = VBA.Left$(buf, VBA.InStr(buf, vbNullChar))
         Else
             buf = vbNullString
         End If
     End If

     This.ctl.Text = buf

 End Function
 '--------------------------------------------------------------------

 使用方法
 UserformにTextBox1を設置し、下記ソースをFormモジュールに記載 
 何らかのファイルをTextBoxにDragDropしてみてください。

 （Userformモジュール）

 Private mm As TDragDrop

 Private Sub UserForm_Initialize()
     InitDragDrop mm, TextBox1
 End Sub

 Private Sub UserForm_Terminate()
     TerminateDragDrop mm
 End Sub 
（ Abyss） 2018/12/13(木) 14:18

みなさん、色々な回答・解決策ありがとうございました。

Abyssさん貴重なコードありがとうございます。試してみます。

とりあえず、解決ということでスレを一旦〆させてもらいます。
（ぷー） 2018/12/17(月) 10:18

コメント返信：

[ 一覧(最新更新順) ]

[[20181211140007]] 『64bitExcelでフォームにD&Dしたファイルパスの取刀x（ぷー） ページの最後に飛ぶ

[[20181211140007]]　『64bitExcelでフォームにD&Dしたファイルパスの取刀x（ぷー）　ページの最後に飛ぶ