試行錯誤中

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 IIDFromString Lib "ole32.dll" ( _
    ByVal lpsz As LongPtr, _
    lpiid As GUID _
) As Long

Private Declare PtrSafe _
Function DispCallFunc Lib "OleAut32.dll" ( _
    ByVal pvInstance As Any, _
    ByVal oVft As LongPtr, _
    ByVal cc_ As Long, _
    ByVal vtReturn As Integer, _
    ByVal cActuals As Long, _
    ByRef prgvt As Integer, _
    ByRef prgpvarg As LongPtr, _
    ByRef pvargResult As Variant _
    ) As Long
Const CC_STDCALL = 4&

Private Declare PtrSafe _
Function AtlIPersistStreamInit_Load Lib "atl.dll" ( _
    ByVal arg1 As Any, _
    ByRef arg2 As Any, _
    ByVal arg3 As Any, _
    ByVal arg4 As Any _
) As Long

Private Declare _
Function AtlAxWinInit Lib "atl.dll" () As Long

Private Declare PtrSafe _
Function AtlComQIPtrAssign Lib "atl.dll" ( _
    pp As IUnknown, _
    ByVal lp As IUnknown, _
    riid As GUID) _
As IUnknown

Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)

Sub hoge()

    Dim pStreamInt As IUnknown 'IPersistStreamInit
    Dim iid As GUID
    Dim hr As Long
    hr = IIDFromString(StrPtr("{7FD52380-4E07-101B-AE2D-08002B2EC713}"), iid)

    Dim pDoc As MSHTML.IHTMLDocument2
    Set pDoc = New HTMLDocument
    
    hr = CallComMethod(pDoc, 0, VarPtr(iid), VarPtr(pStreamInt))
    If pStreamInt Is Nothing Then Exit Sub

    Dim http As WinHttp.WinHttpRequest
    Set http = New WinHttp.WinHttpRequest
    http.Open "GET", "http://www.yahoo.co.jp/", False
    http.send

    Dim tmp As IUnknown
    Set tmp = http.ResponseStream
    'hr = CallComMethod(pStreamInt, 5, ObjPtr(tmp))
    AtlComQIPtrAssign pStreamInt, pDoc, iid

    Dim st&(0 To 3)
    'st(3) = VarPtr(iid)
    'hr = AtlIPersistStreamInit_Load(tmp, st(0), pDoc, pDoc)
    hr = CallComMethod(pStreamInt, 5, ObjPtr(tmp))
    Debug.Print Hex$(hr)

    While pDoc.readyState <> "complete"
        DoEvents
    Wend
    Debug.Print pDoc.Title

    CopyMemory pStreamInt, Nothing, 4


End Sub
' COMのメソッド呼び出し
Private Function CallComMethod(ByVal obj As Variant, _
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 pObj As Long
    Dim hr As Long
    Dim i As Long

    If IsObject(obj) Then
        pObj = ObjPtr(obj)
    ElseIf VarType(obj) = vbDataObject Then
        pObj = ObjPtr(obj)
    Else
        pObj = obj
    End If

    If pObj = 0 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(pObj, VTBLIndex * 4, _
                        CC_STDCALL, vbLong, _
                        lngCount, vt(0), pArgs(0), vntResult)
    If hr < 0 Then Err.Raise hr
    If vntResult < 0 Then
        If VTBLIndex <> 1 And VTBLIndex <> 2 Then
            Err.Raise vntResult
        End If
    End If
    CallComMethod = vntResult

End Function