VBAでIInternetExplorerManager

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, _
    ByVal lpiid As LongPtr _
) As Long

Private Declare PtrSafe _
Function DispCallFunc Lib "OleAut32.dll" ( _
    ByVal pvInstance As LongPtr, _
    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 CoGetObject Lib "Ole32" ( _
        ByVal pszName As LongPtr, _
        ByVal pBindOptions As LongPtr, _
        ByRef riid As GUID, _
        ByRef ppv As Any) As Long

Private Declare PtrSafe _
Function CoCreateInstance Lib "Ole32" ( _
        ByRef rclsid As GUID, _
        ByVal pUnkOuter As LongPtr, _
        ByVal dwClsContext As Long, _
        ByRef riid As GUID, _
        ByRef ppv As Any) As Long
            
Sub hoge()

    'https://msdn.microsoft.com/en-us/library/hh995094%28v=vs.85%29.aspx
    Dim unk As IUnknown 'IInternetExplorerManager
    Dim hr As Long
    Dim IID_IInternetExplorerManager As GUID
    hr = IIDFromString(StrPtr("{ACC84351-04FF-44F9-B23F-655ED168C6D5}"), VarPtr(IID_IInternetExplorerManager))
    'Debug.Print Hex$(hr)
    
    'CLSID_InternetExplorerManager
    hr = CoGetObject(StrPtr("new:DF4FCC34-067A-4E0A-8352-4A1A5095346E"), 0, IID_IInternetExplorerManager, unk)
    'Debug.Print Hex$(hr), unk Is Nothing


    Dim iid As GUID 'IID_IWebBrowser2
    hr = IIDFromString(StrPtr("{D30C1661-CDAF-11D0-8A3E-00C04FC9E26E}"), VarPtr(iid))
    'Debug.Print Hex$(hr)
    
    Dim ie As InternetExplorer
    
    Dim Vnt(0 To 3) As Variant
    Vnt(0) = 1&
    Vnt(1) = StrPtr(vbNullString)
    Vnt(2) = VarPtr(iid)
    Vnt(3) = VarPtr(ie)
    
    Dim pArgs(0 To 3) As LongPtr
    Dim i As Long
    Dim vt(0 To 3) As Integer
    For i = 0 To 3
        pArgs(i) = VarPtr(Vnt(i))
        vt(i) = VarType(Vnt(i))
    Next

    Dim VTBLIndex As Long
    VTBLIndex = 3
#If Win64 Then
    VTBLIndex = VTBLIndex * 8
#Else
    VTBLIndex = VTBLIndex * 4
#End If

    Dim vntResult As Variant
    hr = DispCallFunc(ObjPtr(unk), VTBLIndex, _
                        CC_STDCALL, vbLong, _
                        4, vt(0), pArgs(0), vntResult)
    'Debug.Print Hex$(hr), Hex$(vntResult)
    'Debug.Print ie Is Nothing

    ie.Visible = True
    ie.Navigate "http://www.yahoo.co.jp/"
    While ie.Busy Or ie.ReadyState <> 4 'READYSTATE_COMPLETE
        DoEvents
    Wend
    Dim doc As Object
    Set doc = ie.document
    doc.forms("sf1")("p").Value = "hoge"
    'doc.forms("sf1").submit

End Sub

質問してもよろしいでしょうか？

上記にてホームページを遷移させてみました！たいていの場合はうまくいくのですが、http://www.htmq.com/html/table.shtml のホームページの次のところでひっかかります。なにか対処法などありますでしょうか？

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, _
    ByVal lpiid As LongPtr _
) As Long

