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

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

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

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