タイトル : BASIC認証が必要なホームページへのアクセス 投稿日 : 2011/04/05(Tue) 12:12 投稿者 : だんぼる
初めまして、だんぼると申します。 Basic認証が必要なホームページ上のスペースに、プログラムの追加データを 置いてあります。(厳密なアクセス制限でないことは了承済) トップページと追加データのリストのページと、追加方法の説明ページがあります。 いろいろと探してみたところ、VB6でのBasic認証ページへのアクセス方法 を見つけ、下記のサンプルを作ってみました。 (フォームにコマンドボタンをひとつ設置) 試してみたところ、トップページのアクセスにはダイアログが表示されることなく 成功するのですが、その先のページにアクセスしようとするとダイアログが表示されて しまいます。 パケットキャプチャソフト「Wireshark」で調べてみたところ、通常のブラウザで アクセスした際はトップページにてIDパスを入力後、その他のページにアクセスした 際もヘッダに「Authorization: Basic〜」が入っていました。 しかしVB6から開いた際は、トップページにアクセスする際に「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("「ユーザID」:「パスワード」") & vbCrLf objIE.Navigate "「認証が必用なページのトップページ」", , , , strHEAD End Sub 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 |