VB6.0用掲示板の過去のログ(No.1)−VBレスキュー(花ちゃん)
[記事リスト]
[新規投稿]
[新着記事]
[ワード検索]
[過去ログ]
[管理用]
| 投稿日 | ： 2003/05/10(Sat) 13:13 |
| 投稿者 | ： 魔界の仮面弁士 |
| Ｅメール | ： |
| ＵＲＬ | ： |
| タイトル | ： Re^4: フレームで区切られたブラウザー |
> IPersistFileインターフェイス用のタイプライブラリを、別途参照設定する必要があります。
タイプライブラリを使わないバージョンを作ってみました。
DispCallFunc APIを使って、IPersistFile.Saveを直接呼び出しています。
ついでに、DocumentCompleteイベントでの処理を、ちょっと手直ししてあります。
'===== フォームに、WebBrowserコントロールを貼り付けておき、
'===== そこに下記のコードを記述してください。
Option Explicit
Private Sub Form_Load()
WebBrowser1.Tag = ""
WebBrowser1.Navigate2 "http://www.asahi-net.or.jp/~rg7f-tkhs/frame6.html"
End Sub
Private Sub WebBrowser1_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
'最初に飛ぶURL(フレームの一番外側のページ)を覚えておく
If WebBrowser1.Tag = "" Then
WebBrowser1.Tag = URL
End If
End Sub
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
'最初のURLが完了した時(全てのページがダウンロードされた時)
If WebBrowser1.Tag = URL Then
'ドキュメントを C:\TEST\に保存する
SaveDocument "C:\TEST\", pDisp.Document
WebBrowser1.Tag = ""
End If
End Sub
Private Sub SaveDocument(ByVal Folder As String, ByVal Document As Object)
Dim FileName As String
Dim L As Long
If TypeName(Document) <> "HTMLDocument" Then
Exit Sub
End If
'同名のファイル名があった場合、上書きされていってしまうので、
'実際に使うときには、もう少しこの部分の修正が必要になるかも。
Debug.Print Document.location.href
FileName = Document.location.pathname
FileName = Folder & Mid(FileName, InStrRev(FileName, "/") + 1)
With New PersistFile
.SetObject Document
.Save FileName, False
End With
With Document.frames
For L = 0 To .length - 1
SaveDocument Folder, .Item(L).Document
Next
End With
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
- 関連一覧ツリー
（★ をクリックするとツリー全体を一括表示します）
- 返信フォーム
（この記事に返信する場合は下記フォームから投稿して下さい）