| タイトル | ： Re: BASIC認証が必要なホームページへのアクセス【解決】 |
| 記事No | ： 15164 |
| 投稿日 | ： 2011/04/11(Mon) 09:50 |
| 投稿者 | ： だんぼる |
花ちゃん様、YuO様、本当にありがとうございました。
花ちゃん様の投稿の
> IE.Silent = True で起動すれば、DocumentComplete イベントで付加する事ができます。
を調べようとGoogleにて「VB6 IE.Silent = True」と検索したところ、なんと花ちゃん様
が投稿して頂いた記事がキャッシュで表示できました！
そちらにて動作確認してみたところ、ほぼ希望の動作となることを確認しました。
最初、「DocumentComplete」か「NavigateComplete2」では次ページへのリンクをクリック
した際、認証ダイアログが先に表示されてしまうのではないかと思ったのですが、
「IE.Silent = True」というのがミソだったのですね！
一瞬「ページを表示できません」というようなメッセージが表示されますので、そこだけ
なんとかごまかして実用ソースにしていきたいと思います。
本当にいろいろとありがとうございました。
以下ソースです。（ほぼ花ちゃん様ご提供のソース）
新規プロジェクトに「Command1」ボタンを追加。
プロジェクト→参照設定→Microsoft Internet Controls にチェック。
（こちら、当方環境では参照設定のリストに「Microsoft Internet Controls」が
存在しなかった為、参照にて直接dllを参照しました。system32\ieframe.dllです。）
Option Explicit
Const BASE64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
"abcdefghijklmnopqrstuvwxyz0123456789+/"
Private WithEvents IE As SHDocVw.InternetExplorer
Private myURL As String
Private SNo As Integer
Private Sub Command1_Click()
Dim strHEAD As String
strHEAD = "Authorization: Basic " & StrToBase64("user:user01") & vbCrLf
Set IE = New SHDocVw.InternetExplorer
myURL = "http://cult.jp/danboru/test/Index.html"
SNo = 1
IE.Navigate myURL, , , , strHEAD
IE.Silent = True
IE.Visible = True
End Sub
Private Sub IE_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Debug.Print SNo, URL
Dim strHEAD As String
If SNo = 1 And URL = "http://cult.jp/danboru/test/Index.html" Then
strHEAD = "Authorization: Basic " & StrToBase64("user:user01") & vbCrLf
myURL = "http://cult.jp/danboru/test/Index.html"
IE.Navigate2 myURL, , , , strHEAD
SNo = 2
End If
If SNo = 2 And URL = "http://cult.jp/danboru/test/List.html" Then
strHEAD = "Authorization: Basic " & StrToBase64("user:user01") & vbCrLf
myURL = "http://cult.jp/danboru/test/List.html"
IE.Navigate2 myURL, , , , strHEAD
SNo = 3
IE.Silent = False
End If
End Sub
'******↓↓↓ 以下、Base64への変換 ↓↓↓ ******
Function StrToBase64$(ByVal src$)
Dim tempDigit$, temp64$, mo&
tempDigit$ = StrToDigit$(src$)
temp64$ = DigitToBase64$(StrToDigit$(src$))
temp64$ = temp64$ & String$((4 - (Len(temp64$) Mod 4)) Mod 4, "=")
StrToBase64$ = temp64$
End Function
Function DigitToBase64$(ByVal src$)
Dim i&, ret$, c&
src$ = src$ & String$((6 - (Len(src$) Mod 6)) Mod 6, "0")
For i = 1 To Len(src$) Step 6
c = DigitToInt("00" & Mid$(src$, i, 6)) + 1
ret$ = ret$ & Mid$(BASE64, c, 1)
Next
DigitToBase64$ = ret$
End Function
Function StrToDigit$(ByVal src$)
Dim i&, c&, ret$
For i = 1 To Len(src$)
c = Asc(Mid$(src$, i, 1))
If c >= 0 Then
ret$ = ret$ & IntToDigit$(c)
Else
ret$ = ret$ & IntToDigit$((c And -256) / 256)
ret$ = ret$ & IntToDigit$(c And 255)
End If
Next
StrToDigit$ = ret$
End Function
Private Function IntToDigit$(ByVal x&)
Dim i&, ret$
For i = 7 To 0 Step -1
If (x And 2 ^ i) = 0 Then ret$ = ret$ & "0" Else ret$ = ret$ & "1"
Next
IntToDigit$ = ret$
End Function
Private Function DigitToInt&(ByVal x$)
Dim i&, ret&
For i = 1 To 8
If Mid$(x$, i, 1) = "1" Then ret = ret + 2 ^ (8 - i)
Next
DigitToInt = ret
End Function
|