OLE D&D

メッセージ

しーぷ

OLE D&Dでエクスプローラ等とファイルのやり取りをやってみたいと、
いろいろと調べたのですが、ほとんど理解できなかったので質問させていただきます。

この記事のおかげでD&Dのドロップ（ファイルの受け取り）の部分は実現できましたが、ドラッグ（ファイルの受け渡し）の部分がさっぱりできません。

まず、イグトランスさんがどうやってIDropTargetを実装しているのかコードをみても何をやっているのかまったく分からなかったのですが、無理やり自分なりにIDropSourceを実装してみました。次に、このページを参考に実際に書いてみましたがアクセス違反が起こってしまいます。

なぜアクセス違反になってしまうのでしょうか？それともうひとつ質問ですが、前記のCでの実装のページで使われている、実際にドラッグを開始すると思われるDoDrugDropですが、これは一体何者ですか？

以下にコード（ほぼ前述の記事のパクリですが…）を載せます。
なにか分かる方がいらっしゃればアドバイスよろしくお願いします。

OleDragDropImpl.sbp

[ここをクリックすると内容が表示されます]

Class DropTargetImpl
Inherits DropTargetImplThunk
Public
Sub DropTargetImpl(hwndTarget As HWND)
refCount = 0
hwnd = hwndTarget
End Sub

