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

タイトル Re: BASIC認証が必要なホームページへのアクセス【解決】
投稿日: 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

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

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