タイトル : Re^2: BASIC認証が必要なホームページへのアクセス 投稿日 : 2011/04/07(Thu) 18:12 投稿者 : だんぼる
失礼しました、動作可能なソースに変更しました。 [実行環境] VisualBasic6.0(SP5) WindowsXP(SP3) IE8.0 No.15044 の回答についてですが、Basic認証ではCookie等は使用されず、認証後は ブラウザが自動でヘッダに「Authorization: Basic 〜」を追加してくれるようです。 しかし以下のようにVBからヘッダに認証情報を追加して開いた際は、最初のページは 開くのですが、以降のページには「Authorization: Basic 〜」を追加してくれてい ないようです。 IEのその当たりの挙動に関しては仕様が公開されておらず、VBから操作することは出来 ないようです。 また、トップページに写真等が貼り付けられている場合も写真ファイルの取得で認証 エラーになるらしく、認証ダイアログが表示されてしまいます。 APIか何かで、httpリクエストを送る際、毎回「Authorization: Basic 〜」を追加で きればいいのかなとは思うのですが、その方法もよくわからず現在調べております。 Option Explicit Const BASE64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & _ "abcdefghijklmnopqrstuvwxyz0123456789+/" Dim objIE Dim objShell Private Sub Command1_Click() Dim strHEAD As String 'Shell.Applicationオブジェクトの作成 Set objShell = CreateObject("Shell.Application") 'IEオブジェクトの作成(ダミー) Set objIE = CreateObject("InternetExplorer.Application") objIE.Visible = True 'IEウィンドウを表示 strHEAD = "Authorization: Basic " & StrToBase64("user:user01") & vbCrLf objIE.Navigate "http://cult.jp/danboru/test/Index.html", , , , strHEAD 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 |