Habe den Fehler gefunden. Manchmal ist man einfach nur Blind.
Code: Alles auswählen
;/------------------------
;|
;| Outlook_DragAndDrop.pbi V1.00
;|
;| original code from mesozorn:
;| http://www.purebasic.fr/english/viewtopic.php?p=460210#p460210
;|
;| implemented ideas from srod:
;| http://www.purebasic.fr/english/viewtopic.php?p=438986#p438986
;|
;| just made it a little more "user friendly"
;|
;| Code from https://www.purebasic.fr/english/viewtopic.php?p=460437&sid=26be0bc2f4cf794347e2130dedd273b2#p460437
;| 24.03.2025 Bugfixes DropTarget_Drop() - FilesSize = 2 byte
;|
;/------------------------
DeclareModule OutlookDragDrop
Declare SetGadgetOutlookDrop(Gadget, StorageFolder.s, MessageWindow, MessageWindowEvent)
OleInitialize_(0)
EndDeclareModule
Module OutlookDragDrop
EnableExplicit
Structure _IDropTarget
*vTable
refCount.i
blnAllowDrop.i
hWnd.i
EndStructure
Structure FILEDESCRIPTOR
dwFlags.l
clsid.CLSID
sizel.SIZE
pointl.POINT
dwFileAttributes.l
ftCreationTime.FILETIME
ftLastAccessTime.FILETIME
ftLastWriteTime.FILETIME
nFileSizeHigh.l
nFileSizeLow.l
cFileName.c[#MAX_PATH]
EndStructure
Structure FILEGROUPDESCRIPTOR
cItems.l
fgd.FILEDESCRIPTOR[0]
EndStructure
Structure STATSTG
pwcsName.l
type.l
cbSize.q
mtime.FILETIME
ctime.FILETIME
atime.FILETIME
grfMode.f
grfLocksSupported.l
clsid.GUID
grfStateBits.l
reserved.l
EndStructure
Structure ODD_MAP
Gadget.i
MessageWindow.i
MessageWindowEvent.i
Folder.s
EndStructure
Global cf_email = RegisterClipboardFormat_("Internet Message (rfc822/rfc1522)")
Global cf_content = RegisterClipboardFormat_(#CFSTR_FILECONTENTS)
Global cf_descrip = RegisterClipboardFormat_(#CFSTR_FILEDESCRIPTOR)
Global NewMap ODD.ODD_MAP()
Macro M_SEND_DROP_FILES
If DroppedFiles
DroppedFiles = Left(DroppedFiles, Len(DroppedFiles) - 1)
If ODD()\MessageWindowEvent And IsWindow(ODD()\MessageWindow)
buffer = AllocateMemory(StringByteLength(DroppedFiles) + 2)
If buffer
PokeS(buffer, DroppedFiles)
PostEvent(ODD()\MessageWindowEvent, ODD()\MessageWindow, ODD()\Gadget, #False, buffer)
;Debug "Filesystem copy successful for: "+PeekS(buffer)
EndIf
EndIf
DroppedFiles = ""
EndIf
EndMacro
;-Drop enable function.
;-Internal functions.
Procedure DropTarget_SetEffects(grfKeyState, *pdwEffect.LONG)
If grfKeyState & #MK_CONTROL
*pdwEffect\l = #DROPEFFECT_COPY
ElseIf *pdwEffect\l = #DROPEFFECT_LINK | #DROPEFFECT_COPY
*pdwEffect\l = #DROPEFFECT_COPY
EndIf
EndProcedure
;-iDropTarget methods.
;/////////////////////////////////////////////////////////////////////////////////
Procedure DropTarget_QueryInterface(*this._IDropTarget, iid, *ppvObject.INTEGER)
Protected Result
If CompareMemory(iid, ?IID_IUnknown, SizeOf(CLSID)) Or CompareMemory(iid, ?IID_IDropTarget, SizeOf(CLSID))
*ppvObject\i = *this
*this\refCount + 1
Result = #S_OK
Else
*ppvObject\i = 0
Result = #E_NOINTERFACE
EndIf
ProcedureReturn Result
EndProcedure
;/////////////////////////////////////////////////////////////////////////////////
;/////////////////////////////////////////////////////////////////////////////////
Procedure DropTarget_AddRef(*this._IDropTarget)
*this\refCount + 1
ProcedureReturn 0
EndProcedure
;/////////////////////////////////////////////////////////////////////////////////
;/////////////////////////////////////////////////////////////////////////////////
Procedure DropTarget_Release(*this._IDropTarget)
Protected Result
*this\refCount - 1
If *this\refCount > 0
Result = *this\refCount
Else
FreeMemory(*this)
EndIf
ProcedureReturn Result
EndProcedure
;/////////////////////////////////////////////////////////////////////////////////
;/////////////////////////////////////////////////////////////////////////////////
Procedure DropTarget_DragEnter(*this._IDropTarget, dataObject.IDataobject, grfKeyState, pt.q, *pdwEffect.LONG)
Protected Result = #S_OK, thisFormatEtc.FORMATETC
*this\blnAllowDrop = #False
If *pdwEffect = 0
Result = #E_INVALIDARG
Else
With thisFormatEtc
\cfFormat = #CF_HDROP
\ptd = #Null
\dwAspect = #DVASPECT_CONTENT
\lindex = -1
\tymed = #TYMED_HGLOBAL
EndWith
If dataObject\QueryGetData(thisFormatEtc) = #S_OK
*this\blnAllowDrop = #True
DropTarget_SetEffects(grfKeyState, *pdwEffect)
EndIf
With thisFormatEtc
\cfFormat = cf_descrip
\ptd = #Null
\dwAspect = #DVASPECT_CONTENT
\lindex = -1
\tymed = #TYMED_HGLOBAL
EndWith
If dataObject\QueryGetData(thisFormatEtc) = #S_OK
*this\blnAllowDrop = #True
DropTarget_SetEffects(grfKeyState, *pdwEffect)
EndIf
EndIf
ProcedureReturn Result
EndProcedure
;/////////////////////////////////////////////////////////////////////////////////
;/////////////////////////////////////////////////////////////////////////////////
Procedure DropTarget_DragOver(*this._IDropTarget, grfKeyState, pt.q, *pdwEffect.LONG)
Protected Result = #S_OK
If *pdwEffect = 0
Result = #E_INVALIDARG
Else
If *this\blnAllowDrop
DropTarget_SetEffects(grfKeyState, *pdwEffect)
Else
*pdwEffect\l = #DROPEFFECT_NONE
EndIf
EndIf
ProcedureReturn Result
EndProcedure
;/////////////////////////////////////////////////////////////////////////////////
;/////////////////////////////////////////////////////////////////////////////////
Procedure DropTarget_DragLeave(*this._IDropTarget)
ProcedureReturn #S_OK
EndProcedure
;/////////////////////////////////////////////////////////////////////////////////
;/////////////////////////////////////////////////////////////////////////////////
;*pdwEffect\l contains the original combination of effects.
Procedure DropTarget_Drop(*this._IDropTarget, Dataobject.IDataobject, grfKeyState, pt.q, *pdwEffect.LONG)
Protected Result = #S_OK, anchWnd, tempAnchWnd, thisFormatEtc.FORMATETC, thisStgMedium.STGMEDIUM, *ptr, *ptrChar.CHARACTER
Protected FID, streamsize.q, *tempstream, buffer
Protected *lock.ilockbytes, *mystream.istream, *storageCopy.istorage, hglob.i
Protected numFiles, i, fname$, fsname$, *fgdbuffer.filegroupdescriptor, DroppedFiles.s, *DroppedFilesBuffer
Protected.i ok
Protected.q bytes
Protected *Anfang, *Ende
If *pdwEffect = 0
Result = #E_INVALIDARG
ElseIf FindMapElement(ODD(), Str(*this\hWnd)) = 0
;
ElseIf *this\blnAllowDrop
;Set effects.
DropTarget_SetEffects(grfKeyState, *pdwEffect)
;Do we proceed?
If *pdwEffect\l <> #DROPEFFECT_NONE
Result = #E_FAIL ;default result if no success below
;Retrieve the data. We have previously checked for valid data.
;Windows automatically converts between #CF_TEXT and #CF_UNICODETEXT as appropriate.
;Try regular Hglobal
With thisFormatEtc
\cfFormat = #CF_HDROP
\dwAspect = #DVASPECT_CONTENT
\lindex = -1
\tymed = #TYMED_HGLOBAL
EndWith
DroppedFiles = ""
If Dataobject\GetData(thisFormatEtc, thisStgMedium) = #S_OK
If thisStgMedium\hGlobal ;Only prudent to be sure here!
buffer = AllocateMemory(1024)
If buffer
numFiles = DragQueryFile_(thisStgMedium\hGlobal, -1, 0, 0)
For i = 0 To numFiles - 1
DragQueryFile_(thisStgMedium\hGlobal, i, buffer, 1024)
fname$ = PeekS(buffer)
fsname$ = StringField(fname$, CountString(fname$, "\") + 1, "\")
If CopyFile(fname$, ODD()\Folder + fsname$)
DroppedFiles + ODD()\Folder + fsname$ + #LF$
EndIf
Next i
FreeMemory(buffer)
EndIf
M_SEND_DROP_FILES
EndIf
ReleaseStgMedium_(thisStgMedium)
Result = 0
EndIf
;**************OUTLOOK ATTACHMENT HANDLING STARTS HERE:*******************
;Try filedescriptor/filecontents
With thisFormatEtc
\cfFormat = cf_descrip
\ptd = #Null
\dwAspect = #DVASPECT_CONTENT
\lindex = -1
\tymed = #TYMED_HGLOBAL
EndWith
If Dataobject\GetData(thisFormatEtc, thisStgMedium) = #S_OK
;Simple/dirty method
*fgdbuffer = GlobalLock_(thisStgMedium\hGlobal)
; Alternate method - uncomment To use
; numbytes = GlobalSize_(thisStgMedium\hGlobal)
; *fgdbuffer = AllocateMemory(numbytes)
; *ptr = GlobalLock_(thisStgMedium\hGlobal)
; CopyMemory(*ptr, *fgdbuffer, numbytes)
; GlobalUnlock_(thisStgMedium\hglobal)
numfiles = *fgdbuffer\cItems
For i = 0 To numfiles - 1
fname$ = PeekS(@*fgdbuffer\fgd[i]\cFileName)
With thisFormatEtc
\cfFormat = cf_content
\ptd = #Null
\dwAspect = #DVASPECT_CONTENT
\lindex = i
\tymed = #TYMED_ISTREAM
EndWith
If Dataobject\GetData(thisFormatEtc, thisStgMedium) = #S_OK
;thisStgMedium\pstm\Stat(myStatsTG, #STATFLAG_NONAME)
thisStgMedium\pstm\Seek(0, #STREAM_SEEK_END, @*Ende)
thisStgMedium\pstm\Seek(0, #STREAM_SEEK_SET, @*Anfang)
streamsize = *Ende-*Anfang
*tempstream = AllocateMemory(streamsize)
ok = thisStgMedium\pstm\Read(*tempstream, streamsize, @bytes)
If FindMapElement(ODD(), Str(*this\hWnd)) And ok = #S_OK And bytes > 0
FID = CreateFile(#PB_Any, ODD()\Folder + fname$)
If FID
WriteData(FID, *tempstream, bytes)
CloseFile(FID)
DroppedFiles + ODD()\Folder + fname$ + " - " + FileSize(ODD()\Folder + fname$) + "bytes" + #LF$
EndIf
EndIf
FreeMemory(*tempstream)
Else
With thisFormatEtc
\cfFormat = cf_content
\ptd = #Null
\dwAspect = #DVASPECT_CONTENT
\lindex = 0
\tymed = #TYMED_ISTORAGE
EndWith
If Dataobject\GetData(thisFormatEtc, thisStgMedium) = #S_OK
CreateILockBytesOnHGlobal_(0, #False, @*lock)
StgCreateDocfileOnILockBytes_(*lock, 16 | 4096 | 2, 0, @*storageCopy)
thisstgmedium\pstg\CopyTo(0, #Null, #Null, *storageCopy)
*storageCopy\Commit(#STGC_DEFAULT)
GetHGlobalFromILockBytes_(*lock, @hglob)
CreateStreamOnHGlobal_(hglob, 0, @*mystream)
*mystream\Seek(0, #STREAM_SEEK_END, @*Ende)
*mystream\Seek(0, #STREAM_SEEK_SET, @*Anfang)
streamsize = *Ende-*Anfang
*tempstream = AllocateMemory(streamsize)
ok = *mystream\Read(*tempstream, streamsize, @bytes)
If FindMapElement(ODD(), Str(*this\hWnd)) And ok = #S_OK And bytes > 0
FID = CreateFile(#PB_Any, ODD()\Folder + fname$)
If FID
WriteData(FID, *tempstream, bytes)
CloseFile(FID)
DroppedFiles + ODD()\Folder + fname$ + " - " + FileSize(ODD()\Folder + fname$) + "bytes" + #LF$
EndIf
EndIf
FreeMemory(*tempstream)
*mystream\Release()
*storageCopy\Release()
EndIf
EndIf
Next i
M_SEND_DROP_FILES
GlobalUnlock_(thisStgMedium\hGlobal)
ReleaseStgMedium_(thisStgMedium)
EndIf
EndIf
EndIf
ProcedureReturn Result
EndProcedure
;/////////////////////////////////////////////////////////////////////////////////
Procedure SetGadgetOutlookDrop(Gadget, StorageFolder.s, MessageWindow, MessageWindowEvent)
Protected Result, *this._IDropTarget
Result = IsGadget(Gadget)
If Result
*this = AllocateMemory(SizeOf(_IDropTarget))
If *this = 0
ProcedureReturn 0
EndIf
*this\vTable = ?VTable_IDropTarget
*this\hWnd = GadgetID(Gadget)
If *this\hWnd And RegisterDragDrop_(GadgetID(Gadget), *this) = #S_OK
AddMapElement(ODD(), Str(GadgetID(Gadget)))
ODD()\Gadget = Gadget
ODD()\MessageWindow = MessageWindow
ODD()\MessageWindowEvent = MessageWindowEvent
ODD()\Folder = StorageFolder
Else
Result = 0
FreeMemory(*this)
EndIf
EndIf
ProcedureReturn Result
EndProcedure
DataSection
VTable_IDropTarget:
Data.i @DropTarget_QueryInterface()
Data.i @DropTarget_AddRef()
Data.i @DropTarget_Release()
Data.i @DropTarget_DragEnter()
Data.i @DropTarget_DragOver()
Data.i @DropTarget_DragLeave()
Data.i @DropTarget_Drop()
CompilerIf Defined(IID_IUnknow, #PB_Label) = 0
IID_IUnknown: ;"{00000000-0000-0000-C000-000000000046}"
Data.l $00000000
Data.w $0000, $0000
Data.b $C0, $00, $00, $00, $00, $00, $00, $46
CompilerEndIf
CompilerIf Defined(IID_IDropTarget, #PB_Label) = 0
IID_IDropTarget: ;{00000122-0000-0000-C000-000000000046}
Data.l $00000122
Data.w $0000, $0000
Data.b $C0, $00, $00, $00, $00, $00, $00, $46
CompilerEndIf
EndDataSection
EndModule
;/-----------------------
;|
;| Example
;|
;/-----------------------
CompilerIf #PB_Compiler_IsMainFile
#Main_Window = 0
#ListView_0 = 0
#PB_Event_OutlookDrop = #PB_Event_FirstCustomValue
Procedure main()
Protected *Buffer
If OpenWindow(#Main_Window, 0, 0, 800, 600, "Drag & Drop", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
ListViewGadget(#ListView_0, 5, 5, 790, 570)
OutlookDragDrop::SetGadgetOutlookDrop(#ListView_0, GetTemporaryDirectory(), #Main_Window, #PB_Event_OutlookDrop)
Repeat
Select WaitWindowEvent()
Case #PB_Event_CloseWindow
Break
Case #PB_Event_OutlookDrop
Select EventGadget()
Case #ListView_0
*Buffer = EventData()
If *Buffer
;files seperated via #LF$
Debug PeekS(*Buffer)
FreeMemory(*Buffer)
EndIf
EndSelect
EndSelect
ForEver
EndIf
EndProcedure
main()
CompilerEndIf