Private Declare PtrSafe _
Function DispCallFunc Lib "OleAut32.dll" ( _
    ByVal pvInstance As LongPtr, _
    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 CoGetObject Lib "Ole32" ( _
        ByVal pszName As LongPtr, _
        ByVal pBindOptions As LongPtr, _
        ByRef riid As GUID, _
        ByRef ppv As Any) As Long

Private Declare PtrSafe _
Function CoCreateInstance Lib "Ole32" ( _
        ByRef rclsid As GUID, _
        ByVal pUnkOuter As LongPtr, _
        ByVal dwClsContext As Long, _
        ByRef riid As GUID, _
        ByRef ppv As Any) As Long
            
Sub hoge()

    'https://msdn.microsoft.com/en-us/library/hh995094%28v=vs.85%29.aspx
    Dim unk As IUnknown 'IInternetExplorerManager
    Dim hr As Long
    Dim IID_IInternetExplorerManager As GUID
    hr = IIDFromString(StrPtr("{ACC84351-04FF-44F9-B23F-655ED168C6D5}"), VarPtr(IID_IInternetExplorerManager))
    'Debug.Print Hex$(hr)
    
    'CLSID_InternetExplorerManager
    hr = CoGetObject(StrPtr("new:DF4FCC34-067A-4E0A-8352-4A1A5095346E"), 0, IID_IInternetExplorerManager, unk)
    'Debug.Print Hex$(hr), unk Is Nothing


    Dim iid As GUID 'IID_IWebBrowser2
    hr = IIDFromString(StrPtr("{D30C1661-CDAF-11D0-8A3E-00C04FC9E26E}"), VarPtr(iid))
    'Debug.Print Hex$(hr)
    
    Dim ie As InternetExplorer
    
    Dim Vnt(0 To 3) As Variant
    Vnt(0) = 1&
    Vnt(1) = StrPtr(vbNullString)
    Vnt(2) = VarPtr(iid)
    Vnt(3) = VarPtr(ie)
    
    Dim pArgs(0 To 3) As LongPtr
    Dim i As Long
    Dim vt(0 To 3) As Integer
    For i = 0 To 3
        pArgs(i) = VarPtr(Vnt(i))
        vt(i) = VarType(Vnt(i))
    Next

    Dim VTBLIndex As Long
    VTBLIndex = 3
#If Win64 Then
    VTBLIndex = VTBLIndex * 8
#Else
    VTBLIndex = VTBLIndex * 4
#End If

    Dim vntResult As Variant
    hr = DispCallFunc(ObjPtr(unk), VTBLIndex, _
                        CC_STDCALL, vbLong, _
                        4, vt(0), pArgs(0), vntResult)
    'Debug.Print Hex$(hr), Hex$(vntResult)
    'Debug.Print ie Is Nothing

    ie.Visible = True
    ie.navigate "http://www.yahoo.co.jp/"
    While ie.Busy Or ie.ReadyState <> 4 'READYSTATE_COMPLETE
        DoEvents
    Wend
    Dim doc As Object
    Set doc = ie.document

    ie.Visible = True
    ie.navigate "http://www.htmq.com/html/table.shtml"
    While ie.Busy Or ie.ReadyState <> 4 'READYSTATE_COMPLETE
        DoEvents
    Wend
    Set doc = ie.document

    ie.Visible = True
    ie.navigate "https://www.google.com/"
    While ie.Busy Or ie.ReadyState <> 4 'READYSTATE_COMPLETE
        DoEvents '''' <================ ここでつっかかる！！！！！
    Wend
    Set doc = ie.document
    
        ie.Visible = True
    ie.navigate "https://www.mizuhobank.co.jp/retail/takarakuji/loto/loto6/index.html"
    While ie.Busy Or ie.ReadyState <> 4 'READYSTATE_COMPLETE
        DoEvents
    Wend
    Set doc = ie.document
    
    doc.GotoPage "http://www.htmq.com/html/table.shtml"

End Sub

DoEvents をSleepに置き換えるぐらいしか、思い付きません。

なるほどです！

ですよね、ですよね。。。　このサイトが難しいのかもしれません。。。a タグもうまく押せなかったですし・・・。Google, Yahoo などはうまくいくので、多分このサイト固有の問題かもしれません。。

返事をいただきありがとうございますね。

くまっちさんのコード大切に使わさせていただきます！

また何かあればここに書き込みます！

ありがとうございます！！！

おはようございます！

現在、日本時間の2019/06/21 AM7:15 なのですが、やってみたらできました！

時間なども関係してそうです！

ご報告まで (^_^)/