Function QueryInterface(ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
QueryInterface = S_OK
If IsEqualIID(iid, IID_IUnknown) <> FALSE Then
ppvObj[0] = VarPtr (This) As *IUnknown
AddRef()
ElseIf IsEqualIID(iid, IID_IDropTarget) <> FALSE Then
ppvObj[0] = VarPtr (This) As *IDropTarget
AddRef()
Else
ppvObj[0] = 0
QueryInterface = E_NOINTERFACE
End If
End Function

Function AddRef() As ULONG
refCount++
AddRef = refCount
End Function

Function Release() As ULONG
refCount--
Release = refCount
If refCount = 0 Then
Delete VarPtr(This)
End If
End Function

Function DragEnter(
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT
DragEnter = S_OK
End Function

Function DragOver(
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT
DragOver = S_OK
End Function

Function DragLeave() As HRESULT
DragLeave = S_OK
End Function

Function Drop(
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord _
) As HRESULT
Dim fData As Long
fData = FALSE

Dim fe As FORMATETC
Dim medium As STGMEDIUM
Dim hglMem As HGLOBAL

With fe
.cfFormat = CF_HDROP
.ptd = 0
.dwAspect = DVASPECT_CONTENT
.lindex = -1
.tymed = TYMED_HGLOBAL
End With
'ファイルドロップ
If( pDataObj->GetData(fe, medium) = S_OK )Then
hglMem = medium.data As HGLOBAL
Dim file[MAX_PATH] As Byte
DragQueryFile( GlobalLock(hglMem), 0, file, MAX_PATH )
GlobalUnlock(medium.data)
ReleaseStgMedium(medium)
MessageBox( hMainWnd, file, "",MB_OK)
effect = DROPEFFECT_COPY
fData = TRUE
End If
'それ以外
If( fData=FALSE )Then
effect = DROPEFFECT_NONE
End If
Drop = S_OK
End Function
Private
refCount As ULONG
hwnd As HWND
End Class

Class DropSourceImpl
Inherits DropSourceImplThunk
Public
Sub DropSourceImpl(hwndSource As HWND)
refCount = 0
hwnd = hwndSource
End Sub

Function QueryInterface(ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
QueryInterface = S_OK
If IsEqualIID(iid, IID_IUnknown) <> FALSE Then
ppvObj[0] = VarPtr (This) As *IUnknown
AddRef()
ElseIf IsEqualIID(iid, IID_IDropTarget) <> FALSE Then
ppvObj[0] = VarPtr (This) As *IDropTarget
AddRef()
Else
ppvObj[0] = 0
QueryInterface = E_NOINTERFACE
End If
End Function

Function AddRef() As ULONG
refCount++
AddRef = refCount
End Function

Function Release() As ULONG
refCount--
Release = refCount
If refCount = 0 Then
Delete VarPtr(This)
End If
End Function

Function QueryContinueDrag(
ByVal fEscapePressed As DWord,
ByVal grfKeyState As DWord) As HRESULT
QueryContinueDrag = S_OK
/* ESCキーが押されたらD&Dキャンセル */
If fEscapePressed Then
MessageBox(0, "キャンセル", "", MB_OK)
QueryContinueDrag = DRAGDROP_S_CANCEL
/* マウスボタンが離されたらD&D完了 */
Elseif (grfKeyState And (MK_LBUTTON or MK_RBUTTON)) Then
MessageBox(0, "完了", "", MB_OK)
QueryContinueDrag = S_OK
Endif
EndFunction

Function GiveFeedback(
ByVal dwEffect As DWord) As HRESULT
GiveFeedback = DRAGDROP_S_USEDEFAULTCURSORS
EndFunction

Private
refCount As ULONG
hwnd As HWND
End Class

OleDragDropInterface.sbp

[ここをクリックすると内容が表示されます]

TypeDef BOOL = Long
TypeDef HRESULT = Long
TypeDef ULONG = DWord
TypeDef IID = GUID
TypeDef CLSID = GUID
TypeDef CLIPFORMAT = Word

Type DROPFILES
pFiles As DWord
pt As POINTAPI
fNC As BOOL
fWid As BOOL
End Type

Dim IID_IUnknown = [0, 0, 0, [&hC0, 0, 0, 0, 0, 0, 0, &h46]] As IID
Dim IID_IDataObject = [&h0000010e, 0, 0, [&hC0, 0, 0, 0, 0, 0, 0, &h46]] As IID
Dim IID_IDropTarget = [&h00000122, 0, 0, [&hC0, 0, 0, 0, 0, 0, 0, &h46]] As IID
Dim IID_IDropSource = [&h00000121, 0, 0, [&hC0, 0, 0, 0, 0, 0, 0, &h46]] As IID
Const DRAGDROP_S_CANCEL = &h00040101L
Const DRAGDROP_S_USEDEFAULTCURSORS = &h00040102L

Declare Function OleInitialize Lib "Ole32" (reserved As VoidPtr) As HRESULT
Declare Sub OleUninitialize Lib "Ole32" ()
Declare Function IsEqualGUID Lib "Ole32" (ByRef guid1 As GUID, ByRef guid2 As GUID) As BOOL
Declare Function IsEqualCLSID Lib "Ole32" Alias "IsEqualGUID" (ByRef clsid1 As CLSID, ByRef clsid2 As CLSID) As BOOL
Declare Function IsEqualIID Lib "Ole32" Alias "IsEqualGUID" (ByRef iid1 As IID, ByRef iid2 As IID) As BOOL

Function egtraOleInitialize() HRESULT
OleInitialize(0)
End Function

Declare Function RegisterDragDrop Lib "Ole32" (
hwnd As HWND,
pDropTarget As *IDropTarget _
) As HRESULT

Declare Function RevokeDragDrop Lib "Ole32" (
hwnd As HWND _
) As HRESULT

Declare Sub ReleaseStgMedium Lib "OLE32" (ByRef rmedium As STGMEDIUM)

Type FORMATETC
cfFormat As CLIPFORMAT
ptd As *DVTARGETDEVICE
dwAspect As DWord
lindex As Long
tymed As DWord
End Type

Type STGMEDIUM
tymed As DWord
data As VoidPtr
hGlobal As HGLOBAL
' C/C++では次のような共用体
/* [switch_type(DWORD), switch_is((DWORD) tymed)]
union {
[case(TYMED_GDI)] HBITMAP hBitmap;
[case(TYMED_MFPICT)] HMETAFILEPICT hMetaFilePict;
[case(TYMED_ENHMF)] HENHMETAFILE hEnhMetaFile;
[case(TYMED_HGLOBAL)] HGLOBAL hGlobal;
[case(TYMED_FILE)] LPWSTR lpszFileName;
[case(TYMED_ISTREAM)] IStream *pstm;
[case(TYMED_ISTORAGE)] IStorage *pstg;
[default] ;
};
*/
/*[unique]*/ pUnkForRelease As *IUnknown
End Type

Type DVTARGETDEVICE
tdSize As DWord
tdDriverNameOffset As Word
tdDeviceNameOffset As Word
tdPortNameOffset As Word
tdExtDevmodeOffset As Word
tdData[ELM(1)] As Byte
End Type

Class IDataObject
Inherits IUnknown
Public
Virtual Function /* [local] */ GetData(
/* [unique][in] */ ByRef rformatetcIn As FORMATETC,
/* [out] */ ByRef rmedium As STGMEDIUM _
) As HRESULT

Virtual Function /* [local] */ GetDataHere(
/* [unique][in] */ ByRef rformatetcIn As FORMATETC,
/* [out] */ ByRef pmedium As STGMEDIUM _
) As HRESULT

Virtual Function QueryGetData(
/* [unique][in] */ ByRef pformatetc As FORMATETC _
) As HRESULT

Virtual Function GetCanonicalFormatEtc(
/* [unique][in] */ ByRef pformatetcIn As FORMATETC,
/* [out] */ ByRef pmedium As STGMEDIUM _
) As HRESULT

Virtual Function /* [local] */ SetData(
/* [unique][in] */ByRef pformatetcIn As FORMATETC,
/* [out] */ByRef pmedium As STGMEDIUM,
/* [in] */ fRelease As BOOL _
) As HRESULT

Virtual Function EnumFormatEtc(
/* [in] */ ByVal dwDirection As DWord,
/* [out] */ ByRef rpenumFormatEtc As *IEnumFORMATETC _
) As HRESULT

Virtual Function DAdvise(
/* [in] */ ByRef pformatetc As FORMATETC,
/* [in] */ ByVal advf As DWORD,
/* [unique][in] */ ByVal pAdvSink As *IAdviseSink,
/* [out] */ ByVal pdwConnection As *DWord _
) As HRESULT

Virtual Function DUnadvise(
/* [in] */ ByVal dwConnection As DWord _
) As HRESULT

Virtual Function EnumDAdvise(
/* [out] */ ByRef rpenumAdvise As *IEnumSTATDATA _
) As HRESULT
End Class

Class IDropTarget
Inherits IUnknown
Public
Virtual Function DragEnter(
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

Virtual Function DragOver(
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

Virtual Function DragLeave() As HRESULT

Virtual Function Drop(
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT
End Class

Class IDropSource
Inherits IUnknown
Public
Virtual Function QueryContinueDrag(
ByVal fEscapePressed As DWord,
ByVal grfKeyState As DWord) As HRESULT

Virtual Function GiveFeedback(
ByVal dwEffect As DWord) As HRESULT
End Class

Class IAdviseSink
Inherits IUnknown
End Class

Class IEnumSTATDATA
Inherits IUnknown
End Class

Class IEnumFORMATETC
Inherits IUnknown
End Class

Enum DROPEFFECT
DROPEFFECT_NONE = 0
DROPEFFECT_COPY = 1
DROPEFFECT_MOVE = 2
DROPEFFECT_LINK = 4
DROPEFFECT_SCROLL = &h80000000
End Enum

Enum /*[transmit_as(long)]*/ TYMED
TYMED_HGLOBAL = 1
TYMED_FILE = 2
TYMED_ISTREAM = 4
TYMED_ISTORAGE = 8
TYMED_GDI = 16
TYMED_MFPICT = 32
TYMED_ENHMF = 64
TYMED_NULL = 0
End Enum

Enum DVASPECT
DVASPECT_CONTENT = 1
DVASPECT_THUMBNAIL = 2
DVASPECT_ICON = 4
DVASPECT_DOCPRINT = 8
End Enum

OleDragDropThunk.sbp

[ここをクリックすると内容が表示されます]

Class IUnknownVTable
Public
QueryInterface As *Function(ByRef thunk As IUnknown, ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
AddRef As *Function(ByRef thunk As IUnknown) As ULONG
Release As *Function(ByRef thunk As IUnknown) As ULONG
End Class

Class IDropTargetVTable
Inherits IUnknownVTable
Public
DragEnter As *Function(
ByRef thunk As DropTargetImpl,
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

DragOver As *Function(
ByRef thunk As DropTargetImpl,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

DragLeave As *Function(ByRef thunk As DropTargetImpl) As HRESULT

Drop As *Function(
ByRef thunk As DropTargetImpl,
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT
End Class

Class DropTargetImplThunk
Public
vtable As *IDropTargetVTable
End Class

Function IUnknownThunk_QueryInterface(ByRef unk As DropTargetImpl, ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
IUnknownThunk_QueryInterface = unk.QueryInterface(iid, ppvObj)
End Function

Function IUnknownThunk_AddRef(ByRef unk As DropTargetImpl) As ULONG
IUnknownThunk_AddRef = unk.AddRef()
End Function

Function IUnknownThunk_Release(ByRef unk As DropTargetImpl) As ULONG
Dim vtable As *IDropTargetVTable
vtable = unk.vtable
IUnknownThunk_Release = unk.Release()
If IUnknownThunk_Release = 0 Then
Delete vtable
End If
End Function

Function IDropTargetThunk_DragEnter(
ByRef thunk As DropTargetImpl,
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

IDropTargetThunk_DragEnter = thunk.DragEnter(pDataObj, grfKeyState, x, y, effect)
End Function

Function IDropTargetThunk_DragOver(
ByRef thunk As DropTargetImpl,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

IDropTargetThunk_DragOver = thunk.DragOver(grfKeyState, x, y, effect)
End Function

Function IDropTargetThunk_DragLeave(ByRef thunk As DropTargetImpl) As HRESULT
IDropTargetThunk_DragLeave = thunk.DragLeave()
End Function

Function IDropTargetThunk_Drop(
ByRef thunk As DropTargetImpl,
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

IDropTargetThunk_Drop = thunk.Drop(pDataObj, grfKeyState, x, y, effect)
End Function

Function CreateDropTargetImpl(hwnd As HWND, ByRef iid As IID, ByVal ppv As *VoidPtr) As HRESULT
CreateDropTargetImpl = E_OUTOFMEMORY
Dim punk As *DropTargetImpl
punk = New DropTargetImpl(hwnd)
If punk = 0 Then Exit Function

punk->vtable = New IDropTargetVTable
If punk->vtable = 0 Then Exit Function
With punk->vtable[0]
.QueryInterface = AddressOf (IUnknownThunk_QueryInterface)
.AddRef = AddressOf (IUnknownThunk_AddRef)
.Release = AddressOf (IUnknownThunk_Release)
.DragEnter = AddressOf (IDropTargetThunk_DragEnter)
.DragOver = AddressOf (IDropTargetThunk_DragOver)
.DragLeave = AddressOf (IDropTargetThunk_DragLeave)
.Drop = AddressOf (IDropTargetThunk_Drop)
End With

CreateDropTargetImpl = punk->QueryInterface(iid, ppv)

If CreateDropTargetImpl <> S_OK Then
CreateDropTargetImpl = 0
Delete punk
End If
End Function

Class IDropSourceVTable
Inherits IUnknownVTable
Public
QueryContinueDrag As *Function(
ByRef thunk As DropSourceImpl,
ByVal fEscapePressed As DWord,
ByVal grfKeyState As DWord) As HRESULT

GiveFeedback As *Function(
ByRef thunk As DropSourceImpl,
ByVal dwEffect As DWord) As HRESULT
End Class

Class DropSourceImplThunk
Public
vtable As *IDropSourceVTable
End Class

Function IDropSourceThunk_QueryContinueDrag(
ByRef thunk As DropSourceImpl,
ByVal fEscapePressed As DWord,
ByVal grfKeyState As DWord) As HRESULT
IDropSourceThunk_QueryContinueDrag = thunk.QueryContinueDrag(fEscapePressed, grfKeyState)
End Function

Function IDropSourceThunk_GiveFeedback(
ByRef thunk As DropSourceImpl,
ByVal dwEffect As DWord) As HRESULT
IDropSourceThunk_GiveFeedback = thunk.GiveFeedback(dwEffect)
EndFunction

Function CreateDropSourceImpl(hwnd As HWND, ByRef iid As IID, ByVal ppv As *VoidPtr) As HRESULT
CreateDropSourceImpl = E_OUTOFMEMORY
Dim punk As *DropSourceImpl
punk = New DropSourceImpl(hwnd)
If punk = 0 Then Exit Function

punk->vtable = New IDropSourceVTable
If punk->vtable = 0 Then Exit Function
With punk->vtable[0]
.QueryInterface = AddressOf (IUnknownThunk_QueryInterface)
.AddRef = AddressOf (IUnknownThunk_AddRef)
.Release = AddressOf (IUnknownThunk_Release)
.QueryContinueDrag = AddressOf (IDropSourceThunk_QueryContinueDrag)
.GiveFeedback = AddressOf (IDropSourceThunk_GiveFeedback)
End With

CreateDropSourceImpl = punk->QueryInterface(iid, ppv)

If CreateDropSourceImpl <> S_OK Then
CreateDropSourceImpl = 0
Delete punk
End If
End Function

MainWnd.sbp内

[ここをクリックすると内容が表示されます]

[/hide]

お疲れ様です。ところでAB5ではどうやらThunk処理が不要になり，その分コードが簡素化しそうです，CP4ではまだでしたが。

とりあえずlpDataObjが変数宣言しただけで実体が（Newで）作られていないから落ちるのです。事実上ドラッグを開始する側はIDropSourceだけでなく，IDataObjectも実装する必要があります。

DoDragDropは，確かにドラッグ＆ドロップを開始させる関数です。OLEシステムにドラッグ＆ドロップを依頼すると言えば良いのかもしれません。

この関数を呼ぶと，以後OLEシステムがマウスの動きを捕捉して，通り過ぎるウィンドウに対してマウスが通っていると通知を出します。そして最後にボタンが離されたときにマウスポインタの背後にあったウィンドウへドロップされたという通知を出します。通知と言いましたが，これはウィンドウに関連付けられた（RegisterDragDropされた）IDropTargetのメソッドをOLEシステムが呼び出すという形で実現されています。

しーぷ

ご指摘ありがとうございます。

> とりあえずlpDataObjが変数宣言しただけで実体が（Newで）作られていないから落ちるのです。事実上ドラッグを開始する側はIDropSourceだけでなく，IDataObjectも実装する必要があります。

ということなのでIDropSourceと同様に無理やりIDataObjectも実装しようと、このページを参照しながら試みたのですがCのことがよく分からず（特に演算子）ABに移植することができませんでした。
しかも今の時点でコードを実行しようとするとコンパイラごと落ちてしまいました…。

またコードをすべて載せます。お手数ですが、IDataObjectの実装の方法（というかIDropTargetも自信ないのですが…）・Cからの移植方法等をご教示ください。よろしくお願いします。

OleDragDropImpl.abp

[ここをクリックすると内容が表示されます]

Class DropTargetImpl
Inherits DropTargetImplThunk
Public
Sub DropTargetImpl(hwndTarget As HWND)
refCount = 0
hwnd = hwndTarget
End Sub

Function QueryInterface(ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
QueryInterface = S_OK
If IsEqualIID(iid, IID_IUnknown) <> FALSE Then
ppvObj[0] = VarPtr (This) As *IUnknown
AddRef()
ElseIf IsEqualIID(iid, IID_IDropTarget) <> FALSE Then
ppvObj[0] = VarPtr (This) As *IDropTarget
AddRef()
Else
ppvObj[0] = 0
QueryInterface = E_NOINTERFACE
End If
End Function

Function AddRef() As ULONG
refCount++
AddRef = refCount
End Function

Function Release() As ULONG
refCount--
Release = refCount
If refCount = 0 Then
Delete VarPtr(This)
End If
End Function

Function DragEnter(
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT
DragEnter = S_OK
End Function

Function DragOver(
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT
DragOver = S_OK
End Function

Function DragLeave() As HRESULT
DragLeave = S_OK
End Function

Function Drop(
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord _
) As HRESULT
Dim fData As Long
fData = FALSE

Dim fe As FORMATETC
Dim medium As STGMEDIUM
Dim hglMem As HGLOBAL

With fe
.cfFormat = CF_HDROP
.ptd = 0
.dwAspect = DVASPECT_CONTENT
.lindex = -1
.tymed = TYMED_HGLOBAL
End With
'ファイルドロップ
If( pDataObj->GetData(fe, medium) = S_OK )Then
hglMem = medium.data As HGLOBAL
Dim file[MAX_PATH] As Byte
DragQueryFile( GlobalLock(hglMem), 0, file, MAX_PATH )
GlobalUnlock(medium.data)
ReleaseStgMedium(medium)
MessageBox( hMainWnd, file, "",MB_OK)
effect = DROPEFFECT_COPY
fData = TRUE
End If
'それ以外
If( fData=FALSE )Then
effect = DROPEFFECT_NONE
End If
Drop = S_OK
End Function
Private
refCount As ULONG
hwnd As HWND
End Class

Class DropSourceImpl
Inherits DropSourceImplThunk
Public
Sub DropSourceImpl(hwndSource As HWND)
refCount = 0
hwnd = hwndSource
End Sub

Function QueryInterface(ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
QueryInterface = S_OK
If IsEqualIID(iid, IID_IUnknown) <> FALSE Then
ppvObj[0] = VarPtr (This) As *IUnknown
AddRef()
ElseIf IsEqualIID(iid, IID_IDropTarget) <> FALSE Then
ppvObj[0] = VarPtr (This) As *IDropTarget
AddRef()
Else
ppvObj[0] = 0
QueryInterface = E_NOINTERFACE
End If
End Function

Function AddRef() As ULONG
refCount++
AddRef = refCount
End Function

Function Release() As ULONG
refCount--
Release = refCount
If refCount = 0 Then
Delete VarPtr(This)
End If
End Function

Function QueryContinueDrag(
ByVal fEscapePressed As DWord,
ByVal grfKeyState As DWord) As HRESULT
QueryContinueDrag = S_OK
/* ESCキーが押されたらD&Dキャンセル */
If fEscapePressed Then
MessageBox(0, "キャンセル", "", MB_OK)
QueryContinueDrag = DRAGDROP_S_CANCEL
/* マウスボタンが離されたらD&D完了 */
Elseif (grfKeyState And (MK_LBUTTON or MK_RBUTTON)) Then
MessageBox(0, "完了", "", MB_OK)
QueryContinueDrag = S_OK
Endif
EndFunction

Function GiveFeedback(
ByVal dwEffect As DWord) As HRESULT
GiveFeedback = DRAGDROP_S_USEDEFAULTCURSORS
EndFunction

Private
refCount As ULONG
hwnd As HWND
End Class

Class DataObjectImpl
Inherits DataObjectImplThunk
Public
Sub DataObjectImpl(hwndSource As HWND)
refCount = 0
hwnd = hwndSource
End Sub

Function QueryInterface(ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
QueryInterface = S_OK
If IsEqualIID(iid, IID_IUnknown) <> FALSE Then
ppvObj[0] = VarPtr (This) As *IUnknown
AddRef()
ElseIf IsEqualIID(iid, IID_IDropTarget) <> FALSE Then
ppvObj[0] = VarPtr (This) As *IDropTarget
AddRef()
Else
ppvObj[0] = 0
QueryInterface = E_NOINTERFACE
End If
End Function

Function AddRef() As ULONG
refCount++
AddRef = refCount
End Function

Function Release() As ULONG
refCount--
Release = refCount
If refCount = 0 Then
Delete VarPtr(This)
End If
End Function

Function GetData(ByRef rformatetcIn As FORMATETC, ByRef pmedium As STGMEDIUM) As HRESULT
/*
int i;

if(pFormatetc == NULL || pmedium == NULL){
return E_INVALIDARG;
}

if (!(DVASPECT_CONTENT & pFormatetc->dwAspect)) return DV_E_DVASPECT;

for(i = 0; i < _num; ++i){
if(_Objects.fmt.cfFormat == pFormatetc->cfFormat &&
(_Objects.fmt.tymed & pFormatetc->tymed) != 0){
if(CSTGMEDIUM::Dup(pmedium, &_Objects.fmt, &_Objects.medium) == FALSE){
return E_OUTOFMEMORY;
}
return S_OK;
}
}

return DV_E_FORMATETC;
*/
End Function

Function QueryGetData(ByRef pformatetc As FORMATETC) As HRESULT
/*
int i;

if(pFormatetc == NULL){
return E_INVALIDARG;
}

if (!(DVASPECT_CONTENT & pFormatetc->dwAspect)) return DV_E_DVASPECT;

for(i = 0; i < _num; ++i){
if(_Objects.fmt.cfFormat == pFormatetc->cfFormat &&
(_Objects.fmt.tymed & pFormatetc->tymed) != 0){
return S_OK;
}
}

return DV_E_FORMATETC;*/
End Function

Function SetData(ByRef pformatetcIn As FORMATETC, ByRef pmedium As STGMEDIUM, fRelease As BOOL) As HRESULT
/*
if(pFormatetc == NULL || pmedium == NULL) return E_INVALIDARG;

if(_num >= _Objects.size()) return E_OUTOFMEMORY;

if(_Objects[_num].Set(pFormatetc, pmedium, fRelease) == FALSE) return E_OUTOFMEMORY;

_num++;

return S_OK;*/
End Function

Function EnumFormatEtc( ByVal dwDirection As DWord, ByRef rpenumFormatEtc As *IEnumFORMATETC) As HRESULT
/*
int i;
CEnumFORMATETC* pfmt;

if (ppenumFormatetc == NULL){
return E_INVALIDARG;
}

*ppenumFormatetc = NULL;
switch (dwDirection) {
case DATADIR_GET:
pfmt = new CEnumFORMATETC;
if(pfmt == NULL){
return E_OUTOFMEMORY;
}

if(!pfmt->allocate(_Objects.size())){
delete pfmt;
return E_OUTOFMEMORY;
}

for(i = 0; i < _num; ++i){
pfmt->SetFormat(&_Objects.fmt);
}
*ppenumFormatetc = pfmt;
break;
default:
return E_NOTIMPL;
}

return S_OK;*/
End Function
Private
refCount As ULONG
hwnd As HWND
End Class

OleDragDropInterface.abp

[ここをクリックすると内容が表示されます]

TypeDef BOOL = Long
TypeDef HRESULT = Long
TypeDef ULONG = DWord
TypeDef IID = GUID
TypeDef CLSID = GUID
TypeDef CLIPFORMAT = Word

Type DROPFILES
pFiles As DWord
pt As POINTAPI
fNC As BOOL
fWid As BOOL
End Type

Dim IID_IUnknown = [0, 0, 0, [&hC0, 0, 0, 0, 0, 0, 0, &h46]] As IID
Dim IID_IDataObject = [&h0000010e, 0, 0, [&hC0, 0, 0, 0, 0, 0, 0, &h46]] As IID
Dim IID_IDropTarget = [&h00000122, 0, 0, [&hC0, 0, 0, 0, 0, 0, 0, &h46]] As IID
Dim IID_IDropSource = [&h00000121, 0, 0, [&hC0, 0, 0, 0, 0, 0, 0, &h46]] As IID
Const DRAGDROP_S_CANCEL = &h00040101L
Const DRAGDROP_S_USEDEFAULTCURSORS = &h00040102L

Declare Function OleInitialize Lib "Ole32" (reserved As VoidPtr) As HRESULT
Declare Sub OleUninitialize Lib "Ole32" ()
Declare Function IsEqualGUID Lib "Ole32" (ByRef guid1 As GUID, ByRef guid2 As GUID) As BOOL
Declare Function IsEqualCLSID Lib "Ole32" Alias "IsEqualGUID" (ByRef clsid1 As CLSID, ByRef clsid2 As CLSID) As BOOL
Declare Function IsEqualIID Lib "Ole32" Alias "IsEqualGUID" (ByRef iid1 As IID, ByRef iid2 As IID) As BOOL
Declare Function DoDragDrop Lib "Ole32" Alias "DoDragDrop" (ByRef pDataObj As *IDataObject,ByRef pDropSource As *IDropSource, dwOKEffects As Dword, pdwEffect As DWord) As BOOL
Function egtraOleInitialize() HRESULT
OleInitialize(0)
End Function

Declare Function RegisterDragDrop Lib "Ole32" (
hwnd As HWND,
pDropTarget As *IDropTarget _
) As HRESULT

Declare Function RevokeDragDrop Lib "Ole32" (
hwnd As HWND _
) As HRESULT

Declare Sub ReleaseStgMedium Lib "OLE32" (ByRef rmedium As STGMEDIUM)

Type FORMATETC
cfFormat As CLIPFORMAT
ptd As *DVTARGETDEVICE
dwAspect As DWord
lindex As Long
tymed As DWord
End Type

Type STGMEDIUM
tymed As DWord
data As VoidPtr
hGlobal As HGLOBAL
' C/C++では次のような共用体
/* [switch_type(DWORD), switch_is((DWORD) tymed)]
union {
[case(TYMED_GDI)] HBITMAP hBitmap;
[case(TYMED_MFPICT)] HMETAFILEPICT hMetaFilePict;
[case(TYMED_ENHMF)] HENHMETAFILE hEnhMetaFile;
[case(TYMED_HGLOBAL)] HGLOBAL hGlobal;
[case(TYMED_FILE)] LPWSTR lpszFileName;
[case(TYMED_ISTREAM)] IStream *pstm;
[case(TYMED_ISTORAGE)] IStorage *pstg;
[default] ;
};
*/
/*[unique]*/ pUnkForRelease As *IUnknown
End Type

Type DVTARGETDEVICE
tdSize As DWord
tdDriverNameOffset As Word
tdDeviceNameOffset As Word
tdPortNameOffset As Word
tdExtDevmodeOffset As Word
tdData[ELM(1)] As Byte
End Type

Class IDataObject
Inherits IUnknown
Public
Virtual Function /* [local] */ GetData(
/* [unique][in] */ ByRef rformatetcIn As FORMATETC,
/* [out] */ ByRef rmedium As STGMEDIUM _
) As HRESULT

Virtual Function /* [local] */ GetDataHere(
/* [unique][in] */ ByRef rformatetcIn As FORMATETC,
/* [out] */ ByRef pmedium As STGMEDIUM _
) As HRESULT

Virtual Function QueryGetData(
/* [unique][in] */ ByRef pformatetc As FORMATETC _
) As HRESULT

Virtual Function GetCanonicalFormatEtc(
/* [unique][in] */ ByRef pformatetcIn As FORMATETC,
/* [out] */ ByRef pmedium As STGMEDIUM _
) As HRESULT

Virtual Function /* [local] */ SetData(
/* [unique][in] */ByRef pformatetcIn As FORMATETC,
/* [out] */ByRef pmedium As STGMEDIUM,
/* [in] */ fRelease As BOOL _
) As HRESULT

Virtual Function EnumFormatEtc(
/* [in] */ ByVal dwDirection As DWord,
/* [out] */ ByRef rpenumFormatEtc As *IEnumFORMATETC _
) As HRESULT

Virtual Function DAdvise(
/* [in] */ ByRef pformatetc As FORMATETC,
/* [in] */ ByVal advf As DWORD,
/* [unique][in] */ ByVal pAdvSink As *IAdviseSink,
/* [out] */ ByVal pdwConnection As *DWord _
) As HRESULT

Virtual Function DUnadvise(
/* [in] */ ByVal dwConnection As DWord _
) As HRESULT

Virtual Function EnumDAdvise(
/* [out] */ ByRef rpenumAdvise As *IEnumSTATDATA _
) As HRESULT
End Class

Class IDropTarget
Inherits IUnknown
Public
Virtual Function DragEnter(
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

Virtual Function DragOver(
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

Virtual Function DragLeave() As HRESULT

Virtual Function Drop(
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT
End Class

Class IDropSource
Inherits IUnknown
Public
Virtual Function QueryContinueDrag(
ByVal fEscapePressed As DWord,
ByVal grfKeyState As DWord) As HRESULT

Virtual Function GiveFeedback(
ByVal dwEffect As DWord) As HRESULT
End Class

Class IAdviseSink
Inherits IUnknown
End Class

Class IEnumSTATDATA
Inherits IUnknown
End Class

Class IEnumFORMATETC
Inherits IUnknown
End Class

Enum DROPEFFECT
DROPEFFECT_NONE = 0
DROPEFFECT_COPY = 1
DROPEFFECT_MOVE = 2
DROPEFFECT_LINK = 4
DROPEFFECT_SCROLL = &h80000000
End Enum

Enum /*[transmit_as(long)]*/ TYMED
TYMED_HGLOBAL = 1
TYMED_FILE = 2
TYMED_ISTREAM = 4
TYMED_ISTORAGE = 8
TYMED_GDI = 16
TYMED_MFPICT = 32
TYMED_ENHMF = 64
TYMED_NULL = 0
End Enum

Enum DVASPECT
DVASPECT_CONTENT = 1
DVASPECT_THUMBNAIL = 2
DVASPECT_ICON = 4
DVASPECT_DOCPRINT = 8
End Enum

OleDragDropThunk.abp

[ここをクリックすると内容が表示されます]

Class IUnknownVTable
Public
QueryInterface As *Function(ByRef thunk As IUnknown, ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
AddRef As *Function(ByRef thunk As IUnknown) As ULONG
Release As *Function(ByRef thunk As IUnknown) As ULONG
End Class

Class IDropTargetVTable
Inherits IUnknownVTable
Public
DragEnter As *Function(
ByRef thunk As DropTargetImpl,
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

DragOver As *Function(
ByRef thunk As DropTargetImpl,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

DragLeave As *Function(ByRef thunk As DropTargetImpl) As HRESULT

Drop As *Function(
ByRef thunk As DropTargetImpl,
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT
End Class

Class DropTargetImplThunk
Public
vtable As *IDropTargetVTable
End Class

Function IUnknownThunk_QueryInterface(ByRef unk As DropTargetImpl, ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
IUnknownThunk_QueryInterface = unk.QueryInterface(iid, ppvObj)
End Function

Function IUnknownThunk_AddRef(ByRef unk As DropTargetImpl) As ULONG
IUnknownThunk_AddRef = unk.AddRef()
End Function

Function IUnknownThunk_Release(ByRef unk As DropTargetImpl) As ULONG
Dim vtable As *IDropTargetVTable
vtable = unk.vtable
IUnknownThunk_Release = unk.Release()
If IUnknownThunk_Release = 0 Then
Delete vtable
End If
End Function

Function IDropTargetThunk_DragEnter(
ByRef thunk As DropTargetImpl,
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

IDropTargetThunk_DragEnter = thunk.DragEnter(pDataObj, grfKeyState, x, y, effect)
End Function

Function IDropTargetThunk_DragOver(
ByRef thunk As DropTargetImpl,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

IDropTargetThunk_DragOver = thunk.DragOver(grfKeyState, x, y, effect)
End Function

Function IDropTargetThunk_DragLeave(ByRef thunk As DropTargetImpl) As HRESULT
IDropTargetThunk_DragLeave = thunk.DragLeave()
End Function

Function IDropTargetThunk_Drop(
ByRef thunk As DropTargetImpl,
/* [unique][in] */ ByVal pDataObj As *IDataObject,
/* [in] */ ByVal grfKeyState As DWord,
/* [in] */ ByVal x As Long, ByVal y As Long,
/* [out][in] */ ByRef effect As DWord) As HRESULT

IDropTargetThunk_Drop = thunk.Drop(pDataObj, grfKeyState, x, y, effect)
End Function

Function CreateDropTargetImpl(hwnd As HWND, ByRef iid As IID, ByVal ppv As *VoidPtr) As HRESULT
CreateDropTargetImpl = E_OUTOFMEMORY
Dim punk As *DropTargetImpl
punk = New DropTargetImpl(hwnd)
If punk = 0 Then Exit Function

punk->vtable = New IDropTargetVTable
If punk->vtable = 0 Then Exit Function
With punk->vtable[0]
.QueryInterface = AddressOf (IUnknownThunk_QueryInterface)
.AddRef = AddressOf (IUnknownThunk_AddRef)
.Release = AddressOf (IUnknownThunk_Release)
.DragEnter = AddressOf (IDropTargetThunk_DragEnter)
.DragOver = AddressOf (IDropTargetThunk_DragOver)
.DragLeave = AddressOf (IDropTargetThunk_DragLeave)
.Drop = AddressOf (IDropTargetThunk_Drop)
End With

CreateDropTargetImpl = punk->QueryInterface(iid, ppv)

If CreateDropTargetImpl <> S_OK Then
CreateDropTargetImpl = 0
Delete punk
End If
End Function

Class IDropSourceVTable
Inherits IUnknownVTable
Public
QueryContinueDrag As *Function(
ByRef thunk As DropSourceImpl,
ByVal fEscapePressed As DWord,
ByVal grfKeyState As DWord) As HRESULT

GiveFeedback As *Function(
ByRef thunk As DropSourceImpl,
ByVal dwEffect As DWord) As HRESULT
End Class

Class DropSourceImplThunk
Public
vtable As *IDropSourceVTable
End Class

Function IDropSourceThunk_QueryContinueDrag(
ByRef thunk As DropSourceImpl,
ByVal fEscapePressed As DWord,
ByVal grfKeyState As DWord) As HRESULT
IDropSourceThunk_QueryContinueDrag = thunk.QueryContinueDrag(fEscapePressed, grfKeyState)
End Function

Function IDropSourceThunk_GiveFeedback(
ByRef thunk As DropSourceImpl,
ByVal dwEffect As DWord) As HRESULT
IDropSourceThunk_GiveFeedback = thunk.GiveFeedback(dwEffect)
EndFunction

Function CreateDropSourceImpl(hwnd As HWND, ByRef iid As IID, ByVal ppv As *VoidPtr) As HRESULT
CreateDropSourceImpl = E_OUTOFMEMORY
Dim punk As *DropSourceImpl
punk = New DropSourceImpl(hwnd)
If punk = 0 Then Exit Function

punk->vtable = New IDropSourceVTable
If punk->vtable = 0 Then Exit Function
With punk->vtable[0]
.QueryInterface = AddressOf (IUnknownThunk_QueryInterface)
.AddRef = AddressOf (IUnknownThunk_AddRef)
.Release = AddressOf (IUnknownThunk_Release)
.QueryContinueDrag = AddressOf (IDropSourceThunk_QueryContinueDrag)
.GiveFeedback = AddressOf (IDropSourceThunk_GiveFeedback)
End With

CreateDropSourceImpl = punk->QueryInterface(iid, ppv)

If CreateDropSourceImpl <> S_OK Then
CreateDropSourceImpl = 0
Delete punk
End If
End Function

Class IDataObjectVTable
Inherits IUnknownVTable
Public
GetData As *Function(
ByRef thunk As DataObjectImpl,
/* [unique][in] */ ByRef rformatetcIn As FORMATETC,
/* [out] */ ByRef rmedium As STGMEDIUM _
) As HRESULT
QueryGetData As *Function(
ByRef thunk As DataObjectImpl,
/* [unique][in] */ ByRef pformatetc As FORMATETC _
) As HRESULT
SetData As *Function(
ByRef thunk As DataObjectImpl,
/* [unique][in] */ByRef pformatetcIn As FORMATETC,
/* [out] */ByRef pmedium As STGMEDIUM,
/* [in] */ fRelease As BOOL _
) As HRESULT
EnumFormatEtc As *Function(
ByRef thunk As DataObjectImpl,
/* [in] */ ByVal dwDirection As DWord,
/* [out] */ ByRef rpenumFormatEtc As *IEnumFORMATETC _
) As HRESULT
End Class

Class DataObjectImplThunk
Public
vtable As *IDataObjectVTable
End Class

Function IDataObjectThunk_GetData(
ByRef thunk As DataObjectImpl,
/* [unique][in] */ ByRef rformatetcIn As FORMATETC,
/* [out] */ ByRef rmedium As STGMEDIUM) As HRESULT
IDataObjectThunk_GetData = thunk.GetData(rformatetcIn, rmedium)
End Function

Function IDataObjectThunk_QueryGetData(
ByRef thunk As DataObjectImpl,
/* [unique][in] */ ByRef pformatetc As FORMATETC) As HRESULT
IDataObjectThunk_QueryGetData = thunk.QueryGetData(pformatetc)
End Function

Function IDataObjectThunk_SetData(
ByRef thunk As DataObjectImpl,
/* [unique][in] */ByRef pformatetcIn As FORMATETC,
/* [out] */ByRef pmedium As STGMEDIUM,
/* [in] */ fRelease As BOOL _
) As HRESULT
IDataObjectThunk_SetData = thunk.SetData(pformatetcIn, pmedium, fRelease)
End Function

Function IDataObjectThunk_EnumFormatEtc(
ByRef thunk As DataObjectImpl,
/* [in] */ ByVal dwDirection As DWord,
/* [out] */ ByRef rpenumFormatEtc As *IEnumFORMATETC _
) As HRESULT
IDataObjectThunk_EnumFormatEtc = thunk.EnumFormatEtc(dwDirection, rpenumFormatEtc)
End Function

Function CreateDataObjectImpl(hwnd As HWND, ByRef iid As IID, ByVal ppv As *VoidPtr) As HRESULT
CreateDataObjectImpl = E_OUTOFMEMORY
Dim punk As *DataObjectImpl
punk = New DataObjectImpl(hwnd)
If punk = 0 Then Exit Function

punk->vtable = New IDataObjectVTable
If punk->vtable = 0 Then Exit Function
With punk->vtable[0]
.QueryInterface = AddressOf (IUnknownThunk_QueryInterface)
.AddRef = AddressOf (IUnknownThunk_AddRef)
.Release = AddressOf (IUnknownThunk_Release)
.GetData = AddressOf (IDataObjectThunk_GetData)
.QueryGetData = AddressOf (IDataObjectThunk_QueryGetData)
.SetData = AddressOf (IDataObject_SetData)
.EnumFormatEtc = AddressOf (IDataObject_EnumFormatEtc)
End With

CreateDataObjectImpl = punk->QueryInterface(iid, ppv)

If CreateDataObjectImpl <> S_OK Then
CreateDataObjectImpl = 0
Delete punk
End If
End Function

MainWnd.sbp内

[ここをクリックすると内容が表示されます]

また、DoDragDropについての詳しい解説ありがとうございました。
疑問をひとつ解消することができました！

しーぷ

いろいろと試してみたのですが、OleDragDropThunk.sbp内の
CreateDataObjectImplにミスがありました。
以下のように修正したところコンパイラが落ちることはなくなりました。

[ここをクリックすると内容が表示されます]

しかし、lpDataObj->SetDataでアクセス違反が起こってしまいます。
そこをコメントアウトしても次のlpDataObj->Release()、lpDropSource->Release()でアクセス違反が起こります。IDataObject、IDropSourceともに正しく実装できていないということでしょうか…。

自分でもやってみたいのは山々ですが，そんな時間がなくてやれていません。

IDataObjectの全てのメンバが揃っていないようです。メモリ配置の問題で，全てのメンバが正しい順番で宣言されていないといけません。よくわからない関数は，単にE_NOTIMPLを返すようにするだけにしてでも，とりあえず実装してみてください。

しーぷ

お忙しい中コメントいただきありがとうございます。
ご指摘どおりすべてのメンバを揃え（すべてE_NOTIMPLを返していますが…）、更に諸々を見直して修正したところアクセス違反はでなくなりました！

しかし今度はどうやらDoDragDropが失敗しているようでE_INVALIDARGが返ってきます。MSDNで調べてみたのですが返り値にないのですが…　やはりまだ実装に失敗しているのでしょうか。それともSTGMEDIUM構造体の格納が間違っているのか、DoDragDropの定義が誤っているのか、、、（STGMEDIUM構造体の格納にはこの記事を参考にしました）

再三恐れ入りますが、何かお気づきのことがあればご指摘おねがいします。

OleDragDropImpl

[ここをクリックすると内容が表示されます]

コード: 全て選択

Class DropTargetImpl
    Inherits DropTargetImplThunk
Public
    Sub DropTargetImpl(hwndTarget As HWND)
        refCount = 0
        hwnd = hwndTarget
    End Sub

    Function QueryInterface(ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
        QueryInterface = S_OK
        If IsEqualIID(iid, IID_IUnknown) <> FALSE Then
            ppvObj[0] = VarPtr (This) As *IUnknown
            AddRef()
        ElseIf  IsEqualIID(iid, IID_IDropTarget) <> FALSE Then
            ppvObj[0] = VarPtr (This) As *IDropTarget
            AddRef()
        Else
            ppvObj[0] = 0
            QueryInterface = E_NOINTERFACE
        End If 
    End Function

    Function AddRef() As ULONG
        refCount++
        AddRef = refCount
    End Function

    Function Release() As ULONG
        refCount--
        Release = refCount
        If refCount = 0 Then
            Delete VarPtr(This)
        End If
    End Function

    Function DragEnter(
        ByVal pDataObj As *IDataObject,
        ByVal grfKeyState As DWord,
        ByVal x As Long, ByVal y As Long,
        ByRef effect As DWord) As HRESULT
        DragEnter = S_OK
    End Function

    Function DragOver( 
        ByVal grfKeyState As DWord,
        ByVal x As Long, ByVal y As Long,
        ByRef effect As DWord) As HRESULT
        DragOver = S_OK
    End Function

    Function DragLeave() As HRESULT
        DragLeave = S_OK
    End Function

    Function Drop(
        ByVal pDataObj As *IDataObject,
        ByVal grfKeyState As DWord,
        ByVal x As Long, ByVal y As Long,
        ByRef effect As DWord _
    ) As HRESULT
        Dim fData As Long
        fData = FALSE

        Dim fe As FORMATETC
        Dim medium As STGMEDIUM
        Dim hglMem As HGLOBAL


        With fe
            .cfFormat = CF_HDROP
            .ptd = 0
            .dwAspect = DVASPECT_CONTENT
            .lindex = -1
            .tymed = TYMED_HGLOBAL
        End With
        'ファイルドロップ
        If( pDataObj->GetData(fe, medium) = S_OK )Then
            hglMem = medium.data As HGLOBAL
			Dim file[MAX_PATH] As Byte
            DragQueryFile( GlobalLock(hglMem), 0, file, MAX_PATH )
            GlobalUnlock(medium.data)
            ReleaseStgMedium(medium)
            MessageBox( hMainWnd, file, "",MB_OK)
            effect = DROPEFFECT_COPY
            fData = TRUE
        End If
        'それ以外
        If( fData=FALSE )Then
            effect = DROPEFFECT_NONE
        End If
        Drop = S_OK
    End Function
Private
    refCount As ULONG
    hwnd As HWND
End Class


Class DropSourceImpl
    Inherits DropSourceImplThunk
Public
    Sub DropSourceImpl(hwndSource As HWND)
        refCount = 0
        hwnd = hwndSource
    End Sub

    Function QueryInterface(ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
        QueryInterface = S_OK
        If IsEqualIID(iid, IID_IUnknown) <> FALSE Then
            ppvObj[0] = VarPtr (This) As *IUnknown
            AddRef()
        ElseIf  IsEqualIID(iid, IID_IDropSource) <> FALSE Then
            ppvObj[0] = VarPtr (This) As *IDropSource
            AddRef()
        Else
            ppvObj[0] = 0
            QueryInterface = E_NOINTERFACE
        End If 
    End Function

    Function AddRef() As ULONG
        refCount++
        AddRef = refCount
    End Function

    Function Release() As ULONG
        refCount--
        Release = refCount
        If refCount = 0 Then
            Delete VarPtr(This)
        End If
    End Function

	Function QueryContinueDrag(ByVal fEscapePressed As DWord, ByVal grfKeyState As DWord) As HRESULT
		OutputDebugString("QueryContinueDrag")
		QueryContinueDrag = S_OK
	 	'ESCキーが押されたらD&Dキャンセル
	  	If fEscapePressed Then
			MessageBox(0, "キャンセル", "", MB_OK)
			QueryContinueDrag = DRAGDROP_S_CANCEL
		'マウスボタンが離されたらD&D完了
		Elseif (grfKeyState And (MK_LBUTTON or MK_RBUTTON)) Then
			MessageBox(0, "完了", "", MB_OK)
			QueryContinueDrag = S_OK
		Endif
	EndFunction

	Function GiveFeedback(ByVal dwEffect As DWord) As HRESULT
		GiveFeedback = DRAGDROP_S_USEDEFAULTCURSORS
	EndFunction

Private
    refCount As ULONG
    hwnd As HWND
End Class

Class DataObjectImpl
    Inherits DataObjectImplThunk
Public
    Sub DataObjectImpl(hwndSource As HWND)
        refCount = 0
        hwnd = hwndSource
    End Sub

    Function QueryInterface(ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
        QueryInterface = S_OK
        If IsEqualIID(iid, IID_IUnknown) <> FALSE Then
            ppvObj[0] = VarPtr (This) As *IUnknown
            AddRef()
        ElseIf  IsEqualIID(iid, IID_IDataObject) <> FALSE Then
            ppvObj[0] = VarPtr (This) As *IDataObject
            AddRef()
        Else
            ppvObj[0] = 0
            QueryInterface = E_NOINTERFACE
        End If 
    End Function

    Function AddRef() As ULONG
        refCount++
        AddRef = refCount
    End Function

    Function Release() As ULONG
        refCount--
        Release = refCount
        If refCount = 0 Then
            Delete VarPtr(This)
        End If
    End Function

	Function GetData(ByRef rformatetcIn As FORMATETC, ByRef pmedium As STGMEDIUM) As HRESULT
		GetData = E_NOTIMPL
	End Function
	
	Function GetDataHere(ByRef rformatetcIn As FORMATETC, ByRef pmedium As STGMEDIUM) As HRESULT
		GetDataHere = E_NOTIMPL
	End Function

	Function QueryGetData(ByRef pformatetc As FORMATETC) As HRESULT
		QueryGetData = E_NOTIMPL
	End Function

	Function GetCanonicalFormatEtc(ByRef pformatetcIn As FORMATETC, ByRef pmedium As STGMEDIUM) As HRESULT
		GetCanonicalFormatEtc = E_NOTIMPL
	EndFunction

	Function SetData(ByRef pFormatetc As FORMATETC, ByRef pmedium As STGMEDIUM, fRelease As BOOL) As HRESULT
		OutputDebugString(Ex"IDataObject::SetData\n")
		SetData = E_NOTIMPL
	End Function

	Function EnumFormatEtc( ByVal dwDirection As DWord, ByRef rpenumFormatEtc As *IEnumFORMATETC) As HRESULT
		EnumFormatEtc = E_NOTIMPL
	End Function

    Function DAdvise(ByRef pformatetc As FORMATETC, ByVal advf As DWORD, ByVal pAdvSink As *IAdviseSink, ByVal pdwConnection As *DWord) As HRESULT
		DAdvise = E_NOTIMPL
	End Function

    Function DUnadvise(ByVal dwConnection As DWord) As HRESULT
		DUnadvise = E_NOTIMPL
	End Function
		
    Function EnumDAdvise(ByRef rpenumAdvise As *IEnumSTATDATA) As HRESULT
		EnumDAdvise = E_NOTIMPL
	End Function
Private
    refCount As ULONG
    hwnd As HWND
End Class

OleDragDropInterface

[ここをクリックすると内容が表示されます]

コード: 全て選択


TypeDef BOOL = Long
TypeDef HRESULT = Long
TypeDef ULONG = DWord
TypeDef IID = GUID
TypeDef CLSID = GUID
TypeDef CLIPFORMAT = Word

Type DROPFILES
    pFiles As DWord
    pt As POINTAPI
    fNC As BOOL
    fWid As BOOL
End Type

Dim IID_IUnknown = [0, 0, 0, [&hC0, 0, 0, 0, 0, 0, 0, &h46]] As IID
Dim IID_IDataObject = [&h0000010e, 0, 0, [&hC0, 0, 0, 0, 0, 0, 0, &h46]] As IID
Dim IID_IDropTarget = [&h00000122, 0, 0, [&hC0, 0, 0, 0, 0, 0, 0, &h46]] As IID
Dim IID_IDropSource = [&h00000121, 0, 0, [&hC0, 0, 0, 0, 0, 0, 0, &h46]] As IID
Const DRAGDROP_S_CANCEL = &h00040101L
Const DRAGDROP_S_USEDEFAULTCURSORS = &h00040102L

Declare Function OleInitialize Lib "Ole32" (reserved As VoidPtr) As HRESULT
Declare Sub OleUninitialize Lib "Ole32" ()
Declare Function IsEqualGUID Lib "Ole32" (ByRef guid1 As GUID, ByRef guid2 As GUID) As BOOL
Declare Function IsEqualCLSID Lib "Ole32" Alias "IsEqualGUID" (ByRef clsid1 As CLSID, ByRef clsid2 As CLSID) As BOOL
Declare Function IsEqualIID Lib "Ole32" Alias "IsEqualGUID"  (ByRef iid1 As IID, ByRef iid2 As IID) As BOOL
Declare Function DoDragDrop Lib "Ole32" Alias "DoDragDrop" (ByRef pDataObj As *IDataObject,ByRef pDropSource As *IDropSource, dwOKEffects As Dword,ByVal pdwEffect As *DWord) As BOOL
Function egtraOleInitialize() HRESULT
    OleInitialize(0)
End Function

Declare Function RegisterDragDrop Lib "Ole32" (
    hwnd As HWND,
    pDropTarget As *IDropTarget _
) As HRESULT
 
Declare Function RevokeDragDrop Lib "Ole32" (
    hwnd As HWND _
) As HRESULT

Declare Sub ReleaseStgMedium Lib "OLE32" (ByRef rmedium As STGMEDIUM)

Type FORMATETC 
    cfFormat As CLIPFORMAT
    ptd As *DVTARGETDEVICE
    dwAspect As DWord
    lindex As Long
    tymed As DWord
End Type

Type STGMEDIUM
    tymed As DWord 
    data As VoidPtr
	hGlobal As HGLOBAL
    ' C/C++では次のような共用体
    /* [switch_type(DWORD), switch_is((DWORD) tymed)] 
    union { 
        [case(TYMED_GDI)]      HBITMAP        hBitmap; 
        [case(TYMED_MFPICT)]   HMETAFILEPICT  hMetaFilePict; 
        [case(TYMED_ENHMF)]    HENHMETAFILE   hEnhMetaFile; 
        [case(TYMED_HGLOBAL)]  HGLOBAL        hGlobal; 
        [case(TYMED_FILE)]     LPWSTR         lpszFileName; 
        [case(TYMED_ISTREAM)]  IStream        *pstm; 
        [case(TYMED_ISTORAGE)] IStorage       *pstg; 
        [default] ; 
    }; 
    */
    /*[unique]*/ pUnkForRelease As *IUnknown
End Type

Type DVTARGETDEVICE 
    tdSize As DWord
    tdDriverNameOffset As Word
    tdDeviceNameOffset As Word
    tdPortNameOffset As Word
    tdExtDevmodeOffset As Word
    tdData[ELM(1)] As Byte
End Type

Class IDataObject
    Inherits IUnknown
Public
    Virtual Function /* [local] */ GetData(
        /* [unique][in] */ ByRef rformatetcIn As FORMATETC,
        /* [out] */ ByRef rmedium As STGMEDIUM _
    ) As HRESULT

    Virtual Function /* [local] */ GetDataHere( 
        /* [unique][in] */ ByRef rformatetcIn As FORMATETC,
        /* [out] */ ByRef pmedium As STGMEDIUM _
    ) As HRESULT
    
    Virtual Function QueryGetData(
        /* [unique][in] */ ByRef pformatetc As FORMATETC _
    ) As HRESULT

    Virtual Function GetCanonicalFormatEtc(
        /* [unique][in] */ ByRef pformatetcIn As FORMATETC,
        /* [out] */ ByRef pmedium As STGMEDIUM _
    ) As HRESULT

    Virtual Function /* [local] */ SetData(
        /* [unique][in] */ByRef pformatetcIn As FORMATETC,
        /* [out] */ByRef pmedium As STGMEDIUM,
        /* [in] */ fRelease As BOOL _
    ) As HRESULT

    Virtual Function EnumFormatEtc(
        /* [in] */ ByVal dwDirection As DWord,
        /* [out] */ ByRef rpenumFormatEtc As *IEnumFORMATETC _
    ) As HRESULT

    Virtual Function DAdvise(
        /* [in] */ ByRef pformatetc As FORMATETC,
        /* [in] */ ByVal advf As DWORD,
        /* [unique][in] */ ByVal pAdvSink As *IAdviseSink,
        /* [out] */ ByVal pdwConnection As *DWord _
    ) As HRESULT

    Virtual Function DUnadvise(
        /* [in] */ ByVal dwConnection As DWord _
    ) As HRESULT

    Virtual Function EnumDAdvise(
        /* [out] */ ByRef rpenumAdvise As *IEnumSTATDATA _
    ) As HRESULT
End Class

Class IDropTarget
    Inherits IUnknown
Public
    Virtual Function DragEnter(
        /* [unique][in] */ ByVal pDataObj As *IDataObject,
        /* [in] */ ByVal grfKeyState As DWord,
        /* [in] */ ByVal x As Long, ByVal y As Long,
        /* [out][in] */ ByRef effect As DWord) As HRESULT

    Virtual Function DragOver( 
        /* [in] */ ByVal grfKeyState As DWord,
        /* [in] */ ByVal x As Long, ByVal y As Long,
        /* [out][in] */ ByRef effect As DWord) As HRESULT

    Virtual Function DragLeave() As HRESULT

    Virtual Function Drop(
        /* [unique][in] */ ByVal pDataObj As *IDataObject,
        /* [in] */ ByVal grfKeyState As DWord,
        /* [in] */ ByVal x As Long, ByVal y As Long,
        /* [out][in] */ ByRef effect As DWord) As HRESULT
End Class

Class IDropSource
    Inherits IUnknown
Public
	Virtual Function QueryContinueDrag(
		ByVal fEscapePressed As DWord,
		ByVal grfKeyState As DWord) As HRESULT

	Virtual Function GiveFeedback(
		ByVal dwEffect As DWord) As HRESULT
End Class


Class IAdviseSink
    Inherits IUnknown
End Class

Class IEnumSTATDATA
    Inherits IUnknown
End Class

Class IEnumFORMATETC
    Inherits IUnknown
End Class

Enum DROPEFFECT
    DROPEFFECT_NONE   = 0
    DROPEFFECT_COPY   = 1
    DROPEFFECT_MOVE   = 2
    DROPEFFECT_LINK   = 4
    DROPEFFECT_SCROLL = &h80000000
End Enum

Enum /*[transmit_as(long)]*/ TYMED
    TYMED_HGLOBAL     = 1
    TYMED_FILE        = 2
    TYMED_ISTREAM     = 4
    TYMED_ISTORAGE    = 8
    TYMED_GDI         = 16
    TYMED_MFPICT      = 32
    TYMED_ENHMF       = 64
    TYMED_NULL        = 0
End Enum

Enum DVASPECT
    DVASPECT_CONTENT    = 1
    DVASPECT_THUMBNAIL  = 2
    DVASPECT_ICON       = 4
    DVASPECT_DOCPRINT   = 8
End Enum

OleDragDropThunk

[ここをクリックすると内容が表示されます]

コード: 全て選択

Class DropTarget_IUnknownVTable
Public
    QueryInterface As *Function(ByRef thunk As IUnknown, ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
    AddRef As *Function(ByRef thunk As IUnknown) As ULONG
    Release As *Function(ByRef thunk As IUnknown) As ULONG
End Class

Class IDropTargetVTable
    Inherits DropTarget_IUnknownVTable
Public
    DragEnter As *Function(
        ByRef thunk As DropTargetImpl,
        ByVal pDataObj As *IDataObject,
        ByVal grfKeyState As DWord,
        ByVal x As Long, ByVal y As Long,
        ByRef effect As DWord) As HRESULT

    DragOver As *Function( 
        ByRef thunk As DropTargetImpl,
        ByVal grfKeyState As DWord,
        ByVal x As Long, ByVal y As Long,
        ByRef effect As DWord) As HRESULT

    DragLeave As *Function(ByRef thunk As DropTargetImpl) As HRESULT

    Drop As *Function(
        ByRef thunk As DropTargetImpl,
        ByVal pDataObj As *IDataObject,
        ByVal grfKeyState As DWord,
        ByVal x As Long, ByVal y As Long,
        ByRef effect As DWord) As HRESULT
End Class

Class DropTargetImplThunk
Public
    vtable As *IDropTargetVTable
End Class

Function DropTarget_IUnknownThunk_QueryInterface(ByRef unk As DropTargetImpl, ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
    DropTarget_IUnknownThunk_QueryInterface = unk.QueryInterface(iid, ppvObj)
End Function

Function DropTarget_IUnknownThunk_AddRef(ByRef unk As DropTargetImpl) As ULONG
    DropTarget_IUnknownThunk_AddRef = unk.AddRef()
End Function

Function DropTarget_IUnknownThunk_Release(ByRef unk As DropTargetImpl) As ULONG
    Dim vtable As *IDropTargetVTable
    vtable = unk.vtable
    DropTarget_IUnknownThunk_Release = unk.Release()
    If DropTarget_IUnknownThunk_Release = 0 Then
        Delete vtable
    End If
End Function

Function IDropTargetThunk_DragEnter(
    ByRef thunk As DropTargetImpl,
    ByVal pDataObj As *IDataObject,
    ByVal grfKeyState As DWord,
    ByVal x As Long, ByVal y As Long,
    ByRef effect As DWord) As HRESULT

    IDropTargetThunk_DragEnter = thunk.DragEnter(pDataObj, grfKeyState, x, y, effect)
End Function

Function IDropTargetThunk_DragOver( 
    ByRef thunk As DropTargetImpl,
    ByVal grfKeyState As DWord,
    ByVal x As Long, ByVal y As Long,
    ByRef effect As DWord) As HRESULT

    IDropTargetThunk_DragOver = thunk.DragOver(grfKeyState, x, y, effect)
End Function

Function IDropTargetThunk_DragLeave(ByRef thunk As DropTargetImpl) As HRESULT
    IDropTargetThunk_DragLeave = thunk.DragLeave()
End Function

Function IDropTargetThunk_Drop(
    ByRef thunk As DropTargetImpl,
    ByVal pDataObj As *IDataObject,
    ByVal grfKeyState As DWord,
    ByVal x As Long, ByVal y As Long,
    ByRef effect As DWord) As HRESULT

    IDropTargetThunk_Drop = thunk.Drop(pDataObj, grfKeyState, x, y, effect)
End Function

Function CreateDropTargetImpl(hwnd As HWND, ByRef iid As IID, ByVal ppv As *VoidPtr) As HRESULT
    CreateDropTargetImpl = E_OUTOFMEMORY
    Dim punk As *DropTargetImpl
    punk = New DropTargetImpl(hwnd)
    If punk = 0 Then Exit Function

    punk->vtable = New IDropTargetVTable
    If punk->vtable = 0 Then Exit Function
    With punk->vtable[0]
        .QueryInterface = AddressOf (DropTarget_IUnknownThunk_QueryInterface)
        .AddRef = AddressOf (DropTarget_IUnknownThunk_AddRef)
        .Release = AddressOf (DropTarget_IUnknownThunk_Release)
        .DragEnter = AddressOf (IDropTargetThunk_DragEnter)
        .DragOver = AddressOf (IDropTargetThunk_DragOver)
        .DragLeave = AddressOf (IDropTargetThunk_DragLeave)
        .Drop = AddressOf (IDropTargetThunk_Drop)
    End With

    CreateDropTargetImpl = punk->QueryInterface(iid, ppv)

    If CreateDropTargetImpl <> S_OK Then
        CreateDropTargetImpl = 0
        Delete punk
    End If
End Function


Class DropSource_IUnknownVTable
Public
    QueryInterface As *Function(ByRef thunk As IUnknown, ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
    AddRef As *Function(ByRef thunk As IUnknown) As ULONG
    Release As *Function(ByRef thunk As IUnknown) As ULONG
End Class

Class IDropSourceVTable
    Inherits DropSource_IUnknownVTable
Public
	QueryContinueDrag As *Function(
		ByRef thunk As DropSourceImpl,
		ByVal fEscapePressed As DWord,
		ByVal grfKeyState As DWord) As HRESULT

	GiveFeedback As *Function(
		ByRef thunk As DropSourceImpl,
		ByVal dwEffect As DWord) As HRESULT
End Class

Class DropSourceImplThunk
Public
    vtable As *IDropSourceVTable
End Class

Function DropSource_IUnknownThunk_QueryInterface(ByRef unk As DropSourceImpl, ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
    DropSource_IUnknownThunk_QueryInterface = unk.QueryInterface(iid, ppvObj)
End Function

Function DropSource_IUnknownThunk_AddRef(ByRef unk As DropSourceImpl) As ULONG
    DropSource_IUnknownThunk_AddRef = unk.AddRef()
End Function

Function DropSource_IUnknownThunk_Release(ByRef unk As DropSourceImpl) As ULONG
    Dim vtable As *IDropSourceVTable
    vtable = unk.vtable
    DropSource_IUnknownThunk_Release = unk.Release()
    If DropSource_IUnknownThunk_Release = 0 Then
        Delete vtable
    End If
End Function

Function IDropSourceThunk_QueryContinueDrag(
    ByRef thunk As DropSourceImpl,
	ByVal fEscapePressed As DWord,
	ByVal grfKeyState As DWord) As HRESULT
    IDropSourceThunk_QueryContinueDrag = thunk.QueryContinueDrag(fEscapePressed, grfKeyState)
End Function

Function IDropSourceThunk_GiveFeedback(
    ByRef thunk As DropSourceImpl,
	ByVal dwEffect As DWord) As HRESULT
    IDropSourceThunk_GiveFeedback = thunk.GiveFeedback(dwEffect)
EndFunction

Function CreateDropSourceImpl(hwnd As HWND, ByRef iid As IID, ByVal ppv As *VoidPtr) As HRESULT
    CreateDropSourceImpl = E_OUTOFMEMORY
    Dim punk As *DropSourceImpl
    punk = New DropSourceImpl(hwnd)
    If punk = 0 Then Exit Function

    punk->vtable = New IDropSourceVTable
    If punk->vtable = 0 Then Exit Function
    With punk->vtable[0]
        .QueryInterface = AddressOf (DropSource_IUnknownThunk_QueryInterface)
        .AddRef = AddressOf (DropSource_IUnknownThunk_AddRef)
        .Release = AddressOf (DropSource_IUnknownThunk_Release)
		.QueryContinueDrag = AddressOf (IDropSourceThunk_QueryContinueDrag)
		.GiveFeedback = AddressOf (IDropSourceThunk_GiveFeedback)
    End With

    CreateDropSourceImpl = punk->QueryInterface(iid, ppv)

    If CreateDropSourceImpl <> S_OK Then
        CreateDropSourceImpl = 0
        Delete punk
    End If
End Function


Class DataObject_IUnknownVTable
Public
    QueryInterface As *Function(ByRef thunk As IUnknown, ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
    AddRef As *Function(ByRef thunk As IUnknown) As ULONG
    Release As *Function(ByRef thunk As IUnknown) As ULONG
End Class

Class IDataObjectVTable
    Inherits DataObject_IUnknownVTable
Public
	GetData As *Function(
		ByRef thunk As DataObjectImpl,
        ByRef rformatetcIn As FORMATETC,
        ByRef rmedium As STGMEDIUM _
    	) As HRESULT
	GetDataHere As *Function( 
		ByRef thunk As DataObjectImpl,
        ByRef rformatetcIn As FORMATETC,
        ByRef pmedium As STGMEDIUM _
    ) As HRESULT
	QueryGetData As *Function(
		ByRef thunk As DataObjectImpl,
        ByRef pformatetc As FORMATETC _
	    ) As HRESULT
	GetCanonicalFormatEtc As *Function(
		ByRef thunk As DataObjectImpl,
        ByRef pformatetcIn As FORMATETC,
        ByRef pmedium As STGMEDIUM _
    ) As HRESULT
	SetData As *Function(
		ByRef thunk As DataObjectImpl,
		ByRef pformatetcIn As FORMATETC,
        ByRef pmedium As STGMEDIUM,
        fRelease As BOOL _
    	) As HRESULT
	EnumFormatEtc As *Function(
		ByRef thunk As DataObjectImpl,
        ByVal dwDirection As DWord,
        ByRef rpenumFormatEtc As *IEnumFORMATETC _
	    ) As HRESULT
	DAdvise As *Function(
		ByRef thunk As DataObjectImpl,
        ByRef pformatetc As FORMATETC,
        ByVal advf As DWORD,
        ByVal pAdvSink As *IAdviseSink,
        ByVal pdwConnection As *DWord _
    ) As HRESULT
	DUnadvise As *Function(
		ByRef thunk As DataObjectImpl,
        ByVal dwConnection As DWord _
    ) As HRESULT
	EnumDAdvise As *Function(
		ByRef thunk As DataObjectImpl,
        ByRef rpenumAdvise As *IEnumSTATDATA _
    ) As HRESULT
End Class

Class DataObjectImplThunk
Public
    vtable As *IDataObjectVTable
End Class

Function DataObject_IUnknownThunk_QueryInterface(ByRef unk As DataObjectImpl, ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
    DataObject_IUnknownThunk_QueryInterface = unk.QueryInterface(iid, ppvObj)
End Function

Function DataObject_IUnknownThunk_AddRef(ByRef unk As DataObjectImpl) As ULONG
    DataObject_IUnknownThunk_AddRef = unk.AddRef()
End Function

Function DataObject_IUnknownThunk_Release(ByRef unk As DataObjectImpl) As ULONG
    Dim vtable As *IDataObjectVTable
    vtable = unk.vtable
    DataObject_IUnknownThunk_Release = unk.Release()
    If DataObject_IUnknownThunk_Release = 0 Then
        Delete vtable
    End If
End Function

Function IDataObjectThunk_GetData(
	ByRef thunk As DataObjectImpl,
    ByRef rformatetcIn As FORMATETC,
    ByRef rmedium As STGMEDIUM) As HRESULT
    IDataObjectThunk_GetData = thunk.GetData(rformatetcIn, rmedium)
End Function

Function IDataObjectThunk_GetDataHere( 
	ByRef thunk As DataObjectImpl,
    ByRef rformatetcIn As FORMATETC,
    ByRef pmedium As STGMEDIUM) As HRESULT
	IDataObjectThunk_GetDataHere = thunk.GetDataHere(rformatetcIn, pmedium)
End Function

Function IDataObjectThunk_QueryGetData(
	ByRef thunk As DataObjectImpl,
    ByRef pformatetc As FORMATETC) As HRESULT
    IDataObjectThunk_QueryGetData = thunk.QueryGetData(pformatetc)
End Function

Function IDataObjectThunk_GetCanonicalFormatEtc(
	ByRef thunk As DataObjectImpl,
    ByRef pformatetcIn As FORMATETC,
    ByRef pmedium As STGMEDIUM) As HRESULT
	IDataObjectThunk_GetCanonicalFormatEtc = thunk.GetCanonicalFormatEtc(pformatetcIn, pmedium)
End Function

Function IDataObjectThunk_SetData(
	ByRef thunk As DataObjectImpl,
    ByRef pformatetcIn As FORMATETC,
    ByRef pmedium As STGMEDIUM,
    fRelease As BOOL) As HRESULT
    IDataObjectThunk_SetData = thunk.SetData(pformatetcIn, pmedium, fRelease)
End Function

Function IDataObjectThunk_EnumFormatEtc(
	ByRef thunk As DataObjectImpl,
    ByVal dwDirection As DWord,
    ByRef rpenumFormatEtc As *IEnumFORMATETC) As HRESULT
    IDataObjectThunk_EnumFormatEtc = thunk.EnumFormatEtc(dwDirection, rpenumFormatEtc)
End Function

Function IDataObjectThunk_DAdvise(
	ByRef thunk As DataObjectImpl,
    ByRef pformatetc As FORMATETC,
    ByVal advf As DWORD,
    ByVal pAdvSink As *IAdviseSink,
    ByVal pdwConnection As *DWord) As HRESULT
    IDataObjectThunk_DAdvise = thunk.DAdvise(pformatetc, advf, pAdvSink, pdwConnection)
End Function

Function IDataObjectThunk_DUnadvise(
	ByRef thunk As DataObjectImpl,
    ByVal dwConnection As DWord) As HRESULT
    IDataObjectThunk_DUnadvise = thunk.DUnadvise(dwConnection)
End Function

Function IDataObjectThunk_EnumDAdvise(
	ByRef thunk As DataObjectImpl,
    ByRef rpenumAdvise As *IEnumSTATDATA) As HRESULT
    IDataObjectThunk_EnumDAdvise = thunk.EnumDAdvise(rpenumAdvise)
End Function

Function CreateDataObjectImpl(hwnd As HWND, ByRef iid As IID, ByVal ppv As *VoidPtr) As HRESULT
    CreateDataObjectImpl = E_OUTOFMEMORY
    Dim punk As *DataObjectImpl
    punk = New DataObjectImpl(hwnd)
    If punk = 0 Then Exit Function

    punk->vtable = New IDataObjectVTable
    If punk->vtable = 0 Then Exit Function
    With punk->vtable[0]
        .QueryInterface = AddressOf (DataObject_IUnknownThunk_QueryInterface)
        .AddRef = AddressOf (DataObject_IUnknownThunk_AddRef)
        .Release = AddressOf (DataObject_IUnknownThunk_Release)
		.GetData = AddressOf (IDataObjectThunk_GetData)
		.GetDataHere = AddressOf (IDataObjectThunk_GetDataHere) 
		.QueryGetData = AddressOf (IDataObjectThunk_QueryGetData)
		.GetCanonicalFormatEtc = AddressOf (IDataObjectThunk_GetCanonicalFormatEtc)
		.SetData = AddressOf (IDataObjectThunk_SetData)
		.EnumFormatEtc = AddressOf (IDataObjectThunk_EnumFormatEtc)
		.DAdvise = AddressOf (IDataObjectThunk_DAdvise)
		.DUnadvise = AddressOf (IDataObjectThunk_DUnadvise)
		.EnumDAdvise = AddressOf (IDataObjectThunk_EnumDAdvise)
    End With

    CreateDataObjectImpl = punk->QueryInterface(iid, ppv)

    If CreateDataObjectImpl <> S_OK Then
        CreateDataObjectImpl = 0
        Delete punk
    End If
End Function

MainWnd内

[ここをクリックすると内容が表示されます]

コード: 全て選択


Sub MainWnd_Create(ByRef CreateStruct As CREATESTRUCT)
    If egtraOleInitialize() <> S_OK Then Debug
End Sub

Sub MainWnd_LButtonDown(flags As Long, x As Integer, y As Integer)
	Dim lpDropSource As *IDropSource
	Dim lpDataObj As *IDataObject
	Dim hr As HRESULT
	Dim effect As *DWord
    hr = CreateDropSourceImpl(hMainWnd, IID_IDropSource, VarPtr(lpDropSource))
	hr = CreateDataObjectImpl(hMainWnd, IID_IDataObject, VarPtr(lpDataObj))

	Dim files[MAX_PATH] As Byte
	lstrcpy(files, "C:/test.txt")

	Dim fmtetc As FORMATETC
'	 FORMATETC構造体をセット 
	fmtetc.cfFormat = CF_HDROP
	fmtetc.ptd = NULL
	fmtetc.dwAspect = DVASPECT_CONTENT
	fmtetc.lindex = -1
	fmtetc.tymed = TYMED_HGLOBAL

	Dim medium As STGMEDIUM
	Dim p As LPSTR
	Dim df As *DROPFILES
'	 STGMEDIUM構造体をセット
	medium.tymed = TYMED_HGLOBAL
	medium.hGlobal = GlobalAlloc(
                   GMEM_MOVEABLE,
                   sizeof(DROPFILES) + lstrlen(files)
                 )
	medium.pUnkForRelease = NULL
	p = GlobalLock(medium.hGlobal)
	df = p As *DROPFILES
	df->pFiles = sizeof(DROPFILES)
	df->fWid = FALSE
    p+ = SizeOf(DROPFILES)
    lstrcpy(p, files)
    p+ = lstrlen(p) + 1
    lstrcpy(p, Chr$(0))
	GlobalUnlock(medium.hGlobal)

	' IDataObjectをセット
	lpDataObj->SetData(fmtetc, medium, FALSE)
	' OLE Drag & Drop開始
	hr = DoDragDrop(lpDataObj, lpDropSource,  DROPEFFECT_COPY, effect)
	if hr = E_INVALIDARG Then OutputDebugString("E_INVALIDARG")
	' リソースを開放
	lpDataObj->Release()
	lpDropSource->Release()
End Sub

しーぷ

自分でいろいろ言いましたがやはり最低でもSetData()及びQueryGetData(),GetData()を記述しなければならないのに、それらをただE_NOTIMPLを返すだけで処理しているのが動作しない最大の原因だと思います。以前にも書きましたが、Cで書かれたこのページの内容を上手くABに移植できれば動作すると思うのですが…

ほとんどCのことが分からないのですが、分からないなりに調べ、勝手に解釈し、更に配列やらエラーの処理やらをまったく無視して書いてみました。結局動かなかったのですが、GetDataが呼び出されればpmediumに対してfromatetcInと同じ形式のこちらで保持していたmediumを格納し、QueryGetDataはpformatetcと同じ形式のデータを持っているかを応え、SetDataではpFormatetcとpmediumを自分のところにコピーして保持するようにすればいいのですから原理的にはこれであっているのではないでしょうか？なぜ上手く動いてくれないのでしょうか…

OleDragDropImpl.abs

[ここをクリックすると内容が表示されます]

コード: 全て選択


Class DropTargetImpl
    Inherits DropTargetImplThunk
Public
    Sub DropTargetImpl(hwndTarget As HWND)
        refCount = 0
        hwnd = hwndTarget
    End Sub

    Function QueryInterface(ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
        QueryInterface = S_OK
        If IsEqualIID(iid, IID_IUnknown) <> FALSE Then
            ppvObj[0] = VarPtr (This) As *IUnknown
            AddRef()
        ElseIf  IsEqualIID(iid, IID_IDropTarget) <> FALSE Then
            ppvObj[0] = VarPtr (This) As *IDropTarget
            AddRef()
        Else
            ppvObj[0] = 0
            QueryInterface = E_NOINTERFACE
        End If 
    End Function

    Function AddRef() As ULONG
        refCount++
        AddRef = refCount
    End Function

    Function Release() As ULONG
        refCount--
        Release = refCount
        If refCount = 0 Then
            Delete VarPtr(This)
        End If
    End Function

    Function DragEnter(
        ByVal pDataObj As *IDataObject,
        ByVal grfKeyState As DWord,
        ByVal x As Long, ByVal y As Long,
        ByRef effect As DWord) As HRESULT
        DragEnter = S_OK
    End Function

    Function DragOver( 
        ByVal grfKeyState As DWord,
        ByVal x As Long, ByVal y As Long,
        ByRef effect As DWord) As HRESULT
        DragOver = S_OK
    End Function

    Function DragLeave() As HRESULT
        DragLeave = S_OK
    End Function

    Function Drop(
        ByVal pDataObj As *IDataObject,
        ByVal grfKeyState As DWord,
        ByVal x As Long, ByVal y As Long,
        ByRef effect As DWord _
    ) As HRESULT
        Dim fData As Long
        fData = FALSE

        Dim fe As FORMATETC
        Dim medium As STGMEDIUM
        Dim hglMem As HGLOBAL


        With fe
            .cfFormat = CF_HDROP
            .ptd = 0
            .dwAspect = DVASPECT_CONTENT
            .lindex = -1
            .tymed = TYMED_HGLOBAL
        End With
        'ファイルドロップ
        If( pDataObj->GetData(fe, medium) = S_OK )Then
            hglMem = medium.data As HGLOBAL
			Dim file[MAX_PATH] As Byte
            DragQueryFile( GlobalLock(hglMem), 0, file, MAX_PATH )
            GlobalUnlock(medium.data)
            ReleaseStgMedium(medium)
            MessageBox( hMainWnd, file, "",MB_OK)
            effect = DROPEFFECT_COPY
            fData = TRUE
        End If
        'それ以外
        If( fData=FALSE )Then
            effect = DROPEFFECT_NONE
        End If
        Drop = S_OK
    End Function
Private
    refCount As ULONG
    hwnd As HWND
End Class


Class DropSourceImpl
    Inherits DropSourceImplThunk
Public
    Sub DropSourceImpl(hwndSource As HWND)
        refCount = 0
        hwnd = hwndSource
    End Sub

    Function QueryInterface(ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
        QueryInterface = S_OK
        If IsEqualIID(iid, IID_IUnknown) <> FALSE Then
            ppvObj[0] = VarPtr (This) As *IUnknown
            AddRef()
        ElseIf  IsEqualIID(iid, IID_IDropSource) <> FALSE Then
            ppvObj[0] = VarPtr (This) As *IDropSource
            AddRef()
        Else
            ppvObj[0] = 0
            QueryInterface = E_NOINTERFACE
        End If 
    End Function

    Function AddRef() As ULONG
        refCount++
        AddRef = refCount
    End Function

    Function Release() As ULONG
        refCount--
        Release = refCount
        If refCount = 0 Then
            Delete VarPtr(This)
        End If
    End Function

	Function QueryContinueDrag(ByVal fEscapePressed As DWord, ByVal grfKeyState As DWord) As HRESULT
		OutputDebugString("QueryContinueDrag")
		QueryContinueDrag = S_OK
	 	'ESCキーが押されたらD&Dキャンセル
	  	If fEscapePressed Then
			MessageBox(0, "キャンセル", "", MB_OK)
			QueryContinueDrag = DRAGDROP_S_CANCEL
		'マウスボタンが離されたらD&D完了
		Elseif (grfKeyState And (MK_LBUTTON or MK_RBUTTON)) Then
			MessageBox(0, "完了", "", MB_OK)
			QueryContinueDrag = S_OK
		Endif
	EndFunction

	Function GiveFeedback(ByVal dwEffect As DWord) As HRESULT
		GiveFeedback = DRAGDROP_S_USEDEFAULTCURSORS
	EndFunction

Private
    refCount As ULONG
    hwnd As HWND
End Class

Class DataObjectImpl
    Inherits DataObjectImplThunk
Public
    Sub DataObjectImpl(hwndSource As HWND)
        refCount = 0
        hwnd = hwndSource
    End Sub

    Function QueryInterface(ByRef iid As IID, ppvObj As *VoidPtr) As HRESULT
        QueryInterface = S_OK
        If IsEqualIID(iid, IID_IUnknown) <> FALSE Then
            ppvObj[0] = VarPtr (This) As *IUnknown
            AddRef()
        ElseIf  IsEqualIID(iid, IID_IDataObject) <> FALSE Then
            ppvObj[0] = VarPtr (This) As *IDataObject
            AddRef()
        Else
            ppvObj[0] = 0
            QueryInterface = E_NOINTERFACE
        End If 
    End Function

    Function AddRef() As ULONG
        refCount++
        AddRef = refCount
    End Function

    Function Release() As ULONG
        refCount--
        Release = refCount
        If refCount = 0 Then
            Delete VarPtr(This)
        End If
    End Function

	Function GetData(ByRef rformatetcIn As FORMATETC, ByRef pmedium As STGMEDIUM) As HRESULT
		if DVASPECT_CONTENT And rformatetcIn.dwAspect Then
			GetData = DV_E_DVASPECT
		else if (rformatetcIn.cfFormat = fmt.cfFormat) And (fmt.tymed And rformatetcIn.tymed) Then
			Dim hVoid As HANDLE
			hVoid = OleDuplicateData(medium.hGlobal, fmt.cfFormat, NULL)
			pmedium.hGlobal = hVoid
			pmedium.tymed = medium.tymed
			pmedium.pUnkForRelease = medium.pUnkForRelease
			GetData = S_OK
		EndIf
	End Function
	
	Function GetDataHere(ByRef rformatetcIn As FORMATETC, ByRef pmedium As STGMEDIUM) As HRESULT
		GetDataHere = E_NOTIMPL
	End Function

	Function QueryGetData(ByRef pformatetc As FORMATETC) As HRESULT
		if (pformatetc.cfFormat = fmt.cfFormat) And (fmt.tymed And pformatetc.tymed) Then
			QueryGetData = S_OK
		Else
			QueryGetData = DV_E_FORMATETC
		EndIf
	End Function

	Function GetCanonicalFormatEtc(ByRef pformatetcIn As FORMATETC, ByRef pmedium As STGMEDIUM) As HRESULT
		GetCanonicalFormatEtc = E_NOTIMPL
	EndFunction

	Function SetData(ByRef pFormatetc As FORMATETC, ByRef pmedium As STGMEDIUM, fRelease As BOOL) As HRESULT
		fmt = pFormatetc
		if fRelease = FALSE Then
			medium = pmedium
		Else
			Dim hVoid As HANDLE
			hVoid = OleDuplicateData(pmedium.hGlobal, pFormatetc.cfFormat, NULL)
			medium.hGlobal = hVoid
			medium.tymed = pmedium.tymed
			medium.pUnkForRelease = pmedium.pUnkForRelease
		EndIf
		SetData = S_OK
	End Function

	Function EnumFormatEtc( ByVal dwDirection As DWord, ByRef rpenumFormatEtc As *IEnumFORMATETC) As HRESULT
		EnumFormatEtc = E_NOTIMPL
	End Function

    Function DAdvise(ByRef pformatetc As FORMATETC, ByVal advf As DWORD, ByVal pAdvSink As *IAdviseSink, ByVal pdwConnection As *DWord) As HRESULT
		DAdvise = E_NOTIMPL
	End Function

    Function DUnadvise(ByVal dwConnection As DWord) As HRESULT
		DUnadvise = E_NOTIMPL
	End Function
		
    Function EnumDAdvise(ByRef rpenumAdvise As *IEnumSTATDATA) As HRESULT
		EnumDAdvise = E_NOTIMPL
	End Function
Private
	fmt As FORMATETC
    medium As STGMEDIUM
    refCount As ULONG
    hwnd As HWND
End Class

OleDragDropInterface.abs

コード: 全て選択


Const DVASPECT_CONTENT = 1
Const DV_E_FORMATETC = &h80040064
Const DV_E_DVASPECT = &h8004006BL
Declare Function OleDuplicateData Lib "Ole32" (hSrc As HANDLE, cfFormat As CLIPFORMAT, uiFlags As Long) As HANDLE