VB6 リダイレクトURLを利用したCSVファイルの自動ダウンロードについて

Question

お世話になっております。

今回、VB6にて用意されたリダイレクトURL(HTTPS)から自動でCSVファイルをダウンロードする処理の実装を行いたいと思っています。

どの様な方法があるかご教示ください。

<条件>

　・リダイレクトURLのためファイル名の指定はしない。

　・URLを呼ぶとファイルを「開く/保存/名前を付けて保存」から指定のフォルダへ保存を実行する。

以上、宜しくお願い致します。

Answer 1

こんな

Option Explicit

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Private Sub Command1_Click()
    'てすと
    DownloadFile_1 "https://go.microsoft.com/fwlink/?LinkId=691129"
    DownloadFile_2 "https://go.microsoft.com/fwlink/?LinkId=691129"
End Sub



'ファイル名を先につけておいてURLDownloadToFileでダウンロードする場合
Private Sub DownloadFile_1(ByVal url As String)
    Dim fileName As String
    If (Not GetSaveFileName(fileName)) Then
        Exit Sub
    End If
    
    If URLDownloadToFile(0, url, fileName, 0, 0) <> 0 Then
        MsgBox "ダウンロードが失敗しました"
        Exit Sub
    Else
        
    End If
End Sub

'リダイレクトを追跡してファイル名を取得してからダウンロードする場合
Private Sub DownloadFile_2(ByVal url As String)
    Dim httpReq As New winhttp.WinHttpRequest 'Microsoft WinHTTP Servicesを参照する
    httpReq.Option(WinHttpRequestOption_EnableRedirects) = False 'リダイレクト無効に
    Do
        
        Call httpReq.Open("HEAD", url, False) 'HTTPヘッダだけをダウンロード
        httpReq.Send
        If (httpReq.Status = 302) Then 'リダイレクトの場合
            url = httpReq.GetResponseHeader("Location")
        End If
    Loop While httpReq.Status = 302
    

    If (httpReq.Status <> 200) Then
        MsgBox "ダウンロード失敗しました " & httpReq.Status
    Else
        httpReq.Option(WinHttpRequestOption_EnableRedirects) = True '不要だけどリダイレクト有効に
    
        Dim fileName As String
        Dim i As Integer
        i = InStrRev(url, "/")
        fileName = Mid(url, i + 1) 'URLからファイル名をとりだし
        
        If (Not GetSaveFileName(fileName)) Then
            Exit Sub
        End If
        
        Call httpReq.Open("GET", url, False) 'データを含めてダウンロード
        httpReq.Send
        Dim bs() As Byte
        bs = httpReq.ResponseBody

        Dim fileNumber As Integer
        fileNumber = FreeFile
        Open fileName For Binary Access Write As #fileNumber
        Put #fileNumber, , bs 'ファイルに保存
        Close #fileNumber
    End If
End Sub

Private Function GetSaveFileName(ByRef fileName As String) As Boolean
    'Microsoft Common Dialog Controlを参照してフォームに張り付けておく
    Me.CommonDialog1.fileName = fileName
    Me.CommonDialog1.Filter = "CSV|*.csv|*.*|*.*"
    If (Right(fileName, 4) = ".csv" Or fileName = "") Then
        Me.CommonDialog1.FilterIndex = 1
    Else
        Me.CommonDialog1.FilterIndex = 2
    End If
    On Error Resume Next
    Me.CommonDialog1.CancelError = True
    Me.CommonDialog1.ShowSave
    If (Err.Number = ErrorConstants.cdlCancel) Then
         GetSaveFileName = False
        Exit Function
    End If
    On Error GoTo 0
    fileName = Me.CommonDialog1.fileName
    GetSaveFileName = True
End Function

---

個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

Answer 2

お疲れ様です。

回答ありがとうございました。

質問を投げている間も試行錯誤して下記の様な感じで何とかリダイレクトURLからCSVファイルをダウンロードできました。

また何かありましたら宜しくお願い致します。

※ダウンロード処理部分のみ掲載

----------------------------------------------------------------------

Public Function URLDownloadFile(strHttpsURL As String, strHttpsFile As String, _
                            strLocalFile As String, strLogMessage As String) As Boolean
 
On Error GoTo ErrorHandler
 
    Dim hOpen As Long       'インターネットサービスのハンドル
    Dim hConnection As Long 'インターネットセッションのハンドル
    Dim result As Long
    Dim strUserID As String
    Dim strUserPasswd As String
    Dim strLogMsg As String
    Dim dlResult As Boolean
 
    hOpen = 0
    hConnection = 0
     
    strUserID = ""
    strUserPasswd = ""
    dlResult = False
   
    'インターネットサービスのハンドル取得 - hOpen
    hOpen = InternetOpen("HttpsDL", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
    If (hOpen <> 0) Then 'ハンドル取得成功
   
        'インターネットセッションのハンドル取得(Httpsサーバへ接続) - hConnection
        hConnection = InternetConnect(hOpen, strHttpsURL, INTERNET_INVALID_PORT_NUMBER, _
                                        strUserID, strUserPasswd, INTERNET_SERVICE_Https, 0, 0)
        If (hConnection <> 0) Then '接続成功
       
            'ファイルをダウンロード
            result = HttpsGetFile(hConnection, strHttpsFile, strLocalFile, False, _
                  FILE_ATTRIBUTE_NORMAL, Https_TRANSFER_TYPE_BINARY Or INTERNET_FLAG_RELOAD, 0)
            If (result = 0) Then 'ダウンロード失敗
       
                strLogMsg = "ファイルの取得に失敗しました。(" & Err.LastDllError & ")" & vbCrLf
                strLogMsg = strLogMsg & "ファイル名" & vbTab & strHttpsFile & vbCrLf
                Call LogEventWarning(strLogMsg & strLogMessage)
            Else 'ダウンロード成功
                dlResult = True
            End If
             
        Else '接続失敗
            strLogMsg = "Httpsサーバへ接続できませんでした。(" & Err.LastDllError & ")" & vbCrLf
            strLogMsg = strLogMsg & "サーバ名" & vbTab & strHttpsURL & vbCrLf
            Call LogEventWarning(strLogMsg & strLogMessage)
        End If
   
    Else 'ハンドル取得失敗
        strLogMsg = "Httpsサーバへ接続できませんでした。(" & Err.LastDllError & ")" & vbCrLf
        strLogMsg = strLogMsg & "サーバ名" & vbTab & strHttpsURL & vbCrLf
        Call LogEventWarning(strLogMsg & strLogMessage)
    End If
   
    'インターネットセッションを閉じる
    If (hConnection <> 0) Then InternetCloseHandle hConnection
   
    'インターネットサービスを閉じる
    If (hOpen <> 0) Then InternetCloseHandle hOpen
     
    URLDownloadFile = dlResult
   
    Exit Function

ErrorHandler:

    Dim strErrorMessage As String
    strErrorMessage = strErrorMessage & "[Err.Number = " & Err.Number & "]" & vbCrLf
    strErrorMessage = strErrorMessage & "[Err.Source = " & Err.Source & "]" & vbCrLf
    strErrorMessage = strErrorMessage & "[Err.Description = " & Err.Description & "]" & vbCrLf
   
    Call LogEventError(strErrorMessage & strLogMessage)

    URLDownloadFile = False

End Function

----------------------------------------------------------------------