VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cDropTarget"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'cDropTarget.cls - Modern drop functionality for VB6
'Version 0.1 (Beta)
'(c) 2015 by fafalone. All I ask is credit if you use this in an app.
'Otherwise feel free to modify and distribute with attribution

'This class has several advtanges over the normal drop functionality:
'-Automatically shows the fancy drag image Explorer and newer apps show
'-Supports custom drop tips
'-Supports all formats, with built-in handling for the most common
'
'To use:
'-Create an instance of this class for the control that will be a drop target
'  One class instance per control.
'-Set the appropriate options; DropHWND is required; AllowedEffects must be set
' if you want to accept any format; add formats to accept with AddAllowedFormat
'-Register the window as a drop target with the RegisterDragDrop API. Do NOT also
' use DragAcceptFiles.
'-Be sure that before exiting (or to disable dragdrop generally) that you call the
' the RevokeDragDropAPI. Be careful to not call this when the window isn't registered
' or it may cause an app crash
'----
'USAGE NOTES:
'->If the drop has multiple formats (that are accepted), multiple events will be
'   raised. The DropBegin and DropEnd events let you track if it's a new drop or not
'->You can limit the drop events in two ways: a single format of any kind, or some
'   category limitations; mainly for images. For any limit, in the case of multiple
'   formats being accepted, preference will be given according to the order added
'   with AddAcceptedFormat; the first-added will be the one raised
'->The class handles registering the CFSTR_ formats, so when you add them as an
'   accepted format, just pass the CFSTR_ string variable.
'->When image drawing is enabled, only one will be processed by default; to override
'   change SingleImageEvent. The preference order is as follows: CFSTR_PNG, CF_DIBV5,
'   CF_DIB, CF_BITMAP, CF_ENHMETAFILE, CF_METAFILEPICT
'->When accepting text, both ANSI and Unicode text formats will be accepted, and
'   Unicode text will be returned preferentially.
'->The HandleFiles option should be used in conjuction with a control that displays
'   files. It assumes you're supporting the DragOverFolder function, or at least
'   set the background folder (.CurrentFolder). When enabled, the Explorer drop menu
'   is displayed (rdrag), and Explorer handles the selected command. The DropFiles event
'   is still raised, but you will not need to move/copy/link/archive files yourself.
'   Left button drops are also handled by Explorer; the key advantage here is being
'   able to drop on zip files and other objects, that would otherwise require extensive
'   coding to handle manually.
'   Also note that the QueryDropMenu event will not be raised as the system handles it
'->To display a custom right click menu, the QueryDropMenu event is raised before
'   any drop begins.
'->Drops of CFSTR_FILECONTENTS (with CFSTR_FILEGROUPDESCRIPTOR) can be automatically
'   saved by this class; the SaveFileContents sub is used to turn this on or off; note
'   that the path must exist and saves will fail if it does not.
'->CFSTR_FILECONTENTS depends on CFSTR_FILEGROUPDESCRIPTOR-- you only need to add
'   the filecontents to accept the format, you don't need to add accept entries
'   for the group descriptors, as that's implied.
'->For image drops that pass an hGlobal in their event: this is for copying only; it
'   must not be freed or locked when the event sub exits
'->Custom drop descriptions can, if drag highlighting is enabled, use $CD for sInsert,
'   and it will be replaced with the currently highlighting drop target
'->If automatic file handling is enabled but CurrentPath is not set, files may wind up
'   on the desktop.
'->To accept all formats add CF_MAX

'SUPPORTED FORMATS
'While an event is provided that gives you the raw IDataObject to work with so you
'can handle any format you want, the following formats have internal handlers that
'do the commmon processing:
'-CF_HDROP
'-CF_TEXT/CF_UNICODETEXT/CFSTR_HTML/CFSTR_INETURL[A,W]/CFSTR_RTF
'-CF_DIB/CF_DIBV5/CFSTR_PNG
'-CFSTR_FILECONTENTS/CFSTR_FILEGROUPDESCRIPTOR[A,W]

Private Declare Function OleGetClipboard Lib "ole32" (ppDataObj As oleexp3.IDataObject) As Long
Private Declare Function RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As Long) As Long
Private Declare Function SHCreateItemFromParsingName Lib "shell32" (ByVal pszPath As Long, pbc As Any, riid As UUID, ppv As Any) As Long
Private Declare Function SHCreateShellItemArrayFromDataObject Lib "shell32" (ByVal pdo As oleexp3.IDataObject, riid As UUID, ppv As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long) ' Frees memory allocated by the shell
Private Declare Function PathFileExistsW Lib "shlwapi" (ByVal lpszPath As Long) As Long
Private Declare Function SHCreateStreamOnFileEx Lib "shlwapi" (ByVal pszFile As Long, ByVal grfMode As STGM, ByVal dwAttributes As FILE_ATTRIBUTES, ByVal fCreate As Long, ByVal pstmTemplate As Long, ppstm As oleexp3.IStream) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hDC As Long, _
                                                ByVal XDest As Long, _
                                                ByVal YDest As Long, _
                                                ByVal dwWidth As Long, _
                                                ByVal dwHeight As Long, _
                                                ByVal XSrc As Long, ByVal YSrc As Long, _
                                                ByVal uStartScan As Long, _
                                                ByVal cScanLines As Long, _
                                                lpvBits As Any, _
                                                lpbmi As Any, _
                                                ByVal fuColorUse As Long) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hWnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function UpdateWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function lstrcpyA Lib "kernel32" (lpString1 As Any, lpString2 As Any) As Long
Private Declare Function lstrlenA Lib "kernel32" (lpString As Any) As Long

