HTML5のドラッグ＆ドロップ試行

Module1.bas

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Declare PtrSafe _
        Function IUnknown_QueryService Lib "shlwapi.dll" ( _
        ByVal punk As IUnknown, _
        guidService As GUID, _
        riid As GUID, _
        ppvOut As IAccessible _
      ) As Long

Private Declare Function IIDFromString Lib "ole32.dll" _
        (lpsz As Any, lpiid As Any) As Long

Private Declare Function DispCallFunc Lib "oleaut32" _
        (ByVal pvInstance As Long, ByVal oVft As Long, _
        ByVal cc As Long, ByVal vtReturn As Integer, _
        ByVal cActuals As Long, prgvt As Integer, _
        prgpvarg As Long, pvargResult As Variant) As Long
Const CC_STDCALL = 4
        
Sub hoge()

    Dim iid&(0 To 3)
    Const s = "{00000122-0000-0000-C000-000000000046}"
    IIDFromString ByVal s, iid(0)

    Dim IID_IAccessible As GUID

    With IID_IAccessible
        .Data1 = &H618736E0
        .Data2 = &H3C3D
        .Data3 = &H11CF
        .Data4(0) = &H81
        .Data4(1) = &HC
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H38
        .Data4(6) = &H9B
        .Data4(7) = &H71
    End With

    Const url = "https://twitter.com/"
    
    Dim IE
    Set IE = CreateObject("Shell.Application").Windows.findwindowSW(url, Empty, 1, 0, 1)
    If IE Is Nothing Then Exit Sub

    Dim hr As Long
    Dim pElement As MSHTML.IHTMLElement
    Set pElement = IE.document.all("tweet-box-mini-home-profile")
    
    
    'IHTMLElementからIAccessibleを取り出す
    Dim acc As IAccessible
    hr = IUnknown_QueryService(pElement, IID_IAccessible, IID_IAccessible, acc)
    'Debug.Print acc Is Nothing, Hex(hr)
    If hr < 0 Then Exit Sub

    Dim pTarget As IUnknown
    hr = CallComMethod(acc, 0, VarPtr(iid(0)), VarPtr(pTarget))
    Debug.Print Hex$(hr)

End Sub


' COMのメソッド呼び出し
Private Function CallComMethod(unk As IUnknown, _
ByVal VTBLIndex As Long, ParamArray Args() As Variant) As Long

    Dim pArgs() As Long
    Dim vt() As Integer
    Dim vntResult As Variant
    Dim lngCount As Long
    Dim hr As Long
    Dim i As Long

    If unk Is Nothing Then Err.Raise 91
    lngCount = UBound(Args) + 1
    ReDim pArgs(0 To lngCount + (lngCount > 0))
    ReDim vt(0 To UBound(pArgs))
    For i = 0 To lngCount - 1
        vt(i) = VarType(Args(i))
        pArgs(i) = VarPtr(Args(i))
    Next
    hr = DispCallFunc(ObjPtr(unk), VTBLIndex * 4, _
                        CC_STDCALL, vbLong, _
                        lngCount, vt(0), pArgs(0), vntResult)
    If hr < 0 Then Err.Raise hr
    CallComMethod = vntResult

End Functino