「WebBrowser」でソースコードを取得するには? (ID：79670)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

ちなみに、タイプライブラリを使わず、COM APIを直接呼び出すのであれば、こんな感じになります。

Private Sub Command1_Click()
    If TypeName(WebBrowser1.Document) = "HTMLDocument" Then
        With New PersistFile
            .SetObject Me.WebBrowser1.Document
            .Save "C:\TEST.HTML", False
        End With
    End If
End Sub

'===== クラスモジュールを追加し、クラス名を PersistFile という名前にしてから、
'===== そこに下記のコードを記述してください。
Option Explicit

Private Type UUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type
Private mudtIPersistFile As UUID    'IID_IPersistFileの格納用

Private Const autCCStdCall = 4
Private Declare Function DispCallFunc Lib "oleaut32" _
   (ByVal pvInstance As Long, _
    ByVal oVft As Long, _
    ByVal CallConv As Integer, _
    ByVal vtReturn As Integer, _
    ByVal cActuals As Long, _
    ByRef prgvt As Integer, _
    ByRef prgpvarg As Long, _
    ByRef pvargResult As Variant _
) As Long

Private mobjSource As Object
Private mlpPersistFile As Long

'メソッドの位置
Private Const comIUnknown_QueryInterface = 0
Private Const comIUnknown_Release = 8
Private Const comIPersistFile_Save = 24

Private Sub Class_Initialize()
    '{0000010b-0000-0000-C000-000000000046}
    With mudtIPersistFile
        .Data1 = &H10B
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
End Sub

Public Sub SetObject(ByVal Source As Object)
    Set mobjSource = Source
    If Source Is Nothing Then
        mlpPersistFile = 0
    Else
        Dim hResult As Long
        
        If mlpPersistFile <> 0 Then
            Call Invoke_(mlpPersistFile, comIUnknown_Release)
            mlpPersistFile = 0
        End If

hResult = Invoke_(ObjPtr(Source), comIUnknown_QueryInterface, _
                    VarPtr(mudtIPersistFile), VarPtr(mlpPersistFile))
        If hResult < 0 Then
            mlpPersistFile = 0
            Err.Raise hResult
        End If
    End If
End Sub

Public Sub Save(ByVal pszFileName As String, ByVal fRemember As Boolean)
    Dim bytFileName() As Byte
    Dim hResult As Long
    Dim lngBool As Long

If mlpPersistFile = 0 Then
        'オブジェクト変数またはWithブロック変数が設定されていません。
        Err.Raise 91
        Exit Sub
    End If

bytFileName = pszFileName & vbNullChar
    lngBool = IIf(fRemember, 1&, 0&)

hResult = Invoke_(mlpPersistFile, comIPersistFile_Save, _
                        VarPtr(bytFileName(0)), lngBool)
    If hResult <> 0 Then
        Err.Raise hResult
    End If
End Sub

Private Function Invoke_(ByVal lpObject As Long, ByVal VtblOffset As Long, _
                         ParamArray Args() As Variant) As Long
    Dim lngPtArgs() As Long
    Dim intVtArgs() As Integer
    Dim varResult As Variant
    Dim lngArgs As Long
    Dim n As Long
    
    If lpObject = 0 Then
        Exit Function
    End If

lngArgs = UBound(Args) - LBound(Args) + 1
    If lngArgs = 0 Then
        ReDim lngPtArgs(0), intVtArgs(0)
    Else
        ReDim lngPtArgs(lngArgs - 1), intVtArgs(lngArgs - 1)
        For n = 0 To lngArgs - 1
            intVtArgs(n) = VarType(Args(n))
            lngPtArgs(n) = VarPtr(Args(n))
        Next
    End If

n = 0
    n = DispCallFunc(lpObject, VtblOffset, autCCStdCall, _
            vbLong, lngArgs, intVtArgs(0), lngPtArgs(0), varResult)
    If n >= 0 Then
        Invoke_ = CLng(varResult)
    End If
End Function

Private Sub Class_Terminate()
    Call Invoke_(mlpPersistFile, comIUnknown_Release)
    mlpPersistFile = 0
    Set mobjSource = Nothing
End Sub

←解決時は質問者本人がここをチェックしてください。

戻る