Drag and Drop image from chrome

[LeandroA]

hello,you know what is the way to get the image dragged and dropped from a browser (chrome) and get the image?, if we do this on the explorer this creates a file, although I can get the url of the image, this does not seem to be utility as this may also not be an image url but a link
on the other hand vbCFFiles, vbCFDIB and vbCFBitmap are not present there are many formats but I do not know which would be the correct one, two of them give me error when recovering them

Option Explicit

Private Sub Form_Load()
    Me.OLEDropMode = 1
End Sub

Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
      On Error Resume Next
      Dim i As Long
      With Data
        For i = -20000 To 20000
            If .GetFormat(i) Then
                Debug.Print i, Left(StrConv(.GetData(i), vbUnicode), 10)
                If Err.Number Then
                    Debug.Print "Error Data", i
                    Err.Clear
                End If
            End If
        Next
      End With
End Sub

print result

'Error Data - 16264
'-16195            €
'-16191        Version:0.
'-16186        http://lea
''Error Data - 16184
'-16179        h t t p :
'-16176        ÿÿÿÿ
'-16094        X  P   G
'-16001
'-15782        h t t p :
'-15774        <img id="s
'-15773
'-15768
'-15767        ¶
' 1            h t t p :  <----vbCFText
' 13           h t t p :

see if any data throws the head of a jpg ÿØÿà but nothing similar

(In Windows 10, you should run Chrome as an administrator so you can drag and drop over vb6 IDE)

[LeandroA]

this way I can get the image url, but surely the array of the file should be somewhere

        If .GetFormat(-15774) Then
            Dim sHtml As String, lPos As Long, sUrl As String
            
            sHtml = StrConv(Data.GetData(-15774), vbUnicode)
            
            If Left$(sHtml, 4) = "<img" Then
                lPos = InStr(sHtml, "src=""")
                If lPos Then
                    sUrl = Mid(sHtml, lPos + 5)
                    lPos = InStr(sUrl, """")
                    sUrl = Left$(sUrl, lPos - 1)
                    Debug.Print sUrl
                End If
            End If
        End If

I will have to contemplate this also data:image/jpeg;base64,/

[fafalone]

Chrome has file contents/file group descriptor on dragged/dropped images.


See this post for discussion (and that thread in general).

The type of object chrome is using doesn't seem to be working with that code right now, so more work needs to be done (it's writing nonsense).

Edit: I've modified things a bit to work specifically with Chrome, which supports HGLOBAL on FileContents, but for some reason it's impossible to create an IStream on it. So now that part just copies the data directly and hands it off to a generic 'write byte array to file' routine

Private Function DoDrop_FileContents(pDataObj As oleexp.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
mFileContentsPath = "C:\temp2\droptest1"
    '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)
            Dim dtsize As Long
            dtsize = GlobalSize(tSTG.Data)
            Debug.Print "size=" & dtsize
            Dim bDat() As Byte
            ReDim bDat(dtsize - 1)
            CopyMemory ByVal VarPtr(bDat(0)), ByVal lpGlobal, dtsize
            
            WriteByteArr bDat, mFileContentsPath & "\" & sFCN(idx)
            GlobalUnlock tSTG.Data
            GoTo nxt
        End If
   End If
     'Code not relevant to Chrome specifically omitted, see full class in linked thread for supporting other scenarios
nxt:
Next

End Function

Public Sub WriteByteArr(bytIn() As Byte, sSaveTo As String)
Dim hFile As Long
hFile = FreeFile
Open sSaveTo For Binary As #hFile
Put #hFile, 1, bytIn
Close #hFile
End Sub

You can also use OleGetClipboard in the native drop methods to get the dragdrop IDataObject to pass to that function.