tagCANDY CGI VBレスキュー(花ちゃん)の Visual Basic 6.0用 掲示板
VBレスキュー(花ちゃん)の Visual Basic 6.0用 掲示板
[ツリー表示へ]  [ワード検索]  [Home]

タイトル 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

- 関連一覧ツリー をクリックするとツリー全体を一括表示します)

古いスレッドにレスはつけられません。