Private Declare Function GdipLoadImageFromStream Lib "GDIplus" (ByVal stream As IUnknown, Image As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "GdiPlus.dll" (ByVal hDC As Long, GpGraphics As Long) As Long
Private Declare Function GdipGetImageWidth Lib "GdiPlus.dll" (ByVal Image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "GdiPlus.dll" (ByVal Image As Long, Height As Long) As Long
Private Declare Function GdipDrawImageRectRectI Lib "GdiPlus.dll" (ByVal graphics As Long, ByVal GpImage As Long, ByVal dstx As Long, ByVal dsty As Long, ByVal dstwidth As Long, ByVal dstheight As Long, ByVal srcx As Long, ByVal srcy As Long, ByVal srcwidth As Long, ByVal srcheight As Long, ByVal srcUnit As Long, ByVal imageAttributes As Long, ByVal callback As Long, ByVal callbackData As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal graphics As Long) As Long
Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal Image As Long) As Long
Private Declare Function GdiplusStartup Lib "GDIplus" (ByRef Token As Long, ByRef lpInput As GdiplusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "GDIplus" (ByVal Token As Long) As Long

Private Declare Function ILCombine Lib "shell32" (ByVal pidl1 As Long, ByVal pidl2 As Long) As Long
Private Declare Function ILCreateFromPath Lib "shell32" Alias "#157" (ByVal lpszPath As String) As Long
Private Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Private Declare Sub ILFree Lib "shell32" (ByVal pidl As Long)
Private Declare Function vbaObjSetAddRef Lib "msvbvm60.dll" Alias "__vbaObjSetAddref" (ByRef objDest As Object, ByVal pObject As Long) As Long
Private Type GdiplusStartupInput
    GdiplusVersion              As Long
    DebugEventCallback          As Long
    SuppressBackgroundThread    As Long
    SuppressExternalCodecs      As Long
End Type
Private gdipInit As Long
Private Type BITMAPFILEHEADER
    bfType As Long
    bfSize As Long
    bfReserved1 As Long
    bfReserved2 As Long
    bfOffBits As Long
End Type
Private Type BITMAPINFOHEADER
   biSize                   As Long
   biWidth                  As Long
   biHeight                 As Long
   biPlanes                 As Integer
   biBitCount               As Integer
   biCompression            As Long
   biSizeImage              As Long
   biXPelsPerMeter          As Long
   biYPelsPerMeter          As Long
   biClrUsed                As Long
   biClrImportant           As Long
End Type
Private Type BITMAPINFO
   bmiHeader                As BITMAPINFOHEADER
   bmiColors(3)             As Long
End Type
Private Type BITMAPV5HEADER
    bV5Size As Long
    bV5Width As Long
    bV5Height As Long
    bV5Planes As Integer
    bV5BitCount As Integer
    bV5Compression As Long
    bV5SizeImage As Long
    bV5XPelsPerMeter As Long
    bV5YPelsPerMeter As Long
    bV5ClrUsed As Long
    bV5ClrImportant As Long
    bV5RedMask As Long
    bV5GreenMask As Long
    bV5BlueMask As Long
    bV5AlphaMask As Long
    bV5CSType As Long
    bV5EndpointsRedX As Long
    bV5EndpointsRedY As Long
    bV5EndpointsRedZ As Long
    bV5EndpointsGreenX As Long
    bV5EndpointsGreenY As Long
    bV5EndpointsGreenZ As Long
    bV5EndpointsBlueX As Long
    bV5EndpointsBlueY As Long
    bV5EndpointsBlueZ As Long
    bV5GammaRed As Long
    bV5GammaGreen As Long
    bV5GammaBlue As Long
    bV5Intent As Long
    bV5ProfileData As Long
    bV5ProfileSize As Long
    bV5Reserved As Long
End Type

Private bShowMenu As Boolean
Private m_hWnd As Long
Private pDTH As IDropTargetHelper
Private lItemIndex As Long
Private mDataObj As oleexp3.IDataObject
Private mDragOver As String
Private mDropTipMsg As String
Private mDropTipIns As String
Private mDropTipImg As DROPIMAGETYPE
Private mDefEffect As DROPEFFECTS
Private mSingleImage As Boolean

Private sFolder As String
Private bAbort As Boolean
Private bAcceptStd(CF_MAX + 5) As Boolean
Private sAcceptEx() As String
Private CF_HTML As Long
Private CF_PNG As Long
Private CF_RTF As Long
Private CF_FILECONTENTS As Long
Private CF_FILEGROUPDESCRIPTOR As Long
Private CF_FILEGROUPDESCRIPTORW As Long
Private CF_INETURL As Long
Private CF_INETURLW As Long
Private CF_SHELLIDLIST As Long
Private CF_DROPDESCRIPTION As Long
Private CF_PREFERREDDROPEFFECT As Long

Private bRender As Boolean
Private mImgHWND As Long, mImgDC As Long
Private mImgX As Long, mImgY As Long
Private mHandleFiles As Boolean
Private mCurPath As String, mCurPathDisp As String
Private psiCurPath As IShellItem
Private bAllFmt As Boolean
Private mDragHighlight As Boolean
Private mSaveFileContents  As Boolean
Private mFileContentsPath As String
Private mFCinCP As Boolean
Private mAllowMultiImage As Boolean

Public Event DragEnter(pDataObject As oleexp3.IDataObject)
Public Event DragOver(lKeyState As Long, X As Long, Y As Long)
Public Event DragLeave()
Public Event DropBegin(X As Long, Y As Long)
Public Event DropFilesXP(sFiles() As String, X As Long, Y As Long, inout_Effect As DROPEFFECTS)
Public Event DropText(sText As String, X As Long, Y As Long)
Public Event DropFiles(isiaFiles As IShellItemArray, sFiles() As String, X As Long, Y As Long, inout_Effect As DROPEFFECTS)
Public Event DropHTML(sHTML As String, X As Long, Y As Long)
Public Event DropDIB(hGlbl As Long, X As Long, Y As Long)
Public Event DropDIBV5(hGlbl As Long, X As Long, Y As Long)
Public Event DropBitmap(hGlbl As Long, X As Long, Y As Long)
Public Event DropPNG(hGlbl As Long, X As Long, Y As Long)
Public Event DropRTF(sRTF As String, X As Long, Y As Long)
Public Event DropURL(sURL As String, X As Long, Y As Long)
Public Event DropAll(pDataObject As oleexp3.IDataObject, X As Long, Y As Long, inout_Effect As DROPEFFECTS)
Public Event DropEnd()
'Custom Menu: To display a custom right click menu (if not using Explorer's), you can display it
' in response to this event and fill in/save lReturn for something later
Public Event QueryDropMenu(lReturn As Long)
'DragHighlight Events: To have your control behave as part of the file system, if drop highlighting
' is enabled, respond to the following events. Vars marked in_ are data that are already filled in
' to be used to lookup and set the vars labelled out_
Public Event QueryDragOverItem(in_ptX As Long, in_ptY As Long, in_PrevIndex As Long, out_NewIndex As Long, out_fGroup As Boolean)
Public Event QueryDragOverData(in_ItemIndex As Long, in_fIsGroup As Boolean, out_FullPath As String)

Implements IDropTarget

Private Sub Class_Initialize()
ReDim sAcceptEx(0)
mSingleImage = True
CF_HTML = RegisterClipboardFormatW(StrPtr(CFSTR_HTML))
CF_PNG = RegisterClipboardFormatW(StrPtr(CFSTR_PNG))
CF_RTF = RegisterClipboardFormatW(StrPtr(CFSTR_RTF))
CF_FILECONTENTS = RegisterClipboardFormatW(StrPtr(CFSTR_FILECONTENTS))
CF_FILEGROUPDESCRIPTOR = RegisterClipboardFormatW(StrPtr(CFSTR_FILEDESCRIPTORA))
CF_FILEGROUPDESCRIPTORW = RegisterClipboardFormatW(StrPtr(CFSTR_FILEDESCRIPTORW))
CF_INETURL = RegisterClipboardFormatW(StrPtr(CFSTR_INETURLA))
CF_INETURLW = RegisterClipboardFormatW(StrPtr(CFSTR_INETURLW))
CF_SHELLIDLIST = RegisterClipboardFormatW(StrPtr(CFSTR_SHELLIDLIST))
CF_DROPDESCRIPTION = RegisterClipboardFormatW(StrPtr(CFSTR_DROPDESCRIPTION))
CF_PREFERREDDROPEFFECT = RegisterClipboardFormatW(StrPtr(CFSTR_PREFERREDDROPEFFECT))
Set pDTH = New DragDropHelper
mDefEffect = DROPEFFECT_NONE
End Sub

Private Sub Class_Terminate()
Set pDTH = Nothing
If gdipInit Then FreeGDIPlus gdipInit
End Sub
Private Function InitGDIPlus() As Long
    Dim Token    As Long
    Dim tgdipInit As GdiplusStartupInput
    
    tgdipInit.GdiplusVersion = 1
    GdiplusStartup Token, tgdipInit, ByVal 0&
    InitGDIPlus = Token
End Function

' Frees GDI Plus
Private Sub FreeGDIPlus(Token As Long)
    GdiplusShutdown Token
End Sub

Public Property Let DropHWND(hWnd As Long)
m_hWnd = hWnd
End Property
Public Property Get DropHWND() As Long
DropHWND = m_hWnd
End Property
Public Sub SetDropTip(sMsg As String, sIns As String, nDI As DROPIMAGETYPE)
mDropTipMsg = sMsg
mDropTipIns = sIns
End Sub
Public Property Let DefaultEffect(dwEffect As DROPEFFECTS): mDefEffect = dwEffect: End Property
Public Property Get DefaultEffect() As DROPEFFECTS: DefaultEffect = mDefEffect: End Property

Public Property Let DragHighlight(Val As Boolean): mDragHighlight = True: End Property
Public Property Get DragHighlight() As Boolean: DragHighlight = mDragHighlight: End Property

Public Property Let DrawImagesToControl(Val As Boolean): bRender = Val: End Property
Public Property Get DrawImagesToControl() As Boolean: DrawImagesToControl = bRender: End Property
Public Sub SetDrawImageControl(hWnd As Long, hDC As Long, X As Long, Y As Long)
mImgHWND = hWnd
mImgDC = hDC
mImgX = X
mImgY = Y
'COMMENT OUT IF STARTED IN YOUR SUB MAIN OR FORM_LOAD:
'If gdipInit = 0 Then
'    gdipInit = InitGDIPlus
'End If
End Sub

Public Property Let SingleImageEvent(Val As Boolean): mSingleImage = Val: End Property
Public Property Get SingleImageEvent() As Boolean: SingleImageEvent = mSingleImage: End Property

Public Property Let HandleFileDrop(Val As Boolean): mHandleFiles = Val: End Property
Public Property Get HandleFileDrop() As Boolean: HandleFileDrop = mHandleFiles: End Property
Public Property Let CurrentPath(sPath As String)
Dim lp As Long

mCurPath = sPath
Call SHCreateItemFromParsingName(StrPtr(sPath), ByVal 0&, IID_IShellItem, psiCurPath)
If (psiCurPath Is Nothing) = False Then
    psiCurPath.GetDisplayName SIGDN_NORMALDISPLAY, lp
    mCurPathDisp = LPWSTRtoStr(lp)
End If
End Property

Public Sub SaveFileContents(fSave As Boolean, sPath As String, Optional bPathIsCurDir As Boolean = False)
'bPathIsCurDir requires DragHighlight to be enabled or CurPath to be set
' used in conjunction with a drop target that represents a folder or contains
' folders
mSaveFileContents = fSave
mFileContentsPath = sPath
mFCinCP = bPathIsCurDir
End Sub

Public Sub AddAllowedFormat(cfFmt As Variant)
If VarType(cfFmt) = vbLong Then
    Dim lFmt As Long
    lFmt = CLng(cfFmt)
    If lFmt = CF_MAX Then bAllFmt = True: Exit Sub
    If (lFmt > &H80&) And (lFmt < &H84&) Then
        lFmt = (lFmt - &H80) + 18
    ElseIf (lFmt = &H8E&) Then
        lFmt = 22&
    End If
    bAcceptStd(CLng(cfFmt)) = True
Else
    Dim sFmt As String
    sFmt = CStr(cfFmt)
    Dim k As Long
    k = UBound(sAcceptEx)
    If (k = 0) And (sAcceptEx(0) = "") Then
        sAcceptEx(k) = sFmt
    Else
        k = k + 1
        ReDim Preserve sAcceptEx(k)
        k = k + 1
    End If
End If
End Sub
Private Function AcceptFmt(cfFmt As Variant) As Boolean
'If bAllFmt = True Then
    AcceptFmt = True
    Exit Function
'End If
If VarType(cfFmt) = vbLong Then
    AcceptFmt = bAcceptStd(CLng(cfFmt))
Else
    Dim sFmt As String
    Dim i As Long
    sFmt = CStr(cfFmt)
    For i = 0 To UBound(sAcceptEx)
        If sAcceptEx(i) = sFmt Then
            AcceptFmt = True
            Exit Function
        End If
    Next
End If
    

End Function

Private Function IDOSupportsFormat(pIDO As oleexp3.IDataObject, lFmt As Long, Optional ty As TYMED = TYMED_HGLOBAL, Optional lIndex As Long = -1, Optional dva As DVASPECT = DVASPECT_CONTENT, Optional ldev As Long = 0) As Boolean
Dim tFMT As FORMATETC
With tFMT
    .cfFormat = lFmt
    .TYMED = ty
    .dwAspect = dva
    .lIndex = lIndex
    .pDVTARGETDEVICE = ldev
End With
If pIDO.QueryGetData(tFMT) = S_OK Then
    IDOSupportsFormat = True
End If
End Function

Private Sub IDropTarget_DragEnter(ByVal pDataObj As oleexp3.IDataObject, ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As oleexp3.DROPEFFECTS)
   Debug.Print "DragEnter, keystate=" & grfKeyState
   On Error Resume Next
   Dim pt As oleexp3.POINT
   pt.X = ptX
   pt.Y = ptY
   lItemIndex = -1
   SetFocusAPI m_hWnd
   DoEvents
   Dim pEnumFMT As IEnumFORMATETC
   Set pEnumFMT = pDataObj.EnumFormatEtc(DATADIR_GET)
   Dim tFMTETC As FORMATETC
   Dim bAllowed As Boolean
   Do While (pEnumFMT.Next(1, tFMTETC) = NOERROR)
        Debug.Print "dragenter fmt->" & tFMTETC.cfFormat
        If AcceptFmt(tFMTETC.cfFormat) Then
            bAllowed = True
            Exit Do
        End If
    Loop
    If bAllowed = False Then
        AddDropDescription pDataObj, DROPIMAGE_NONE, "Can't drop here.", ""
        pdwEffect = DROPEFFECT_NONE
    End If
    
    
   If (grfKeyState And MK_RBUTTON) = MK_RBUTTON Then
        bShowMenu = True
    Else
        bShowMenu = False
    End If
    pdwEffect = mDefEffect
    Debug.Print "effect=" & mDefEffect
   pDTH.DragEnter m_hWnd, pDataObj, pt, pdwEffect
   If bAllowed = False Then Exit Sub
IDO_AddPrefEffect pDataObj, mDefEffect
If mDropTipMsg <> "" Then
    If (mDropTipIns = "$CD") Then mDropTipIns = Replace$(mDropTipIns, "$CD", IIf(sFolder = "", mCurPath, sFolder))
    AddDropDescription pDataObj, mDropTipImg, mDropTipMsg, mDropTipIns
Else
   Select Case pdwEffect
    Case DROPEFFECT_NONE
        AddDropDescription pDataObj, DROPIMAGE_NONE, "Can't drop here.", ""
    Case DROPEFFECT_COPY
        AddDropDescription pDataObj, DROPIMAGE_COPY, "Copy here", ""
    Case DROPEFFECT_MOVE
        AddDropDescription pDataObj, DROPIMAGE_MOVE, "Move here", ""
   End Select
End If

Set mDataObj = pDataObj

End Sub

Private Sub IDropTarget_DragLeave()
Debug.Print "DragLeave"
pDTH.DragLeave
If bAbort Then Exit Sub
AddDropDescription mDataObj, DROPIMAGE_INVALID, "", ""
Set mDataObj = Nothing
   
End Sub

Private Sub IDropTarget_DragOver(ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As oleexp3.DROPEFFECTS)
Dim pt As oleexp3.POINT
pt.X = ptX
pt.Y = ptY

'Debug.Print "DragOver" & ", ptx=" & ptX & ", pty=" & ptY
Dim lPrevItemIndex As Long
pdwEffect = mDefEffect
pDTH.DragOver pt, pdwEffect
If bAbort Then Exit Sub

If mDragHighlight Then
    lPrevItemIndex = lItemIndex
    Dim fGrp As Boolean
    Dim sOld As String
    Dim nPrev As Long
    nPrev = lItemIndex
    RaiseEvent QueryDragOverItem(ptX, ptY, nPrev, lItemIndex, fGrp)
    If (lItemIndex >= 0) Then
        Debug.Print "dragover set dir"
        If fGrp Then
            sOld = sFolder
            RaiseEvent QueryDragOverData(lItemIndex, True, sFolder)
            If sOld <> sFolder Then
                mDragOver = PathGetDisp(sFolder)
            End If
        Else
            sOld = sFolder
            RaiseEvent QueryDragOverData(lItemIndex, False, sFolder)
            If sOld <> sFolder Then
                mDragOver = PathGetDisp(sFolder)
            End If
            
        End If
    Else
        If mCurPath <> "" Then
            sFolder = mCurPath
            mDragOver = mCurPathDisp
        Else
            mDragOver = ""
            sFolder = ""
        End If
    End If
If (lItemIndex <> lPrevItemIndex) Then
    If mDropTipMsg <> "" Then
        If (mDropTipIns = "$CD") Then mDropTipIns = Replace$(mDropTipIns, "$CD", IIf(sFolder = "", mCurPath, sFolder))
        AddDropDescription mDataObj, mDropTipImg, mDropTipMsg, mDropTipIns
    Else
        Select Case pdwEffect
            Case DROPEFFECT_NONE
                AddDropDescription mDataObj, DROPIMAGE_NONE, "Can't drop here.", ""
            Case DROPEFFECT_COPY
                AddDropDescription mDataObj, DROPIMAGE_COPY, IIf(mDragOver = "", "Copy here", "Copy to %1"), mDragOver
            Case DROPEFFECT_MOVE
                AddDropDescription mDataObj, DROPIMAGE_MOVE, IIf(mDragOver = "", "Move here", "Move to %1"), mDragOver
        End Select
    End If
End If
End If
End Sub
Public Sub DropClipboard()
'drops the clipboard like it was dragged and dropped. added mainly
'for debug purposes, but might be useful elsewhere
Dim iData As oleexp3.IDataObject
OleGetClipboard iData
IDropTarget_Drop iData, 0, 0, 0, mDefEffect
Set iData = Nothing


End Sub
Private Sub IDropTarget_Drop(ByVal pDataObj As oleexp3.IDataObject, ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As oleexp3.DROPEFFECTS)
Debug.Print "Drop"
Dim lpGlobal As Long
Dim idx As Long
Dim lRead As Long
Dim hGlobal As Long
Dim tSTG As STGMEDIUM
Dim tFMT As FORMATETC
Dim bSkip As Boolean
Dim lRes As Long
        Dim pDT As IDropTarget
        Dim pidl() As Long
        Dim pidlPar As Long
        Dim pidlChild As Long
On Error GoTo e1
Dim pt As oleexp3.POINT
   pt.X = ptX
   pt.Y = ptY
   Debug.Print "keystate=" & grfKeyState
 pDTH.Drop pDataObj, pt, pdwEffect
RaiseEvent DropBegin(ptX, ptY)
 If (bShowMenu = True) And (sFolder <> "") Then
    If mHandleFiles Then
        
        ReDim pidl(0)
        pidl(0) = ILCreateFromPathW(StrPtr(sFolder))
       isfDesktop.GetUIObjectOf 0&, 1, pidl(0), IID_IDropTarget, 0&, pDT
        If (pDT Is Nothing) = False Then
            pDT.DragEnter pDataObj, MK_RBUTTON, ptX, ptY, pdwEffect 'pdwEffect has no effect here; Explorer chooses the default
            pDT.Drop pDataObj, MK_RBUTTON, ptX, ptY, DROPEFFECT_MOVE Or DROPEFFECT_COPY Or DROPEFFECT_LINK 'allowed effects.. if it's not here it won't appear on the menu
            Debug.Print "dropped"
            Call CoTaskMemFree(pidlChild)
            Call CoTaskMemFree(pidlPar)
            Call CoTaskMemFree(pidl(0))
            Exit Sub
        Else
            Debug.Print "no pDT"
        End If
    Else
        RaiseEvent QueryDropMenu(pdwEffect)
    
    End If
End If
If AcceptFmt(CFSTR_FILECONTENTS) Then
    lRes = DoDrop_FileContents(pDataObj)
    If lRes = -1 Then Exit Sub
End If
skp1:
If AcceptFmt(CFSTR_PNG) Then
    If IDOSupportsFormat(pDataObj, CF_PNG) Then
        lRes = DoDrop_PNG(pDataObj, pt)
        If lRes = -1 Then Exit Sub
        If mSingleImage Then GoTo imgend
    End If
End If

If AcceptFmt(CF_DIBV5) Then
    If IDOSupportsFormat(pDataObj, CF_DIBV5) Then
        lRes = DoDrop_DIBV5(pDataObj, pt)
        If lRes = -1 Then Exit Sub
        If mSingleImage Then GoTo imgend
    End If
End If
If AcceptFmt(CF_DIB) Then
    On Error GoTo e1
    If IDOSupportsFormat(pDataObj, CF_DIB) Then
        lRes = DoDrop_DIB(pDataObj, pt)
        If lRes = -1 Then Exit Sub
    End If
End If
imgend:
If (AcceptFmt(CF_TEXT)) Or (AcceptFmt(CF_UNICODETEXT)) Then
    If IDOSupportsFormat(pDataObj, CF_UNICODETEXT) Then
        lRes = DoDrop_TextW(pDataObj, pt)
        If lRes = -1 Then Exit Sub
    Else
        If lRes <> 1& Then
            If IDOSupportsFormat(pDataObj, CF_TEXT) Then
                lRes = DoDrop_TextA(pDataObj, pt)
                If lRes = -1 Then Exit Sub
            End If
        End If
    End If
End If
If AcceptFmt(CFSTR_INETURLA) Or AcceptFmt(CFSTR_INETURLW) Then
    If IDOSupportsFormat(pDataObj, CF_INETURLW) Then
        lRes = DoDrop_URLW(pDataObj, pt)
        If lRes = -1 Then Exit Sub
    Else
        If lRes <> 1& Then
            If IDOSupportsFormat(pDataObj, CF_INETURL) Then
                lRes = DoDrop_URLA(pDataObj, pt)
                If lRes = -1 Then Exit Sub
            End If
        End If
    End If
End If
If AcceptFmt(CFSTR_HTML) Then
    If IDOSupportsFormat(pDataObj, CF_HTML) Then
        lRes = DoDrop_HTML(pDataObj, pt)
        If lRes = -1 Then Exit Sub
    End If
End If
If AcceptFmt(CFSTR_RTF) Then
    If IDOSupportsFormat(pDataObj, CF_RTF) Then
        lRes = DoDrop_RTF(pDataObj, pt)
        If lRes = -1 Then Exit Sub
    End If
End If

If AcceptFmt(CF_HDROP) Then
If bAbort Then Exit Sub
    If IDOSupportsFormat(pDataObj, CF_HDROP) Then
        lRes = DoDrop_HDROP(pDataObj, pdwEffect, pt)
        If lRes = -1 Then Exit Sub
        GoTo sidbypass 'don't process CFSTR_SHELLIDLIST
    End If
End If

'****************************************
'XP USERS:
'The following support for CFSTR_SHELLIDLIST uses the Vista+
'method in the HDROP handler. If you disable that, you must
'also disable CFSTR_SHELLIDLIST handling, or you'll need to
'dive into the CIDA structure to manually get pidls yourself
If AcceptFmt(CFSTR_SHELLIDLIST) Then
    If IDOSupportsFormat(pDataObj, CF_SHELLIDLIST) Then
        lRes = DoDrop_HDROP(pDataObj, pdwEffect, pt)
        If lRes = -1 Then Exit Sub
    End If
End If
sidbypass:

RaiseEvent DropEnd
Exit Sub

e1:
    Debug.Print "IDropTarget_Drop.Error->" & Err.Description
    Resume Next
End Sub

Private Function DoDrop_FileContents(pDataObj As oleexp3.IDataObject) As Long
    '<EhHeader>
    On Error GoTo DoDrop_FileContents_Err
    '</EhHeader>
Dim tSTG As STGMEDIUM
Dim tFMT As FORMATETC
Dim lpGlobal As Long
Dim idx As Long
Dim sName As String, pszPath As String, sTargetDir As String
Dim cbSize As Currency
Dim nFiles As Long, sFCN() As String, sTmp As String
Dim fgd As FILEGROUPDESCRIPTORW
Dim tFD As FILEDESCRIPTORW

    'try unicode first
    tFMT.cfFormat = CF_FILEGROUPDESCRIPTORW
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL
    If pDataObj.QueryGetData(tFMT) = S_OK Then
        Debug.Print "got group description"
        pDataObj.GetData tFMT, tSTG
        lpGlobal = GlobalLock(tSTG.Data)
        CopyMemory fgd, ByVal lpGlobal, LenB(fgd)
        Debug.Print "citems=" & fgd.cItems
        nFiles = fgd.cItems - 1
        ReDim sFCN(nFiles)
        For idx = 0 To (fgd.cItems - 1)
            CopyMemory tFD, ByVal lpGlobal + 4& + Len(tFD) * idx, Len(tFD)
            Debug.Print "idx=" & idx & "size h/l=" & tFD.nFileSizeHigh & "/" & tFD.nFileSizeLow
            Debug.Print "name=" & CStr(tFD.cFileName)
            sFCN(idx) = tFD.cFileName
        Next
        Call GlobalUnlock(tSTG.Data)
        ReleaseStgMedium tSTG
    Else
        'try ANSI
            Dim fgdA As FILEGROUPDESCRIPTORA
            Dim tFDA As FILEDESCRIPTORA
        tFMT.cfFormat = CF_FILEGROUPDESCRIPTOR
        tFMT.dwAspect = DVASPECT_CONTENT
        tFMT.lIndex = -1
        tFMT.TYMED = TYMED_HGLOBAL
        If pDataObj.QueryGetData(tFMT) = S_OK Then
            Debug.Print "got group description"
            pDataObj.GetData tFMT, tSTG
            lpGlobal = GlobalLock(tSTG.Data)
            CopyMemory fgdA, ByVal lpGlobal, LenB(fgdA)
            Debug.Print "citems=" & fgdA.cItems
            nFiles = fgdA.cItems - 1
            ReDim sFCN(nFiles)
            For idx = 0 To (fgdA.cItems - 1)
                CopyMemory tFDA, ByVal lpGlobal + 4& + Len(tFDA) * idx, Len(tFDA)
                Debug.Print "idx=" & idx & "size h/l=" & tFDA.nFileSizeHigh & "/" & tFDA.nFileSizeLow
                Debug.Print "name=" & StrConv(tFDA.cFileName, vbUnicode)
                sFCN(idx) = StrConv(tFDA.cFileName, vbUnicode)
            Next
            Call GlobalUnlock(tSTG.Data)
            ReleaseStgMedium tSTG
        Else
            'no descriptor; skip contents
            GoTo skp1
        End If
    End If
        
        
    Dim bUnlock As Boolean
        
    For idx = 0 To nFiles
    tFMT.cfFormat = CF_FILECONTENTS
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.TYMED = TYMED_ISTREAM
    tFMT.lIndex = idx
    If pDataObj.QueryGetData(tFMT) = S_OK Then
        Debug.Print "got file contents drop"
        Dim hr As Long, pstrm As IStream, tStat As STATSTG, pStrmFile As IStream
        hr = pDataObj.GetData(tFMT, tSTG)
        Debug.Print "hr=" & hr & ",got data=" & tSTG.Data
        If hr = S_OK Then
            vbaObjSetAddRef pstrm, tSTG.Data
        Else
            'for some reason, TYMED_ISTREAM will return S_OK on QueryGetData even if it's not supported
            'so we'll see if we get a valid hglobal
            tFMT.cfFormat = CF_FILECONTENTS
            tFMT.dwAspect = DVASPECT_CONTENT
            tFMT.TYMED = TYMED_HGLOBAL
            tFMT.lIndex = idx
            hr = pDataObj.GetData(tFMT, tSTG)
            Debug.Print "hglobal hr=" & hr & ",got data=" & tSTG.Data
            vbaObjSetAddRef pstrm, tSTG.Data
            lpGlobal = GlobalLock(tSTG.Data)
            Debug.Print "size=" & GlobalSize(tSTG.Data)
            bUnlock = True
'            Call CreateStreamOnHGlobal(tSTG.Data, 1, pstrm)
            If (pstrm Is Nothing) Then
                Debug.Print "failed to set pstrm with hglobal"
            Else
                Debug.Print "set stream via hglobal"
            End If
        End If
            If (pstrm Is Nothing) Then
                Debug.Print "pstrm not set, will try IStorage"
                tFMT.cfFormat = CF_FILECONTENTS
                tFMT.dwAspect = DVASPECT_CONTENT
                tFMT.TYMED = TYMED_ISTORAGE
                tFMT.lIndex = idx
                hr = pDataObj.GetData(tFMT, tSTG)
                Debug.Print "istorage hr=" & hr & ",data=" & tSTG.Data
                Dim pStgF As oleexp3.IStorage
                Dim pStgMem As oleexp3.IStorage
                sTargetDir = mFileContentsPath
                If sFCN(idx) = "" Then
                    Debug.Print "don't have name"
                    sFCN(idx) = "filedoe.msg"
                    
                End If
                pszPath = AddBackslash(sTargetDir) & sFCN(idx)
                Set pStgMem = StgCreateDocfile(pszPath, STGM_CREATE Or STGM_READWRITE Or STGM_SHARE_EXCLUSIVE)
                vbaObjSetAddRef pStgF, tSTG.Data

                If (pStgF Is Nothing) Then
                    Debug.Print "Failed to get IStorage from IDO"
                Else
                    Debug.Print "Got IStorage from IDO, saving... " & pszPath
                    Dim tIID As UUID
                    pStgF.CopyTo 0, tIID, "", pStgMem
'                    Debug.Print "checking for streams to save..."
                    
'                    Dim pEnum As IEnumSTATSTG
'                    Set pEnum = pStgF.EnumElements(0, 0, 0)
'                    If (pEnum Is Nothing) Then
'                        DebugAppend "pEnum==nothing"
'                        Exit Function
'                    Else
'                        DebugAppend "got penum"
'                        Dim celtFetched As Long
'                        Do While (pEnum.Next(1, tStat, celtFetched) = NOERROR)
'                        pszPath = SysAllocString(tStat.pwcsName)
'                        Debug.Print "pszPath on alloc=" & pszPath
'                        If Left$(pszPath, 9) = "__attach_" Then
''                            pszPath = AddBackslash(sTargetDir) & pszPath
'                            If tStat.type = STGTY_STREAM Then 'file
'                                Debug.Print "Got stream, saving"
'                                Dim pstrm2 As oleexp3.IStream, tStat2 As STATSTG
'                                Set pstrm2 = pStgF.OpenStream(SysAllocString(tStat.pwcsName), 0, STGM_READ, 0)
'                                pstrm2.stat tStat2
'                                Debug.Print "substream name/" & tStat2.pwcsName & "=" & SysAllocString(tStat2.pwcsName)
'                                Debug.Print "substream size=" & tStat2.cbSize
'                                Dim pStrmFile2 As oleexp3.IStream
''                                Call SHCreateStreamOnFileEx(StrPtr(pszPath), STGM_CREATE Or STGM_WRITE, FILE_ATTRIBUTE_NORMAL, 1, 0, pStrmFile2)
''                                pstrm2.CopyTo pStrmFile2, tStat.cbSize, 0, cbSize
'                                Set pStrmFile2 = Nothing
'                                Set pstrm2 = Nothing
'                            End If
'                        Else
'                            Debug.Print "failed to get filename from pEnum"
'                        End If
'                        Loop
'                    End If

                    
                    Set pStgMem = Nothing
                    Set pStgF = Nothing
                    ReleaseStgMedium tSTG
                    DoDrop_FileContents = -1
                    Exit Function
                End If
                    
            End If
                pstrm.stat tStat
                Dim nSize As Long
                nSize = tStat.cbSize * 10000
                Debug.Print "cbsize=" & tStat.cbSize * 10000
                sName = SysAllocString(tStat.pwcsName)
                Debug.Print "name(" & tStat.pwcsName & ")=" & sName
                If mSaveFileContents Then
                    Debug.Print "saving..."
                    If mFCinCP Then
                        sTargetDir = IIf(sFolder = "", mCurPath, sFolder)
                    Else
                        sTargetDir = mFileContentsPath
                    End If
                    If PathFileExistsW(StrPtr(sTargetDir)) Then
                        If (sFCN(idx) = "") Then
                            pszPath = AddBackslash(sTargetDir) & sName
                        Else
                            pszPath = AddBackslash(sTargetDir) & sFCN(idx)
                        End If
                        Call SHCreateStreamOnFileEx(StrPtr(pszPath), STGM_CREATE Or STGM_WRITE, FILE_ATTRIBUTE_NORMAL, 1, 0, pStrmFile)
                        If (pStrmFile Is Nothing) Then
                            Debug.Print "Failed to create new file"
                        Else
                            If bUnlock Then
                             'bizarre method where CopyTo isn't supported
                              Dim pvB() As Byte
                              ReDim pvB(nSize)
                              Debug.Print "reading pstrm into byte array..."
                              pstrm.Read pvB(0), nSize
                              Debug.Print "pstrm read, writing to new stream..."
                              pStrmFile.setSize tStat.cbSize
                              pStrmFile.Write pvB(0), nSize
                              Debug.Print "wrote pstrmfile, committing"
                              pStrmFile.Commit
                            Else
                                Debug.Print "Writing new file... " & pszPath
                                pstrm.CopyTo pStrmFile, tStat.cbSize, 0, cbSize
                                
                                Debug.Print "bytes written=" & cbSize
                            End If
                            Set pStrmFile = Nothing
                    End If
                End If
            End If

        Set pstrm = Nothing
        If bUnlock Then Call GlobalUnlock(tSTG.Data)
        ReleaseStgMedium tSTG
DoDrop_FileContents = -1
            
Else
    Debug.Print "Failed QueryGetData on FileContents"
End If
Next



'    RaiseEvent DropAll(pDataObj)
'
skp1:
Exit Function

DoDrop_FileContents_Err:
    DebugAppend "cDropTarget.DoDrop_FileContents->" & Err.Description & " (" & Err.Number & ")"
End Function
Private Function DoDrop_PNG(pDataObj As oleexp3.IDataObject, pt As oleexp3.POINT) As Long
Dim tFMT As FORMATETC
Dim tSTG As STGMEDIUM
Dim lpGlobal As Long
Dim hGlobal As Long
    tFMT.cfFormat = CF_PNG
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL

        Debug.Print "Got PNG drop"
        pDataObj.GetData tFMT, tSTG
        If tSTG.Data Then
            RaiseEvent DropPNG(tSTG.Data, pt.X, pt.Y)
            If (bRender = True) And (mImgHWND <> 0) And (mImgDC <> 0) Then
                hGlobal = tSTG.Data
                lpGlobal = GlobalLock(hGlobal)
                Dim pIStrm As IStream
                Dim hImage As Long
                Dim hGraphics As Long
                Dim CX As Long, CY As Long
                
                Call CreateStreamOnHGlobal(hGlobal, 1, pIStrm)
                GdipLoadImageFromStream pIStrm, hImage
        
                If GdipCreateFromHDC(mImgDC, hGraphics) = 0 Then
                    GdipGetImageWidth hImage, CX
                    GdipGetImageHeight hImage, CY
                    
                    GdipDrawImageRectRectI hGraphics, hImage, mImgX, mImgY, CX, CY, 0, 0, CX, CY, &H2, 0, 0&, 0&
            
                    GdipDeleteGraphics hGraphics
                    
                End If
    
                GdipDisposeImage hImage
                RedrawWindow mImgHWND, 0, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_ERASE Or RDW_ALLCHILDREN
                UpdateWindow mImgHWND
                
                GlobalUnlock hGlobal
            End If
        End If
        ReleaseStgMedium tSTG


End Function
Private Function DoDrop_DIBV5(pDataObj As oleexp3.IDataObject, pt As oleexp3.POINT) As Long
Dim tFMT As FORMATETC
Dim tSTG As STGMEDIUM
Dim lpGlobal As Long
Dim hGlobal As Long

    Debug.Print "Got cf_dibv5"
    tFMT.cfFormat = CF_DIBV5
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL

    pDataObj.GetData tFMT, tSTG
    RaiseEvent DropDIBV5(tSTG.Data, pt.X, pt.Y)
    If (bRender = True) And (mImgHWND <> 0) And (mImgDC <> 0) And (bSkip = False) Then
        Dim tBIH5 As BITMAPV5HEADER
        Dim tHdr As BITMAPFILEHEADER
        Dim nGlb As Long
        nGlb = GlobalSize(tSTG.Data)
        lpGlobal = GlobalLock(tSTG.Data)
        CopyMemory tBIH5, ByVal lpGlobal, LenB(tBIH5)
        Debug.Print "dib bitcnt=" & tBIH5.bV5BitCount
        Debug.Print "dib width=" & tBIH5.bV5Width
        Debug.Print "dib alpha=" & tBIH5.bV5AlphaMask
        lRead = tBIH5.bV5Size              ' determine where pixel data starts
        If tBIH5.bV5Compression = 3& Then lRead = lRead + 12&  ' BI_BITFIELDS
        If tBIH5.bV5ClrUsed Then
            lRead = lRead + 4& * tBIH5.bV5ClrUsed
        ElseIf tBIH5.bV5BitCount <= 8& Then
            lRead = lRead + 4& * 2 ^ tBIH5.bV5BitCount
        End If
    '    tHdr.bfType = &H4D42
    '    tHdr.bfOffBits = LenB(tHdr) + lRead
    '    tHdr.bfSize = LenB(tHdr) + nGlb
    '    Dim aDat5() As Byte
    ''    ReDim aDat5(nGlb - 1)
    '    CopyMemory aDat5(0), ByVal lpGlobal, nGlb
    ''    Dim hFile As Long
    ''    hFile = FreeFile()
    ''    Open "C:\temp2\dib5test.bmp" For Binary As #hFile
    ''        Put #hFile, , tHdr
    ''        Put #hFile, , aDat5
    ''    Close #hFile
        SetDIBitsToDevice mImgDC, mImgX, mImgY, tBIH5.bV5Width, Abs(tBIH5.bV5Height), _
            0, 0, 0, Abs(tBIH5.bV5Height), ByVal lpGlobal + lRead, ByVal lpGlobal, 0 'DIB_RGB_COLORS
        RedrawWindow mImgHWND, 0, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_ERASE Or RDW_ALLCHILDREN
        UpdateWindow mImgHWND
        
        Call GlobalUnlock(tSTG.Data)
        ReleaseStgMedium tSTG
    End If

End Function
Private Function DoDrop_DIB(pDataObj As oleexp3.IDataObject, pt As oleexp3.POINT) As Long
Dim tSTG As STGMEDIUM
Dim tFMT As FORMATETC
Dim lpGlobal As Long
Dim hGlobal As Long
    Debug.Print "Got cf_dib"
    tFMT.cfFormat = CF_DIB
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL
    
    pDataObj.GetData tFMT, tSTG
    Dim tBIH As BITMAPINFOHEADER
    Dim tInfo As BITMAPINFO
'    Dim nSZ As Long
'    nSZ = GlobalSize(tSTG.Data)
'    Debug.Print "dib memsize=" & nSZ
    RaiseEvent DropDIB(tSTG.Data, pt.X, pt.Y)
    If (bRender = True) And (mImgHWND <> 0) And (mImgDC <> 0) And (bSkip = False) Then
    lpGlobal = GlobalLock(tSTG.Data)
    CopyMemory tBIH, ByVal lpGlobal, 4&
    If tBIH.biSize < 40 Then
        Debug.Print "bad size on tBIH" ' deal with this, don't want to crash due to bad data/pointer
        Exit Function
    End If

    CopyMemory tBIH.biWidth, ByVal lpGlobal + 4, 36
    lRead = tBIH.biSize              ' determine where pixel data starts
    If tBIH.biCompression = 3& And tBIH.biSize = 40& Then lRead = lRead + 12& ' BI_BITFIELDS
    If tBIH.biClrUsed Then
        lRead = lRead + 4& * tBIH.biClrUsed
    ElseIf tBIH.biBitCount <= 8& Then
        lRead = lRead + 4& * 2 ^ tBIH.biBitCount
    End If
    SetDIBitsToDevice mImgDC, mImgX, mImgY, tBIH.biWidth, Abs(tBIH.biHeight), _
        0, 0, 0, Abs(tBIH.biHeight), ByVal lpGlobal + lRead, ByVal lpGlobal, 0 'DIB_RGB_COLORS
    RedrawWindow mImgHWND, 0, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_ERASE Or RDW_ALLCHILDREN
    UpdateWindow mImgHWND
'    Dim aBits() As Byte
'    ReDim aBits(0 To tBIH.biSizeImage - 1) ' << this should NOT be zero
'CopyMemory aBits(0), ByVal lpGlobal + lRead, tBIH.biSizeImage
'    Dim pStr As String
'    Dim cbt As Long
'    For cbt = 0 To UBound(aBits)
'        pStr = pStr & aBits(cbt) & ","
'    Next
'    Debug.Print "bts=" & pStr

'    SetDIBitsToDevice frmSearch.Picture4.hDC, 0, 0, tBIH.biWidth, Abs(tBIH.biHeight), _
'        0, 0, 0, Abs(tBIH.biHeight), ByVal lpGlobal + lRead, lpGlobal, DIB_RGB_COLORS
'    lpGlobal = GlobalLock(tSTG.Data)
'    CopyMemory tBIH, ByVal lpGlobal, LenB(tBIH)
    Debug.Print "dib bitcnt=" & tBIH.biBitCount
    Debug.Print "dib height=" & tBIH.biHeight
    Debug.Print "dib comp=" & tBIH.biSize
'    SetDIBitsToDevice frmSearch.Picture4.hDC, 0, 0, tBIH.biWidth, tBIH.biHeight, _
'        0, 0, 0, tBIH.biHeight, ByVal lpGlobal + 40&, tInfo, DIB_RGB_COLORS
        
'    Dim hDC As Long, hdcMem As Long
'    Dim hBitmap As Long, hOldBmp As Long
'
'    hDC = GetDC(0&)
'    hdcMem = CreateCompatibleDC(hDC)
'    hBitmap = CreateCompatibleBitmap(hDC, tBIH.biWidth, tBIH.biHeight)
'    hOldBmp = SelectObject(hdcMem, hBitmap)
'    Call StretchDIBits(hdcMem, 0, 0, tBIH.biWidth, tBIH.biHeight, 0, 0, _
'                        tBIH.biWidth, tBIH.biHeight, ByVal lpGlobal + 41&, tInfo, DIB_RGB_COLORS, SRCCOPY)
'    hBitmapToPictureBox2 frmSearch.Picture4, hBitmap, tBIH.biWidth, tBIH.biHeight
'    BitBlt frmSearch.Picture4.hDC, 0, 0, tBIH.biWidth, tBIH.biHeight, hdcMem, 0, 0, SRCCOPY
'    Debug.Print "hbitmap=" & hBitmap & ",hdcmem=" & hdcMem
'    Call SelectObject(hdcMem, hOldBmp)
'    Call DeleteObject(hBitmap)
'    Call DeleteDC(hdcMem)
'    Call ReleaseDC(0&, hDC)
    End If
    Call GlobalUnlock(tSTG.Data)
    ReleaseStgMedium tSTG


End Function
Private Function DoDrop_TextW(pDataObj As oleexp3.IDataObject, pt As oleexp3.POINT) As Long
Dim tSTG As STGMEDIUM
Dim tFMT As FORMATETC
Dim lpGlobal As Long
Dim hGlobal As Long
Dim lpText As Long
Dim stBuf As String
    Debug.Print "got unicode text drop"
    tFMT.cfFormat = CF_UNICODETEXT
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL

    pDataObj.GetData tFMT, tSTG
    lpText = GlobalLock(tSTG.Data)
    If (tSTG.Data <> 0&) And (lpText <> 0&) Then DoDrop_TextW = 1
    Debug.Print "cf_unicodetext=" & LPWSTRtoStr(lpText, False)
    RaiseEvent DropText(LPWSTRtoStr(lpText, False), pt.X, pt.Y)
    Call GlobalUnlock(tSTG.Data)
    ReleaseStgMedium tSTG
End Function
Private Function DoDrop_TextA(pDataObj As oleexp3.IDataObject, pt As oleexp3.POINT) As Long
Dim tSTG As STGMEDIUM
Dim tFMT As FORMATETC
Dim lpGlobal As Long
Dim hGlobal As Long
Dim lpText As Long
Dim stBuf As String
    Debug.Print "got ansi text drop"
    tFMT.cfFormat = CF_TEXT
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL

    pDataObj.GetData tFMT, tSTG
    lpText = GlobalLock(tSTG.Data)
    stBuf = GetStrFromPtrA(lpText)
    Debug.Print "cf_text=" & stBuf
    RaiseEvent DropText(stBuf, pt.X, pt.Y)
    Call GlobalUnlock(tSTG.Data)
    ReleaseStgMedium tSTG

End Function
Private Function DoDrop_URLW(pDataObj As oleexp3.IDataObject, pt As oleexp3.POINT) As Long
Dim tSTG As STGMEDIUM
Dim tFMT As FORMATETC
Dim lpGlobal As Long
Dim hGlobal As Long
Dim lpText As Long
Dim stBuf As String
    Debug.Print "got unicode url drop"
    tFMT.cfFormat = CF_INETURLW
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL

    pDataObj.GetData tFMT, tSTG
    lpText = GlobalLock(tSTG.Data)
    If (tSTG.Data <> 0&) And (lpText <> 0&) Then DoDrop_URLW = 1
    Debug.Print "cf_unicodetext=" & LPWSTRtoStr(lpText, False)
    RaiseEvent DropURL(LPWSTRtoStr(lpText, False), pt.X, pt.Y)
    Call GlobalUnlock(tSTG.Data)
    ReleaseStgMedium tSTG
End Function
Private Function DoDrop_URLA(pDataObj As oleexp3.IDataObject, pt As oleexp3.POINT) As Long
Dim tSTG As STGMEDIUM
Dim tFMT As FORMATETC
Dim lpGlobal As Long
Dim hGlobal As Long
Dim lpText As Long
Dim stBuf As String
    Debug.Print "got ansi url drop"
    tFMT.cfFormat = CF_INETURL
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL

    pDataObj.GetData tFMT, tSTG
    lpText = GlobalLock(tSTG.Data)
    stBuf = GetStrFromPtrA(lpText)
    Debug.Print "cf_text=" & stBuf
    RaiseEvent DropURL(stBuf, pt.X, pt.Y)
    Call GlobalUnlock(tSTG.Data)
    ReleaseStgMedium tSTG

End Function
Private Function DoDrop_HTML(pDataObj As oleexp3.IDataObject, pt As oleexp3.POINT) As Long
Dim tSTG As STGMEDIUM
Dim tFMT As FORMATETC
Dim lpGlobal As Long
Dim hGlobal As Long
Dim lpText As Long
Dim stBuf As String
      Debug.Print "Got HTML drop"
    tFMT.cfFormat = CF_HTML
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL

      pDataObj.GetData tFMT, tSTG
      lpText = GlobalLock(tSTG.Data)
      RaiseEvent DropHTML(GetStrFromPtrA(lpText), pt.X, pt.Y)
      Call GlobalUnlock(tSTG.Data)
      ReleaseStgMedium tSTG

End Function
Private Function DoDrop_RTF(pDataObj As oleexp3.IDataObject, pt As oleexp3.POINT) As Long
Dim tSTG As STGMEDIUM
Dim tFMT As FORMATETC
Dim lpGlobal As Long
Dim hGlobal As Long
Dim lpText As Long
      Debug.Print "Got RTF drop"
    tFMT.cfFormat = CF_RTF
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL

      pDataObj.GetData tFMT, tSTG
      lpText = GlobalLock(tSTG.Data)
      RaiseEvent DropRTF(GetStrFromPtrA(lpText), pt.X, pt.Y)
      Call GlobalUnlock(tSTG.Data)
      ReleaseStgMedium tSTG

End Function
Private Function DoDrop_HDROP(pDataObj As oleexp3.IDataObject, pdwEffect As Long, pt As oleexp3.POINT) As Long
    Dim sF() As String
    ReDim sF(0)
    'WINXP: Use this method only
'    pDataObj.GetData fmt, stg
'    Dim i As Long
'    Dim sBuffer As String
'    nFiles = DragQueryFileW(stg.Data, &HFFFFFFFF, 0, 0)
'    ReDim sF(nFiles - 1)
'    For i = 0 To nFiles - 1
'        SysReAllocStringLen VarPtr(sBuffer), , DragQueryFileW(stg.Data, i)
'        DragQueryFileW stg.Data, i, StrPtr(sBuffer), Len(sBuffer) + 1&
'        sF(i) = sBuffer
'    Next
'   RaiseEvent DropFilesXP(sF, pdwEffect)
    Dim psia As IShellItemArray
    Dim piesi As IEnumShellItems
    Dim pItem As IShellItem
    Dim lpFile As Long
    Dim pcl As Long
    Dim nF As Long
    Call SHCreateShellItemArrayFromDataObject(pDataObj, IID_IShellItemArray, psia)
    If (psia Is Nothing) = False Then
        psia.EnumItems piesi
        Do While (piesi.Next(1, pItem, pcl) = NOERROR)
            pItem.GetDisplayName SIGDN_FILESYSPATH, lpFile
            ReDim Preserve sF(nF)
            sF(nF) = LPWSTRtoStr(lpFile)
            nF = nF + 1

        Loop
        RaiseEvent DropFiles(psia, sF, pt.X, pt.Y, pdwEffect)
        If mHandleFiles Then
            Dim pDT As IDropTarget
            Dim pidl() As Long, pidlChild As Long, pidlPar As Long
            ReDim pidl(0)
            If sFolder = "" Then
                sFolder = mCurPath
            End If
            Debug.Print "explorer drop to " & sFolder
            pidl(0) = ILCreateFromPathW(StrPtr(sFolder))
           isfDesktop.GetUIObjectOf 0&, 1, pidl(0), IID_IDropTarget, 0&, pDT
            If (pDT Is Nothing) = False Then
                pDT.DragEnter pDataObj, MK_LBUTTON, pt.X, pt.Y, pdwEffect 'pdwEffect has no effect here; Explorer chooses the default
                pDT.Drop pDataObj, MK_LBUTTON, pt.X, pt.Y, DROPEFFECT_MOVE Or DROPEFFECT_COPY Or DROPEFFECT_LINK 'allowed effects.. if it's not here it won't appear on the menu
                Debug.Print "dropped via explorer"
                Call CoTaskMemFree(pidlChild)
                Call CoTaskMemFree(pidlPar)
                Call CoTaskMemFree(pidl(0))
                Exit Function
            Else
                Debug.Print "no pDT"
            End If
        End If
    End If

End Function
Private Sub SetPreferredEffect(ido As oleexp3.IDataObject, nVal As Long)
Dim fmt As FORMATETC
Dim stg As STGMEDIUM
Dim tDD As DROPDESCRIPTION
Dim hGlobal As Long, lpGlobal As Long
Dim lpFmt As Long
Dim i As Long
'Dim cfstr As String
'cfstr = "Preferred DropEffect"
Debug.Print "adddil.enter"

hGlobal = GlobalAlloc(GHND, LenB(nVal))
If hGlobal Then
    lpGlobal = GlobalLock(hGlobal)
    Call CopyMemory(ByVal lpGlobal, nVal, LenB(nVal))
    Debug.Print "adddil.copymem"
    Call GlobalUnlock(hGlobal)
    stg.TYMED = TYMED_HGLOBAL
    stg.Data = lpGlobal
    fmt.cfFormat = CF_PREFERREDDROPEFFECT
    fmt.dwAspect = DVASPECT_CONTENT
    fmt.lIndex = -1
    fmt.TYMED = TYMED_HGLOBAL
    ido.SetData fmt, stg, 1
Else
    Debug.Print "failed to get hglobal"
End If
End Sub
Private Sub AddDropDescription(ido As oleexp3.IDataObject, nType As DROPIMAGETYPE, sMsg As String, sIns As String)
Dim fmt As FORMATETC
Dim stg As STGMEDIUM
Dim tDD As DROPDESCRIPTION
Dim iTmp1() As Integer
Dim iTmp2() As Integer
Dim hGlobal As Long, lpGlobal As Long
Dim i As Long
On Error GoTo e0

Str2WCHAR sMsg, iTmp1
Str2WCHAR sIns, iTmp2

For i = 0 To UBound(iTmp1)
    tDD.szMessage(i) = iTmp1(i)
Next i

For i = 0 To UBound(iTmp2)
    tDD.szInsert(i) = iTmp2(i)
Next i
tDD.type = nType

hGlobal = GlobalAlloc(GHND, LenB(tDD))
If hGlobal Then
    lpGlobal = GlobalLock(hGlobal)
    Call CopyMemory(ByVal lpGlobal, tDD, LenB(tDD))
    Call GlobalUnlock(hGlobal)
    
    stg.TYMED = TYMED_HGLOBAL
    stg.Data = lpGlobal
     
    
    fmt.cfFormat = CF_DROPDESCRIPTION
    fmt.dwAspect = DVASPECT_CONTENT
    fmt.lIndex = -1
    fmt.TYMED = TYMED_HGLOBAL
        
    ido.SetData fmt, stg, 1
End If
Exit Sub
e0:
    Debug.Print "AddDropDescription->" & Err.Description
End Sub
Private Sub Str2WCHAR(sz As String, iOut() As Integer)
Dim i As Long
ReDim iOut(255)
'If Len(sz) > MAX_PATH Then sz = Left$(sz, MAX_PATH)
For i = 1 To Len(sz)
    iOut(i - 1) = AscW(Mid(sz, i, 1))
Next i

End Sub
Private Function PathGetDisp(ByVal sPath As String) As String
If Right$(sPath, 1) = "\" Then
    sPath = Left$(sPath, Len(sPath) - 1)
End If
Dim psi As IShellItem
Dim lp As Long
Call SHCreateItemFromParsingName(StrPtr(sPath), ByVal 0&, IID_IShellItem, psi)
If (psi Is Nothing) = False Then
    psi.GetDisplayName SIGDN_NORMALDISPLAY, lp
    PathGetDisp = LPWSTRtoStr(lp)
End If
End Function
Private Function LPWSTRtoStr(lPtr As Long, Optional ByVal fFree As Boolean = True) As String
SysReAllocString VarPtr(LPWSTRtoStr), lPtr
If fFree Then
    Call CoTaskMemFree(lPtr)
End If
End Function
Private Function AddBackslash(s As String) As String

   If Len(s) > 0 Then
      If Right$(s, 1) <> "\" Then
         AddBackslash = s & "\"
      Else
         AddBackslash = s
      End If
   Else
      AddBackslash = "\"
   End If

End Function
Private Function GetStrFromPtrA(lpszA As Long) As String
  Dim sRtn As String
  sRtn = String$(lstrlenA(ByVal lpszA), 0)
  Call lstrcpyA(ByVal sRtn, ByVal lpszA)
  GetStrFromPtrA = sRtn
End Function