It will probably interrest very few people since PureBasic has already a fairly complete management of the Drag & Drop that responds to the most common needs. But if you need a bit of management for this particular mechanism (which was my case) you'll need immerse your hands dirty. The following clears the ground well.
The first code should be saved in a file that you PB named "dataobject.pb"
[EDIT 30/09/24 : the code has been updated to correct some bugs and is now OK for x64 systems]
Code: Select all
;***************************************************************************
;
; IMPLEMENTATION OF IDATAOBJET, IDROPSOURCE & IDROPTARGET
;
; By Zapman
; From a Nico code (http://www.purebasic.fr/english/viewtopic.php?p=201027&sid=a993c3617a34f5a2ee4ccdaa9a3dd8c4#p201027)
; And from "Implementing IDataObject" CATCH 22 : http://www.catch22.net/tuts/dragdrop/3
;
;***************************************************************************
;
;
;***************************************************************************
; CUSTOM STRUCTURES
; Don't look for those structures in the Microsoft documentation, you won't
; find them. They're only to help the implementation of
; iDataObject, IdropSource and IDropTarget in PureBasic
;***************************************************************************
;
#DataMax = 100
Structure iDataObjectData
*pIntf.IDataobject
Refcount.l
m_count.l ; number of STGMEDIUM and FORMATETC objects
m_stgmed.i[#DataMax];We'll store here pointers to a tab of STGMEDIUM objects
m_format.i[#DataMax];We'll store here pointers to a tab of FORMATETC objects
EndStructure
Structure iDropSourceData
*pIntf.IDropSource
Refcount.l
LastEffect.l
pDataobject.i ; we'll store here a pointer to the DataObject used for this DropSource
EndStructure
Structure iDropTargetData
*pIntf.IDropTarget
Refcount.l
TargetGadget.i ; We'll store here a pointer to the target Gadget
AcceptedFormats.s ; We'll store here the list of formats accepted by our targets
FormatMatchs.l ; On DragEnter, we'll store here 1 if the accepted formats and the DataSource formats match and 0 if not
FormatList.s ; We'll store here a list of formats available from the dataSource (this is only for the demo)
InfoWinHdl.i ; We'll store here a pointer to the target GadgetID wich will display infos (this is only for the demo)
EndStructure
Global NewList IDataObject.iDataObjectData()
Global NewList IDropSource.iDropSourceData()
Global NewList IDropTarget.iDropTargetData()
;
;
;***************************************************************************
; GENERAL FUNCTIONS
; By Zapman
;***************************************************************************
;
Procedure.s FormatMessage(lngErrorCode.l)
; Unknown author
MemoryID = AllocateMemory (255)
tchar.l = FormatMessage_(#FORMAT_MESSAGE_FROM_SYSTEM, #Null, lngErrorCode, 0, MemoryID, 255, #Null)
e$ = PeekS(MemoryID)
FreeMemory(MemoryID)
If tchar > 0
e$ = Trim(Left(e$, tchar))
Else
e$ = ""
EndIf
ProcedureReturn e$
EndProcedure
;
Procedure.s ProgNameFromCLSID(MyCLSID)
; By Zapman
*Buffer = AllocateMemory(100)
For ct = 1 To Len("CLSID\") ; Write "CLSID\" in Unicode Mode
PokeB(*Buffer+ct*2-2,Asc(Mid("CLSID\",ct,1)))
PokeB(*Buffer+ct*2-1,0)
Next
Slen = StringFromGUID2_(MyCLSID,*Buffer+Len("CLSID\")*2,100)*2 ; add the CLSID String (always coded in Unicode)
Slen+Len("CLSID\")*2
sk$ = ""
For ct = 1 To SLen Step 2 ; Get the string in Unicode OR Ascii depending on our compilation mode
sk$ + Chr(PeekC(*Buffer+ct-1))
Next
FreeMemory(*Buffer)
If SLen
Ret = RegOpenKeyEx_(#HKEY_CLASSES_ROOT,@sk$, 0, #KEY_ALL_ACCESS, @hKey)
If (Ret =#ERROR_SUCCESS)
; Query value of key To get Path And close the key
Ret = RegQueryValueEx_(hKey, #Null, #Null, #Null, #Null, @cSize)
If (Ret = #ERROR_SUCCESS)
*szPath = AllocateMemory(cSize)
Ret = RegQueryValueEx_(hKey, #Null, #Null, #Null, *szPath, @cSize)
If (Ret = #ERROR_SUCCESS)
RegCloseKey_(hKey);
File$ = PeekS(*szPath)
FreeMemory(*szPath)
EndIf
EndIf
EndIf
EndIf
If (Ret <>#ERROR_SUCCESS)
File$ = FormatMessage(Ret)
EndIf
ProcedureReturn File$
EndProcedure
;
Procedure SetCharPosFromXY(GadgetID,x,y)
; By Zapman
; Set cursor/carret position in a listview or editor gadget
; x and y are absolute coordinates (from top/left corner of the screen)
GetWindowRect_(GadgetID, rc.RECT)
x - rc\left
y - rc\top
CharPos = SendMessage_(GadgetID,#EM_CHARFROMPOS,0,(x | y <<16))
SendMessage_(GadgetID,#EM_SETSEL,CharPos,CharPos)
EndProcedure
Procedure DupGlobalMem(hMem.i)
; By Zapman
If hMem
len = GlobalSize_(hMem);
If len
source = GlobalLock_(hMem)
If source
dest = GlobalAlloc_(#GMEM_FIXED, len)
If dest
CopyMemory(source,dest,len)
Else
Debug "*************** ERROR in DupGlobalMem ****************"
Debug "dest is null"
Debug "******************************************************"
EndIf
EndIf
GlobalUnlock_(hMem)
Else
Debug "*************** ERROR in DupGlobalMem ****************"
Debug "len mem is null"
Debug "******************************************************"
EndIf
Else
Debug "*************** ERROR in DupGlobalMem ****************"
Debug "hmem is null"
Debug "******************************************************"
EndIf
ProcedureReturn dest;
EndProcedure
Procedure.s GetTymedName(Tymed)
; By Zapman
; This is just for the demo. Your can delete that in your final project
Select tymed
Case #TYMED_GDI
ret$ = "TYMED_GDI"
Case #TYMED_MFPICT
ret$ = "TYMED_MFPICT"
Case #TYMED_ENHMF
ret$ = "TYMED_ENHMF"
Case #TYMED_HGLOBAL
ret$ = "TYMED_HGLOBAL"
Case #TYMED_FILE
ret$ = "TTYMED_FILE"
Case #TYMED_ISTREAM
ret$ = "TYMED_ISTREAM"
Case #TYMED_ISTORAGE
ret$ = "TYMED_ISTORAGE"
EndSelect
ProcedureReturn ret$
EndProcedure
;
Procedure.s GetDropEffectName(dwEffect)
; By Zapman
; This is just for the demo. Your can delete that in your final project
ret$ = ""
If dwEffect = 0
ret$ = "NONE"
Else
If dwEffect&1
ret$ = "COPY/"
EndIf
If dwEffect&2
ret$ + "MOVE/"
EndIf
If dwEffect&4
ret$ + "LINK/"
EndIf
EndIf
If dwEffect<0
ret$+"SCROLL"
EndIf
If Right(ret$,1)="/"
ret$=Left(ret$,Len(ret$)-1)
EndIf
ProcedureReturn ret$
EndProcedure
;
Procedure.s GetClipboardFormatName(Format)
; By Zapman
ret$ = ""
Buffer$ = Space(255)
If GetClipboardFormatName_(Format, @Buffer$, 255) > 0
ret$ = Buffer$
EndIf
ProcedureReturn ret$
EndProcedure
Procedure.s GetFormatName(Format)
; By Zapman
; This is just for the demo. Your can delete that in your final project
Select Format
Case 1
ret$ = "CF_TEXT"
Case 2
ret$ = "CF_BITMAP"
Case 3
ret$ = "CF_METAFILEPICT"
Case 4
ret$ = "CF_SYLK"
Case 5
ret$ = "CF_DIF"
Case 6
ret$ = "CF_TIFF"
Case 7
ret$ = "CF_OEMTEXT"
Case 8
ret$ = "CF_DIB "
Case 9
ret$ = "CF_PALETTE"
Case 10
ret$ = "CF_PENDATA"
Case 11
ret$ = "CF_RIFF"
Case 12
ret$ = "CF_WAVE"
Case 13
ret$ = "CF_UNICODETEXT"
Case 14
ret$ = "CF_ENHMETAFILE"
Case 15
ret$ = "CF_HDROP"
Case 16
ret$ = "CF_LOCALE "
Case 17
ret$ = "CF_MAX/CF_DIBV5"
Case 18 ; (WINVER >= 0x0500)
ret$ = "CF_MAX"
Case $80
ret$ = "CF_OWNERDISPLAY"
Case $81
ret$ = "CF_DSPTEXT"
Case $82
ret$ = "CF_DSPBITMAP"
Case $83
ret$ = "CF_DSPMETAFILEPICT"
Case $8E
ret$ = "CF_DSPENHMETAFILE"
Case $0200
ret$ = "CF_PRIVATEFIRST"
Case $02FF
ret$ = "CF_PRIVATELAST"
Case $0300
ret$ = "CF_GDIOBJFIRST"
Case $03FF
ret$ = "CF_GDIOBJLAST"
Default
ret$ = GetClipboardFormatName(Format)
EndSelect
If ret$ = ""
ret$ = "Unknown ClipFormat: "+Str(Format)
EndIf
ProcedureReturn ret$
EndProcedure
;
Procedure LookupFormatEtc(*dataobject.iDataObjectData,*pFormatEtc.FORMATETC) ; This procedure is used by the DataObject Interface
; It checks each of our formats in turn to see If one matches with *pFormatEtc
;
; This procedure uses our particular iDataObjectData structure
; and depends on the choices we made to store pointers to
; our FORMATETC objects. It'll have to be adapted if you
; organize your implementation in another way.
If *dataobject And *pFormatEtc
For i = 0 To *dataobject\m_count-1
*DataFormatEtc.FORMATETC = *dataobject\m_format[i]
If *DataFormatEtc\tymed & *pFormatEtc\tymed
If *DataFormatEtc\cfFormat = *pFormatEtc\cfFormat
If *DataFormatEtc\dwAspect = *pFormatEtc\dwAspect
ProcedureReturn i ;index of stored format pointer
EndIf
EndIf
EndIf
Next
EndIf
ProcedureReturn -1;
EndProcedure
;
Procedure ComputeDropEffect_OnKey (grfKeyState,dwAllowed)
; By Zapman
dwEffect = dwAllowed;
If(grfKeyState & #MK_CONTROL)
dwEffect = dwAllowed & #DROPEFFECT_COPY;
ElseIf(grfKeyState & #MK_SHIFT)
dwEffect = dwAllowed & #DROPEFFECT_MOVE;
EndIf
ProcedureReturn dwEffect
EndProcedure
Procedure ComputeDropEffect (grfKeyState,PtX,PtY,dwAllowed) ; This procedure is used by the DropTarget interface
; By Zapman
dwEffect = 0;
; 1. check "pt" -> do we allow a drop at the specified coordinates?
; complete the function here if needed
; 2. work out that the drop-effect should be based on grfKeyState
dwEffect = ComputeDropEffect_OnKey (grfKeyState,dwAllowed)
;3 No key-modifiers were specified (Or drop effect Not allowed),
; so base the effect on those allowed by the dropsource
If((dwEffect = 0) Or (dwEffect=dwAllowed))
If(dwAllowed & #DROPEFFECT_COPY) : dwEffect = #DROPEFFECT_COPY : EndIf
If(dwAllowed & #DROPEFFECT_MOVE) : dwEffect = #DROPEFFECT_MOVE : EndIf
EndIf
ProcedureReturn dwEffect
EndProcedure
;
Procedure SetFormatEtc(*etc.FORMATETC,cfFormat,ptd=0,dwAspect=#DVASPECT_CONTENT,lindex=-1,tymed=#TYMED_HGLOBAL)
; By Zapman
*etc\cfFormat = cfFormat;
*etc\ptd = ptd
*etc\dwAspect = dwAspect
*etc\lindex = lindex
*etc\tymed = tymed
EndProcedure
;
Procedure SetStgMedium (*stgmed.STGMEDIUM,hmem,tymed=#TYMED_HGLOBAL,pUnkForRelease=#Null)
; By Zapman
*stgmed\tymed = tymed
*stgmed\hGlobal = hmem
*stgmed\pUnkForRelease = pUnkForRelease
EndProcedure
Procedure StringToHandle(MyString.s,AsciiUnicode)
; By Zapman
If (AsciiUnicode = #PB_Unicode And #PB_Compiler_Unicode) Or (AsciiUnicode = #PB_Ascii And #PB_Compiler_Unicode=0)
convert = 0
SOC = SizeOf(Character)
ElseIf (AsciiUnicode = #PB_Unicode And #PB_Compiler_Unicode=0) ; we need to convert the string to unicode mode
convert = #PB_Unicode
SOC = 2 ; Each Unicode character needs two bytes
Else; we need to convert the string to ascii mode
convert = #PB_Ascii
SOC = 1
EndIf
StringSize = SOC * (Len(MyString)+1) ; add one to the string length to contain the zero ending the string
hData = GlobalAlloc_(#GMEM_MOVEABLE,StringSize)
If hData
pData = GlobalLock_(hData)
If pData
If convert = 0
PokeS(pData,MyString,Len(MyString))
ElseIf convert = #PB_Unicode
PokeS(pData,MyString,Len(MyString),#PB_Unicode)
Else
PokeS(pData,MyString,Len(MyString),#PB_Ascii)
EndIf
Else
GlobalUnlock_(hData)
GlobalFree_(hData)
ProcedureReturn 0
EndIf
GlobalUnlock_(hData)
EndIf
ProcedureReturn hData
EndProcedure
;
Procedure.s HandleToString(hData)
; By Zapman
pData = GlobalLock_(hData)
If pData
ProcedureReturn PeekS(pData)
EndIf
GlobalUnlock_(hData)
EndProcedure
;
Procedure FilesListToHandle(MyString.s)
; copy string To a Global memory block inside a DROPFILE Structure
; the original string must be a list of filenames separated by the chr(10) character
; By Zapman
If Right(MyString,1)<>Chr(10) ; if we have no chr(10) at the end of the list, we add one
MyString + Chr(10)
EndIf
; the string included into the DROPFILES structure must be terminated by a double zero
MyString + Chr(10)
; chr(10) will be replaced by zero, so we'll get a string terminated by a double zero
StringSize = (SizeOf(Character) * Len(MyString)) ; to be compatible with Unicode compilation mode
hData = GlobalAlloc_(#GMEM_MOVEABLE,SizeOf(DROPFILES) + StringSize)
If hData
*pDrop.DROPFILES = GlobalLock_(hData)
If *pDrop
*pDrop\pFiles = SizeOf(DROPFILES) ; size of the DROPFILES structure
pData = *pDrop + *pDrop\pFiles ; data will be paste at the end of the DROPFILES structure
CopyMemory(@MyString,pData, StringSize)
For ct = pData To (pData+StringSize) Step SizeOf(Character) ; replace all chr(10) by zero
If PeekB(ct)=10 : PokeB(ct,0) : EndIf
Next
If #PB_Compiler_Unicode
; If we're compiling for Unicode, set the Unicode flag in the struct to
; indicate it contains Unicode strings.
*pDrop\fWide =#True;
Else
*pDrop\fWide =#False
EndIf
Else
GlobalUnlock_(hData)
GlobalFree_(hData)
ProcedureReturn 0
EndIf
GlobalUnlock_(hData)
EndIf
ProcedureReturn hData
EndProcedure
;
Procedure.s HandleToFilesList(handle)
; Extract FilesList from a DROPFILE Structure
; By Zapman
*pDrop.DROPFILES = GlobalLock_(handle)
*buffer = *pDrop + *pDrop\pFiles ; data is stored at this adress
If *pDrop\fWide =#True ; if FilesList is stored in unicode mode, each character has 2 bytes size
SOC = 2
Else
SOC = 1
EndIf
pos = -SOC
nbzero = 0
Repeat ; look for a double zero at the end of the FilesList
pos + SOC
If PeekB(*buffer+pos)=0
nbzero + 1
Else
nbzero = 0
EndIf
Until nbzero = 2 Or pos>1000 ; If we don't find a double zero, we stop to explore the memory after 1000 character
If nbzero = 2 ; OK, we now have the lenght of the FilesList
StringSize = pos
*buffer2 = AllocateMemory(StringSize)
CopyMemory(*buffer,*buffer2,StringSize) ; duplicate the buffer to leave the original buffer as it is
ct = 0
Repeat
If PeekB(*buffer2+ct)=0
PokeB(*buffer2+ct,10) ; replace zero by chr(10) in all the FilesList
EndIf
ct + SOC
Until ct = (StringSize-SOC)
If *pDrop\fWide =#True
MyString.s = PeekS(*buffer2,#PB_Any,#PB_Unicode)
Else
MyString.s = PeekS(*buffer2,#PB_Any,#PB_Ascii)
EndIf
FreeMemory(*buffer2)
EndIf
GlobalUnlock_(handle)
ProcedureReturn MyString
EndProcedure
;
;***************************************************************************
;
; IMPLEMENTATION OF IDATAOBJET
;
; By Zapman
; From a Nico code (http://www.purebasic.fr/english/viewtopic.php?p=201027&sid=a993c3617a34f5a2ee4ccdaa9a3dd8c4#p201027)
; And from "Implementing IDataObject" CATCH 22 : http://www.catch22.net/tuts/dragdrop/3
;
;***************************************************************************
;
Procedure dataobject_AddRef(*dataobject.iDataObjectData)
Debug "dataobject AddRef : "+Str(*dataobject\Refcount+1)
*dataobject\Refcount=*dataobject\Refcount+1
ProcedureReturn *dataobject\Refcount
EndProcedure
Procedure dataobject_Release(*dataobject.iDataObjectData)
Debug "dataobject Release : "+Str(*dataobject\Refcount-1)
*dataobject\Refcount=*dataobject\Refcount-1
If *dataobject\Refcount
ProcedureReturn *dataobject\Refcount
Else
ForEach IDataObject()
If IDataObject()=*dataobject
For ct = 1 To *dataobject\m_count
If *dataobject\m_stgmed[ct]
*medium.STGMEDIUM = *dataobject\m_stgmed[ct]
If *medium\tymed<>#TYMED_FILE ; I don't want to delete the source file if any
; ReleaseStgMedium_(*medium) ; free memory
EndIf
EndIf
Next
DeleteElement (IDataObject())
Debug "dataobject is now deleted."
Break
EndIf
Next
ProcedureReturn 0
EndIf
EndProcedure
Procedure dataobject_QueryInterface(*dataobject.IDataobject, iid, *ppvObject.Integer)
If CompareMemory (iid, ?IID_IUnknown, 16)=1 Or CompareMemory (iid, ?IID_IDataObject, 16)=1
Debug "dataobject QueryInterface"
*ppvObject\i = *dataobject
*dataobject\AddRef()
ProcedureReturn #S_OK
Else
*ppvObject\i=0
ProcedureReturn #E_NOINTERFACE
EndIf
EndProcedure
Procedure dataobject_GetData(*dataobject.iDataObjectData,*pformatetcIn.FORMATETC, *pmedium.STGMEDIUM)
; This implementation is not complete !
; You'll have to do some work if you want to use it with
; data which is different from hGlobal
If *pformatetcIn = 0
Debug "dataobject GetData : *pformatetcIn is null!!"
ProcedureReturn #DV_E_FORMATETC
EndIf
If *pmedium = 0
Debug "dataobject GetData : *pmedium is null!!"
ProcedureReturn #STG_E_MEDIUMFULL
EndIf
Index = LookupFormatEtc(*dataobject,*pformatetcIn)
If Index = -1
Debug "dataobject GetData for : " + GetFormatName(*pformatetcIn\cfFormat)+" ---> NOT AVAILABLE"
ProcedureReturn #DV_E_FORMATETC
Else
*medium.STGMEDIUM = *dataobject\m_stgmed[Index]
If *medium\tymed = #TYMED_HGLOBAL ; need to be adapted if the data in not hGlobal !!!
Debug "dataobject GetData for : " + GetFormatName(*pformatetcIn\cfFormat)+" ---> OK"
*pmedium\tymed = *medium\tymed
*pmedium\hGlobal = DupGlobalMem(*medium\hGlobal)
*pmedium\pUnkForRelease = *medium\pUnkForRelease
ProcedureReturn #S_OK
Else
Debug "dataobject GetData for : " + GetTymedName(*medium\tymed)+" ---> NOT IMPLEMENTED"
ProcedureReturn #E_NOTIMPL
EndIf
EndIf
EndProcedure
Procedure dataobject_GetDataHere(*dataobject, *pformatetc, *pmedium )
; This implementation is not done !
Debug "dataobject GetDataHere"
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure dataobject_QueryGetData(*dataobject.iDataObjectData, *pformatetc.FORMATETC )
If *pFormatEtc
If LookupFormatEtc(*dataobject,*pFormatEtc) = -1
Debug "dataobject QUERY GetData for : " + GetFormatName(*pformatetc\cfFormat)+" ---> NOT AVAILABLE"
ProcedureReturn #DV_E_FORMATETC
Else
Debug "dataobject QUERY GetData for : " + GetFormatName(*pformatetc\cfFormat)+" ---> OK"
ProcedureReturn #S_OK
EndIf
Else
Debug "dataobject QUERY GetData : formatetc is null!!"
ProcedureReturn #DV_E_FORMATETC
EndIf
EndProcedure
Procedure dataobject_GetCanonicalFormatEtc(*dataobject, *pformatectIn ,*pformatetcOut )
; This implementation is not done !
Debug "dataobject GetCanonicalFormatEtc"
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure dataobject_SetData(*dataobject.iDataObjectData, *pformatetc.FORMATETC , *pmedium.STGMEDIUM, fRelease )
;
Debug "dataobject SetData with: " +GetFormatName(*pformatetc\cfFormat)+" - "+GetTymedName(*pmedium\tymed)
;
If *dataobject\m_count < #DataMax
*dataobject\m_format[*dataobject\m_count] = *pformatetc
*dataobject\m_stgmed[*dataobject\m_count] = *pmedium
*dataobject\m_count + 1
RetValue = #S_OK
Else
Debug "dataobject SetData with: " +GetFormatName(*pformatetc\cfFormat)+" - "+GetTymedName(*pmedium\tymed)
Debug "dataobject SetData: Out of memory -> Limit of "+Str(#DataMax)+" data reached"
RetValue = #E_OUTOFMEMORY
EndIf
;
; ------------------- Here is a small demo about reading data added to a HDrop DataObject by Windows Explorer
;
If GetClipboardFormatName(*pformatetc\cfFormat)="TargetCLSID" And *pmedium\tymed=#TYMED_HGLOBAL
;
; We receive info from the target
source = GlobalLock_(*pmedium\hGlobal)
Debug "Target application is: " +ProgNameFromCLSID(source) ; Convert CLSID To String
GlobalUnlock_(*pmedium\hglobal)
EndIf
;
; ---------------------------------------------------------------------------------------------------------
;
ProcedureReturn RetValue
EndProcedure
Procedure dataobject_EnumFormatEtc(*dataobject.iDataObjectData, dwDirection , *ppenumFormatEtc.IEnumFORMATETC)
If dwDirection = #DATADIR_GET
; Will store a tab of our formatetc objects into a *ppenumFormatEtc enumeration
; ATTENTION : our m_format array is an array of POINTERS to formatetc objects
; What we need now is an array of formatetc objects!!!!
; So, we'll create this array now
Dim FormatEtcArray.FormatEtc(*dataobject\m_count-1)
For i = 0 To *dataobject\m_count-1
CopyMemory(*dataobject\m_format[i],@FormatEtcArray(i),SizeOf(FormatEtc))
Next
SHCreateStdEnumFmtEtc_(*dataobject\m_count,@FormatEtcArray(0),*ppenumFormatEtc)
Debug "dataobject EnumFormatEtc"
ProcedureReturn #S_OK
Else ; EnumFormatEtc for SetData is not implemented
ProcedureReturn #E_NOTIMPL
EndIf
EndProcedure
Procedure dataobject_DAdvise(*dataobject,*pformatetc, advf, *pAdvSink, *pdwConnection)
; This implementation is not done !
Debug "dataobject DAdvise"
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure dataobject_DUnadvise(*dataobject, dwConnection)
; This implementation is not done !
Debug "dataobject DUnadvise"
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure dataobject_EnumDAdvise(*dataobject, *ppenumAdvise)
; This implementation is not done !
Debug "dataobject EnumDAdvise"
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure CreateDataObject()
OleInitialize_(0)
AddElement (IDataObject())
IDataObject()\pIntf=?VTable_IDataObject_Interface
IDataObject()\m_count = 0
ProcedureReturn IDataObject()
EndProcedure
;
;
;***************************************************************************
;
; IMPLEMENTATION OF IDropSource
;
; By Zapman
:
;
; The goal of my implementation is to be able to drag a virtual file to Explorer
; or to any other application able to receive a file by the drag and drop way.
; By "virtual file", I mean that the file does'nt yet exist when the user begin
; to drag its name. It will be created on the fly when the receiving application
; will ask for the data after a successfull drop.
;
; I need this when developping a FTP client: the user drag a file from the FTP
; directory to Explorer, THEN and IF the drop is successful, I download the file
; from the FTP and give Explorer the data.
;
;
;***************************************************************************
;
#DRAGDROP_S_USEDEFAULTCURSORS = $00040102
Procedure DropSource_AddRef(*dropsource.iDropSourceData)
Debug "*DropSource AddRef : "+Str(*dropsource\Refcount+1)
*dropsource\Refcount=*dropsource\Refcount+1
ProcedureReturn *dropsource\Refcount
EndProcedure
Procedure DropSource_Release(*dropsource.iDropSourceData)
Debug "*DropSource Release : "+Str(*dropsource\Refcount-1)
*dropsource\Refcount=*dropsource\Refcount-1
If *dropsource\Refcount > 0
ProcedureReturn *dropsource\Refcount
Else
ForEach IDropSource()
If IDropSource()=*dropsource
Debug "IDropSource is now deleted"
DeleteElement(IDropSource()) : Break
EndIf
Next
*dropsource=0
ProcedureReturn 0
EndIf
EndProcedure
Procedure DropSource_QueryInterface(*dropsource.IDropSource, iid, *ppvObject.Integer)
If CompareMemory(iid, ?IID_IUnknown, 16)=1 Or CompareMemory(iid, ?IID_IDropSource, 16)=1
Debug "*DropSource QueryInterface"
*ppvObject\i = *dropsource
*dropsource\AddRef()
ProcedureReturn #S_OK
Else
*ppvObject\i =0
ProcedureReturn #E_NOINTERFACE
EndIf
EndProcedure
Procedure DropSource_QueryContinueDrag(*dropsource.iDropSourceData,fEscapePressed.b, grfKeyState.l)
;Can return S_OK, DRAGDROP_S_DROP, or DRAGDROP_S_CANCEL
Debug "*DropSource_QueryContinueDrag : "+Str(fEscapePressed)+" - "+Str(grfKeyState)
If(fEscapePressed = #True)
ProcedureReturn #DRAGDROP_S_CANCEL
ElseIf (grfKeyState & #MK_LBUTTON)=0
;
; I Choose to allow only COPY and MOVE, but you can make a different choice
AllowedEffect = ComputeDropEffect_OnKey (grfKeyState,#DROPEFFECT_COPY|#DROPEFFECT_MOVE)
If *dropsource\LastEffect & AllowedEffect
;
Debug "*DropSource -----------------> Drop occured !!"
; -----------------------------------------------------------
;
; Particular implementation for my project :
:
; What follows will create files on fly when the user drops
; a filenam with success
;
*Dataobject.IDataObject = *dropsource\pDataObject ; retreive the data object from its pointer
; we did store the pointer using "CreateDropSource"
SetFormatEtc(pformatetc.FORMATETC,#CF_HDROP)
SetStgMedium (pmedium.STGMEDIUM,0)
If *Dataobject\GetData(pformatetc,pmedium) = #S_OK ; Check if the data object contains a Files list
If pmedium\tymed = #TYMED_HGLOBAL
Files$ = HandleToFilesList(pmedium\hGlobal)
index = 1
While StringField(Files$,index,Chr(10))
FileName$ = StringField(Files$,index,Chr(10))
Debug "---------------------------------"
Debug "Creating "+FileName$+" on the fly"
Debug "---------------------------------"
If CreateFile(0,FileName$)
WriteString(0,"Test content"+Str(index))
CloseFile(0)
EndIf
index + 1
Wend
EndIf
EndIf
; -----------------------------------------------------------
EndIf
ProcedureReturn #DRAGDROP_S_DROP
Else
ProcedureReturn #S_OK
EndIf
EndProcedure
Procedure DropSource_GiveFeedback(*dropsource.iDropSourceData,dwEffect.l)
;Can return S_OK or DRAGDROP_S_USEDEFAULTCURSORS
Debug "*DropSource_GiveFeedback : "+Str(dwEffect)+" ("+GetDropEffectName(dwEffect)+")"
*dropsource\LastEffect = dwEffect
ProcedureReturn #DRAGDROP_S_USEDEFAULTCURSORS
EndProcedure
Procedure CreateDropSource(*Dataobject.IDataobjectData)
OleInitialize_(0)
AddElement (IDropSource())
IDropSource()\pIntf=?VTable_IDropSource_Interface
IDropSource()\pDataobject = *Dataobject ; store a pointer to the current data object
ProcedureReturn IDropSource()
EndProcedure
;
;
;***************************************************************************
;
; IMPLEMENTATION OF IDroptarget
;
; By Zapman
;
;***************************************************************************
;
Procedure DropTarget_AddRef(*DropTarget.iDropTargetData)
Debug " DropTarget AddRef : "+Str(*DropTarget\Refcount+1)
*DropTarget\Refcount=*DropTarget\Refcount+1
ProcedureReturn *DropTarget\Refcount
EndProcedure
Procedure DropTarget_Release(*DropTarget.iDropTargetData)
Debug " DropTarget Release : "+Str(*DropTarget\Refcount-1)
*DropTarget\Refcount=*DropTarget\Refcount-1
If *DropTarget\Refcount > 0
ProcedureReturn *DropTarget\Refcount
Else
ForEach IDropTarget()
If IDropTarget()=*DropTarget
Debug "DropTarget is now deleted"
DeleteElement(IDropTarget()) : Break
EndIf
Next
*DropTarget=0
ProcedureReturn 0
EndIf
EndProcedure
Procedure DropTarget_QueryInterface(*DropTarget.IDropTarget, iid, *ppvObject.Integer)
If CompareMemory(iid, ?IID_IUnknown, 16)=1 Or CompareMemory(iid, ?IID_IDropTarget, 16)=1
Debug " DropTarget QueryInterface"
*ppvObject\i = *DropTarget
*DropTarget\AddRef()
ProcedureReturn #S_OK
Else
*ppvObject\i=0
ProcedureReturn #E_NOINTERFACE
EndIf
EndProcedure
;
Procedure DropTarget_DragEnter(*DropTarget.IDropTarget, *Dataobject.IDataobject, grfKeyState.l, cPoint.q, *pdwEffect.Long)
ptx.l = cPoint & $FFFFFFFF
pty.l = cPoint >> 32
;
info$ = "DragEnter : grfKeyState = "+Str(grfKeyState)+" - point : "+Str(ptx)+"/"+Str(pty)+" - pdwEffect = "+GetDropEffectName(*pdwEffect\l)
Debug " DropTarget_"+info$
If *pdwEffect = 0
ProcedureReturn #E_INVALIDARG
Else
*Target.iDropTargetData = *DropTarget
SetFocus_(GadgetID(*Target\TargetGadget))
*Dataobject\EnumFormatEtc(#DATADIR_GET,@ppenumFormatEtc.IEnumFORMATETC) ; enumerate all the formats contained by the data object
*Target\FormatList = ""
*Target\FormatMatchs = 0
While ppenumFormatEtc\Next(1,@TempFormatEtc.FormatEtc, #Null) = #S_OK ; check if one of them match with the formats accepted by our drop target
If FindString(*Target\AcceptedFormats,"/"+Str(TempFormatEtc\cfFormat)+"/",0)
*Target\FormatMatchs = 1
EndIf
;
If FindString(*Target\FormatList,GetFormatName(TempFormatEtc\cfFormat),0)=0 ; For Demo only
*Target\FormatList + GetFormatName(TempFormatEtc\cfFormat)+" - "; For Demo only
Debug "---------------------------------------"+GetFormatName(TempFormatEtc\cfFormat)
EndIf; For Demo only
;GlobalFree_(@TempFormatEtc)
Wend
Debug "-----------"
; ------------- For Demo ------------
If Right(*Target\FormatList,3)=" - "
*Target\FormatList = Left(*Target\FormatList,Len(*Target\FormatList)-3)
EndIf
If IsGadget(*Target\InfoWinHdl)
If *Target\FormatList
info$ + Chr(13) + "DragSource available formats: "+ *Target\FormatList
EndIf
SetGadgetText(*Target\InfoWinHdl,info$)
EndIf
; -----------------------------------
Effect = *pdwEffect\l & ComputeDropEffect (grfKeyState,PtX,PtY,#DROPEFFECT_COPY); our DropTarget implementation will only accept DROPEFFECT_COPY from the source
If Effect = 0
*Target\FormatMatchs = 0
EndIf
*pdwEffect\l = Effect ; set the return value
If *Target\FormatMatchs
If GadgetType(*Target\TargetGadget) = #PB_GadgetType_String Or GadgetType(*Target\TargetGadget) = #PB_GadgetType_Editor
SetCharPosFromXY(GadgetID(*Target\TargetGadget),ptx,pty)
EndIf
EndIf
ProcedureReturn #S_OK
EndIf
EndProcedure
;
Procedure DropTarget_DragOver(*DropTarget.IDropTarget,grfKeyState.l, cPoint.q,*pdwEffect.long)
ptx.l = cPoint & $FFFFFFFF
pty.l = cPoint >> 32
*Target.iDropTargetData = *DropTarget
; ------------- For Demo ------------
info$ = "DragOver "+" - point : "+Str(ptx)+"/"+Str(pty)+" - grfKeyState = "+Str(grfKeyState)+" - DropEffect : "+GetDropEffectName(*pdwEffect\l)
Debug " DropTarget_"+info$
If *Target\FormatList ; in our implementation, the Format List has be initialized by DragEnter
info$ + Chr(13) + "DragSource available formats: "+ *Target\FormatList
EndIf
If IsGadget(*Target\InfoWinHdl)
SetGadgetText(*Target\InfoWinHdl,info$)
EndIf
; -----------------------------------
If *Target\FormatMatchs = 0 ; The formats available from the drop source and accepted by our target don't match
*pdwEffect\l = #DROPEFFECT_NONE ; set the return value
Else
If GadgetType(*Target\TargetGadget) = #PB_GadgetType_String Or GadgetType(*Target\TargetGadget) = #PB_GadgetType_Editor
SetCharPosFromXY(GadgetID(*Target\TargetGadget),ptx,pty)
EndIf
EndIf
ProcedureReturn #S_OK
EndProcedure
Procedure DropTarget_DragLeave(*DropTargetData.iDropTargetData)
; ------------- For Demo ------------
Debug " DropTarget_DragLeave"
SetGadgetText(*DropTargetData\InfoWinHdl,"DragLeave")
; -----------------------------------
ProcedureReturn #S_OK
EndProcedure
Procedure DropTarget_Drop(*DropTarget.IDropTarget,*Dataobject.IDataobject,grfKeyState.l,cPoint.q,*pdwEffect.long)
ptx.l = cPoint & $FFFFFFFF
pty.l = cPoint >> 32
; ------------- For Demo ------------
info$ = "Drop : "+" - point : "+Str(ptx)+"/"+Str(pty)+" - grfKeyState = "+Str(grfKeyState)+" - DropEffect : "+GetDropEffectName(*pdwEffect\l)
Debug " DropTarget_"+info$
; -----------------------------------
*Target.iDropTargetData = *DropTarget
If *Target\FormatMatchs = 0 ; The formats available from the drop source and those accepted by our target don't match
*pdwEffect\l = #DROPEFFECT_NONE ; set the return value
ProcedureReturn #S_OK
EndIf
; -----------------------------------------------------------
;
; Particular implementation for this project :
;
; What must be done when the drop is successfull depends on the type of target gagdet
; and on what your application is made for.
; So, you'll have to adapt the following code.
If GadgetType(*Target\TargetGadget) = #PB_GadgetType_String Or GadgetType(*Target\TargetGadget) = #PB_GadgetType_Editor
SFormat = 0
If #PB_Compiler_Unicode
; we'll try to get the text in unicode mode
; if it does'nt work, we'll get it in ascii mode
SetFormatEtc(pformatetc.FORMATETC,#CF_UNICODETEXT)
If *Dataobject\QueryGetData(pformatetc) = #S_OK
SFormat = #PB_Unicode
EndIf
EndIf
If SFormat = 0
SetFormatEtc(pformatetc.FORMATETC,#CF_TEXT)
SFormat = #PB_Ascii
EndIf
If SFormat = #PB_Unicode Or *Dataobject\QueryGetData(pformatetc) = #S_OK
SetStgMedium (pmedium.STGMEDIUM,0)
If *Dataobject\GetData(pformatetc,pmedium) = #S_OK
If pmedium\tymed = #TYMED_HGLOBAL
MyData = GlobalLock_(pmedium\hGlobal)
MyString.s = PeekS(MyData,#PB_Any,SFormat)
GlobalUnlock_(pmedium\hGlobal)
SendMessage_(GadgetID(*Target\TargetGadget), #EM_REPLACESEL, #True, @MyString)
;
*pdwEffect\l = #DROPEFFECT_COPY ; set the return value
;
; ------------- For Demo ------------
If SFormat = #PB_Ascii
Info$ + Chr(13)+"Text has been dropped in ascii mode (CF_TEXT/TYMED_HGLOBAL)"
Else
Info$ + Chr(13)+"Text has been dropped in Unicode mode (CF_UNICODETEXT/TYMED_HGLOBAL)"
EndIf
; -----------------------------------
EndIf
EndIf
EndIf
EndIf
; -----------------------------------------------------------
;
; ------------- For Demo ------------
If IsGadget(*Target\InfoWinHdl)
SetGadgetText(*Target\InfoWinHdl,info$)
EndIf
; -----------------------------------
ProcedureReturn #S_OK
EndProcedure
Procedure CreateDropTarget(TargetGadget,InfoGadget,AcceptedFormats$)
OleInitialize_(0)
AddElement (IDropTarget())
IDropTarget()\pIntf=?VTable_IDropTarget_Interface
IDropTarget()\TargetGadget = TargetGadget ; Register a handle to the target gadget
IDropTarget()\InfoWinHdl = InfoGadget ; Register a handle to the info gadget
IDropTarget()\AcceptedFormats = "/"+AcceptedFormats$+"/" ; Register the list of formats accepted by our targets
; Example : if our target accepts CF_TEXT (value=1) and CF_BITMAP (value=2)
; The AcceptedFormats$ input parameter must be a string containing "1/2"
;
If #PB_Compiler_Unicode
If FindString(IDropTarget()\AcceptedFormats,"/1/",0) And FindString(IDropTarget()\AcceptedFormats,"/13/",0) = 0
; if the gadget accepts CF_TEXT and the program is running in Unicode mode
IDropTarget()\AcceptedFormats +"13/" ; we'll also accept CF_UNICODETEXT"
EndIf
EndIf
RegisterDragDrop_(GadgetID(TargetGadget),IDropTarget()) ; declare our gadget as a potential drop target
ProcedureReturn IDropTarget()
EndProcedure
;
;
;***************************************************************************
;
; GENERAL FUNCTIONS FOR DRAG AND DROP
;
; By Zapman
;
;***************************************************************************
;
Procedure OleSetClipboardWithDebug(pDataObject)
; By Zapman
result = OleSetClipboard_(pDataObject)
If result = #CLIPBRD_E_CANT_OPEN
Debug "The OpenClipboard function used within OleSetClipboard failed."
ElseIf result = #CLIPBRD_E_CANT_EMPTY
Debug "The EmptyClipboard function used within OleSetClipboard failed."
ElseIf result = #CLIPBRD_E_CANT_CLOSE
Debug "The CloseClipboard function used within OleSetClipboard failed."
ElseIf result = #CLIPBRD_E_CANT_SET
Debug "The SetClipboardData function used within OleSetClipboard failed."
ElseIf result = #E_NOTIMPL
Debug "Member function contains no implementation."
ElseIf result = -2147221008
Debug "OleInitialize has not been called"
ElseIf result
Debug "Error with OleSetClipboard : "+Str(result)
SetClipboardText("Error with OleSetClipboard : "+Str(result))
EndIf
ProcedureReturn result
EndProcedure
;
Procedure DoDragDropWithDebug(pDataObject, pDropSource ,DROPEFFECT,pdwEffect)
; By Zapman
result = DoDragDrop_(pDataObject, pDropSource ,DROPEFFECT,pdwEffect)
If result = #DRAGDROP_S_DROP
Debug "The OLE drag-and-drop operation was successful."
ElseIf result = #DRAGDROP_S_CANCEL
Debug "The OLE drag-and-drop operation was canceled."
ElseIf result = -2147221008
Debug "OleInitialize has not been called"
ElseIf result = #E_INVALIDARG
Debug "Error with DoDragDrop : Invalid argument"
ElseIf result = #DV_E_FORMATETC
Debug "Invalid FORMATETC structure"
ElseIf result = -1;#E_UNSPEC
Debug "Unexpected error occurred."
ElseIf result
Debug "Error with DoDragDrop : "+Str(result)
EndIf
ProcedureReturn result
EndProcedure
;
;***************************************************************************
;
; DATA SECTION
;
; By Zapman
;
;***************************************************************************
DataSection
VTable_IDataObject_Interface:
Data.i @dataobject_QueryInterface(), @dataobject_AddRef(), @dataobject_Release()
Data.i @dataobject_GetData(),@dataobject_GetDataHere(),@dataobject_QueryGetData()
Data.i @dataobject_GetCanonicalFormatEtc(),@dataobject_SetData(),@dataobject_EnumFormatEtc()
Data.i @dataobject_DAdvise(),@dataobject_DUnadvise(),@dataobject_EnumDAdvise()
VTable_IDropSource_Interface:
Data.i @DropSource_QueryInterface(), @DropSource_AddRef(), @DropSource_Release()
Data.i @DropSource_QueryContinueDrag(), @DropSource_GiveFeedback()
VTable_IDropTarget_Interface:
Data.i @DropTarget_QueryInterface(), @DropTarget_AddRef(), @DropTarget_Release()
Data.i @DropTarget_DragEnter(), @DropTarget_DragOver(),@DropTarget_DragLeave(), @DropTarget_Drop()
IID_IDataObject: ;{0000010e-0000-0000-C000-000000000046"}
Data.l $0000010E
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
IID_IDropSource: ;{00000121-0000-0000-C000-000000000046}
Data.l $00000121
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
IID_IDropTarget: ;{00000122-0000-0000-C000-000000000046}
Data.l $00000122
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
IID_IUnknown: ;"{00000000-0000-0000-C000-000000000046}"
Data.l $00000000
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
EndDataSection
Code: Select all
;
; Drag virtual files from List View to Explorer using OLE functions
;
; Translated for PureBasic by Zapman
;
; From "How to Implement Drag and Drop Between Your Program and Explorer" CATCH 22 : http://www.catch22.net/tuts/dragdrop/3
XIncludeFile "DataObject.pb"
appdir$=Space(255) : GetCurrentDirectory_(255,appdir$) ; get the current directory of our application
If OpenWindow(0, 0, 0, 410, 505, "Drag virtual files from List View to Explorer", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)=0:End:EndIf
If CreateGadgetList(WindowID(0))=0:End:EndIf
GText = TextGadget(#PB_Any,10,10,390,30,"Drag those file names to the finder desktop!!")
SetGadgetColor(GText, #PB_Gadget_BackColor, RGB(240,240,155))
If LoadFont(0, "Arial", 12,#PB_Font_Bold)
SetGadgetFont(GText, FontID(0))
EndIf
ELIGRef = ListIconGadget(#PB_Any, 10, 50, 390, 200, "Files", 360, #PB_ListIcon_AlwaysShowSelection|#PB_ListIcon_MultiSelect|#PB_ListIcon_FullRowSelect)
AddGadgetItem(ELIGRef, -1, "testfile.txt")
AddGadgetItem(ELIGRef, -1, "testfile2.txt") ; Those files don't exist ! They we'll be generated on the fly by our IDataObject Interface
BCopy = ButtonGadget(#PB_Any,10,270,150,20,"Copy selection to clipboard")
OText = OptionGadget(#PB_Any,200,270,100,20,"As text")
OFilesList = OptionGadget(#PB_Any,310,270,100,20,"As files list")
SetGadgetState(OFilesList,1)
DisableGadget(BCopy,1)
Frame3DGadget(#PB_Any, 10, 310, 390, 1, "",#PB_Frame3D_Flat)
TextGadget(#PB_Any,10,330,390,20,"Drag viewer")
SDragViewer = StringGadget(#PB_Any,10,350,390,90,"Drag something here to see what it is...")
TDragInfo = TextGadget(#PB_Any,10,445,390,55,"")
*pDropTarget.IDropTarget = CreateDropTarget(SDragViewer,TDragInfo,Str(#CF_TEXT)) ; Create a IDropTarget Interface for the SDragViewer gadget
; Our gadget will only accept #CF_TEXT
Repeat
EventID = WaitWindowEvent()
If EventID=#PB_Event_Gadget
If EventGadget()=OText Or EventGadget()=OFilesList
If EventGadget()=OFilesList
setgadgettext(GText,"Drag those file names to the finder desktop!!")
DisableGadget(BCopy,1)
Else
setgadgettext(GText,"Drag those file names to a text application!!")
DisableGadget(BCopy,0)
EndIf
EndIf
If (EventGadget()=ELIGRef And EventType() = #PB_EventType_DragStart) Or EventGadget()=BCopy
Files$ = ""
For i = 0 To CountGadgetItems(ELIGRef)-1
If GetGadgetItemState(ELIGRef, i) & #PB_ListIcon_Selected
Files$ + appdir$+"\"+GetGadgetItemText(ELIGRef, i,0) + Chr(10)
EndIf
Next i
If Files$ = ""
Files$ = "Empty selection !!!"
EndIf
*pDataObject.IDataobject = CreateDataObject() ; Create a IDataObject Interface
If GetGadgetState(OText)
If #PB_Compiler_Unicode ; If we compile in Unicode Mode, we'll register two different formats in our DataObject
;
SetFormatEtc(@etcU.FORMATETC,#CF_UNICODETEXT) ; register the format in a FORMATETC structure
hDataU = StringToHandle(Files$,#PB_Unicode); Copy the text string To a Global memory block.
SetStgMedium (@stgmedU.STGMEDIUM,hDataU) ; include the handle into a STGMEDIUM Structure
*pDataObject\setdata(@etcU,@stgmedU, 1) ; Set the DataObject with our data
EndIf
SetFormatEtc(@etc.FORMATETC,#CF_TEXT) ; register the format in a FORMATETC structure
hData = StringToHandle(Files$,#PB_Ascii); Copy the text string To a Global memory block.
SetStgMedium (@stgmed.STGMEDIUM,hData) ; include the handle into a STGMEDIUM Structure
*pDataObject\setdata(@etc,@stgmed, 1) ; Set the DataObject with our data
Else
hgDrop = FilesListToHandle(Files$) ; copy string To a Global memory block inside a DROPFILE Structure
SetStgMedium (@stgmed.STGMEDIUM,hgDrop); include the handle into a STGMEDIUM Structure
SetFormatEtc(@etc.FORMATETC,#CF_HDROP); register the format in a FORMATETC structure
*pDataObject\setdata(@etc,@stgmed, 1) ; Set the DataObject with our data
EndIf
If (EventGadget()=ELIGRef And EventType() = #PB_EventType_DragStart)
Debug "DragStart"
*pDropSource.IDropSource = CreateDropSource(*pDataObject) ; Create a IDropSource Interface
DoDragDropWithDebug(*pDataObject, *pDropSource ,#DROPEFFECT_COPY,@pdwEffect.l)
Else
OleSetClipboardWithDebug(*pDataObject)
OleFlushClipboard_();
Debug "The clipboard is now containing : ''"+GetClipboardText()+"''" ; to see if it works
EndIf
EndIf
EndIf
Until EventID=#PB_Event_CloseWindow
End
IMPORTANT :implementation of IDataObject is rarely necessary, you can often simply implement only IDropSource or IDropTarget (as needeed). I will complete this post later showing how one can use an IDataObject generated by Windows without having to recreate it from scratch.
