Office関連

VBAでインターネット上のファイルをダウンロードする方法をまとめてみました。

VBA ファイル ダウンロード」といったキーワード検索でのアクセスがありました。

Office系のQ&Aサイトを見ても「VBAでインターネット上のファイルをダウンロードしたい!」という要望は多いようなので、今回色々な方法をまとめてみることにしました。

■ URLDownloadToFileを使ってファイルをダウンロードする方法

インターネット上でよく見かけるのがこの方法、API関数の「URLDownloadToFile」を使ってファイルをダウンロードする方法です。

Option Explicit

'※ 64ビット版Officeアプリケーションの場合は要修正
Private Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryW" ( _
        ByVal lpszUrlName As Long) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileW" ( _
        ByVal pCaller As Long, _
        ByVal szURL As Long, _
        ByVal szFileName As Long, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As Long) As Long

Public Sub Sample01()
  DownloadFile "http://ftp.vector.co.jp/pack/winnt/business/office/ankd200.zip", _
               "C:\Test\MyFile.zip"
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Sub DownloadFile(ByVal Url As String, ByVal SaveFilePath As String)
'URLDownloadToFileでファイルをダウンロード
'http://msdn.microsoft.com/en-us/library/aa383983.aspx
'http://msdn.microsoft.com/en-us/library/ms775123.aspx
'http://www.ken3.org/vba/backno/vba120.html 参考
  Dim ret As Long
  
  ret = 0 '初期化
  DeleteUrlCacheEntry StrPtr(Url) 'キャッシュクリア
  ret = URLDownloadToFile(0, StrPtr(Url), StrPtr(SaveFilePath), 0, 0)
  If ret <> 0 Then MsgBox "処理が失敗しました。", vbCritical + vbSystemModal
End Sub

DeleteUrlCacheEntry関数でキャッシュを削除した後、URLDownloadToFile関数で指定したファイルを指定した場所に保存するという、シンプルなものですね。説明も要らないくらいです。

ダウンロードしたいファイルのURLが分かっている場合には、この方法を使うのが簡単です。
ただし、64ビット版Officeアプリケーションで上記のコードを動かす際には、APIの宣言部分を64ビット用に修正する必要があります。

■ WinHttpRequest(XMLHTTPRequest) + ADODB.Streamを使ってファイルをダウンロードする方法

次はWinHttpRequest(XMLHTTPRequest)とADODB.Streamを使ってファイルをダウンロードする方法の紹介です。

Option Explicit

Public Sub Sample02()
  DownloadFile "http://ftp.vector.co.jp/pack/winnt/business/office/ankd200.zip", _
               "C:\Test\MyFile.zip"
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Sub DownloadFile(ByVal Url As String, ByVal SaveFilePath As String)
'WinHttpRequest/XMLHTTPRequest + ADODB.Streamでファイルをダウンロード
  Dim req As Object
  Const adTypeBinary = 1
  Const adSaveCreateOverWrite = 2
  
  Set req = Nothing '初期化
  Set req = CreateHttpRequest()
  If req Is Nothing Then Exit Sub
  req.Open "GET", Url, False
  
  'XMLHTTPRequestを考慮してキャッシュ対策
  'http://vird2002.s8.xrea.com/javascript/XMLHttpRequest.html#XMLHttpRequest_Cache-Control
  'http://www.atmarkit.co.jp/ait/articles/0305/10/news002.html 参考
  req.setRequestHeader "Pragma", "no-cache"
  req.setRequestHeader "Cache-Control", "no-cache"
  req.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
  
  req.Send
  Select Case req.Status
    Case 200
      With CreateObject("ADODB.Stream")
        .Type = adTypeBinary
        .Open
        .Write req.responseBody
        .SaveToFile SaveFilePath, adSaveCreateOverWrite
        .Close
      End With
    Case Else
      MsgBox "エラーが発生しました。" & vbCrLf & _
             "ステータスコード:" & req.Status, _
             vbCritical + vbSystemModal
      Exit Sub
  End Select
End Sub

Private Function CreateHttpRequest() As Object
'WinHttpRequest/XMLHTTPRequestオブジェクト作成
'http://www.f3.dion.ne.jp/~element/msaccess/AcTipsWinHTTP1.html 参考
  Dim progIDs As Variant
  Dim ret As Object
  Dim i As Long
  
  Set ret = Nothing '初期化
  progIDs = Array("WinHttp.WinHttpRequest.5.1", _
                  "WinHttp.WinHttpRequest.5", _
                  "WinHttp.WinHttpRequest", _
                  "Msxml2.ServerXMLHTTP.6.0", _
                  "Msxml2.ServerXMLHTTP.5.0", _
                  "Msxml2.ServerXMLHTTP.4.0", _
                  "Msxml2.ServerXMLHTTP.3.0", _
                  "Msxml2.ServerXMLHTTP", _
                  "Microsoft.ServerXMLHTTP", _
                  "Msxml2.XMLHTTP.6.0", _
                  "Msxml2.XMLHTTP.5.0", _
                  "Msxml2.XMLHTTP.4.0", _
                  "Msxml2.XMLHTTP.3.0", _
                  "Msxml2.XMLHTTP", _
                  "Microsoft.XMLHTTP")
  On Error Resume Next
  For i = LBound(progIDs) To UBound(progIDs)
    Set ret = CreateObject(progIDs(i))
    If Not ret Is Nothing Then Exit For
  Next
  On Error GoTo 0
  Set CreateHttpRequest = ret
End Function

大雑把に言えば、WinHttpRequest(XMLHTTPRequest)を使って指定したURLにリクエストを投げ、受け取ったバイナリ形式のレスポンスをADODB.Streamでローカルに保存する、というやり方です。

上記コードでは、“GET/POSTできればWinHttpRequest・XMLHTTPRequestのどちらでも良い!”ということで、CreateHttpRequestプロシージャーのような形でWinHttpRequest(XMLHTTPRequest)オブジェクトを作成していますが、通常は「CreateObject(“WinHttp.WinHttpRequest.5.1”)」で問題無いだろうと思います。

2つのオブジェクトの違いについては、YU-TANGさんのWebページ「WinHTTP ライブラリで Web スクレイピング(1)~ GET 編~」に詳しい説明が記載されているので、そちらをご参照ください。

■ Basic認証によるアクセス制限がかかったサイトのファイルをダウンロードする方法

次はBasic認証によるアクセス制限がかかったサイトのファイルをダウンロードする方法の紹介です。

会員制のサイト等を開こうとしたとき、下図のようにユーザー名とパスワードの入力を求められた経験のある人も多いだろうと思いますが、このタイプの認証で多いのがBasic認証です。

VBA_DownloadFile_01

Option Explicit

Public Sub Sample03()
  DownloadFileBasicAuth "http://htaccess.cman.jp/sample/basic/", _
                        "C:\Test\BasicAuth.html", _
                        "guest", _
                        "password"
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Sub DownloadFileBasicAuth(ByVal Url As String, _
                                  ByVal SaveFilePath As String, _
                                  ByVal UserName As String, _
                                  ByVal PassWord As String)
'WinHttpRequest/XMLHTTPRequest + ADODB.Streamでファイルをダウンロード
'http://ja.wikipedia.org/wiki/Basic%E8%AA%8D%E8%A8%BC 参考
  Dim req As Object
  Const adTypeBinary = 1
  Const adSaveCreateOverWrite = 2
  
  Set req = Nothing '初期化
  Set req = CreateHttpRequest()
  If req Is Nothing Then Exit Sub
  req.Open "GET", Url, False
  
  'Authorizationヘッダーでユーザー名とパスワード送信
  req.setRequestHeader "Authorization", "Basic " & EncodeBase64Str(UserName & ":" & PassWord)
  
  'XMLHTTPRequestを考慮してキャッシュ対策
  req.setRequestHeader "Pragma", "no-cache"
  req.setRequestHeader "Cache-Control", "no-cache"
  req.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
  
  req.Send
  Select Case req.Status
    Case 200
      With CreateObject("ADODB.Stream")
        .Type = adTypeBinary
        .Open
        .Write req.responseBody
        .SaveToFile SaveFilePath, adSaveCreateOverWrite
        .Close
      End With
    Case Else
      MsgBox "エラーが発生しました。" & vbCrLf & _
             "ステータスコード:" & req.Status, _
             vbCritical + vbSystemModal
      Exit Sub
  End Select
End Sub

Private Function CreateHttpRequest() As Object
'WinHttpRequest/XMLHTTPRequestオブジェクト作成
'http://www.f3.dion.ne.jp/~element/msaccess/AcTipsWinHTTP1.html 参考
  Dim progIDs As Variant
  Dim ret As Object
  Dim i As Long
  
  Set ret = Nothing '初期化
  progIDs = Array("WinHttp.WinHttpRequest.5.1", _
                  "WinHttp.WinHttpRequest.5", _
                  "WinHttp.WinHttpRequest", _
                  "Msxml2.ServerXMLHTTP.6.0", _
                  "Msxml2.ServerXMLHTTP.5.0", _
                  "Msxml2.ServerXMLHTTP.4.0", _
                  "Msxml2.ServerXMLHTTP.3.0", _
                  "Msxml2.ServerXMLHTTP", _
                  "Microsoft.ServerXMLHTTP", _
                  "Msxml2.XMLHTTP.6.0", _
                  "Msxml2.XMLHTTP.5.0", _
                  "Msxml2.XMLHTTP.4.0", _
                  "Msxml2.XMLHTTP.3.0", _
                  "Msxml2.XMLHTTP", _
                  "Microsoft.XMLHTTP")
  On Error Resume Next
  For i = LBound(progIDs) To UBound(progIDs)
    Set ret = CreateObject(progIDs(i))
    If Not ret Is Nothing Then Exit For
  Next
  On Error GoTo 0
  Set CreateHttpRequest = ret
End Function

Private Function EncodeBase64Str(ByVal str As String) As String
'文字列をBase64エンコード
  Dim ret As String
  Dim d() As Byte
  
  Const adTypeBinary = 1
  Const adTypeText = 2
  
  ret = "" '初期化
  On Error Resume Next
  With CreateObject("ADODB.Stream")
    .Open
    .Type = adTypeText
    .Charset = "UTF-8"
    .WriteText str
    .Position = 0
    .Type = adTypeBinary
    .Position = 3
    d = .Read()
    .Close
  End With
  With CreateObject("MSXML2.DOMDocument").createElement("base64")
    .DataType = "bin.base64"
    .nodeTypedValue = d
    ret = .Text
  End With
  On Error GoTo 0
  EncodeBase64Str = ret
End Function

仕組みとしては、Authorizationヘッダーでユーザー名とパスワードを付けてリクエストを投げ、認証に成功したらファイルをダウンロードする、というやり方です。

Wikipediaの記事にも書いてある通り、Basic認証ではユーザー名とパスワードをBase64エンコードする必要があるため、そのための関数「EncodeBase64Str」を用意しています。

■ フォーム認証によるアクセス制限がかかったサイトのファイルをダウンロードする方法

次は、下図のようにWebページ上でユーザー名やパスワードを入力してログインするのが必要なサイト(フォーム認証とします)からファイルをダウンロードする方法を紹介します。

VBA_DownloadFile_02

ここでは、下記のようにごく簡単な構成のテスト環境を用意してみました。
.htaccessでファイルの直アクセスを禁止し、auth.phpで認証に成功しないとsample.pdfファイルがダウンロードできないような仕組みです。

localhost/auth
  1. login.html ログインページ
  2. auth.php 認証用ページ
  3. down.php ファイルダウンロード用ページ
  /files
       4. .htaccess アクセス制限用ファイル
       5. sample.pdf ダウンロードしたいファイル

※ 下記コードはあくまでもテスト用に書いた簡易的な認証のコードです。実際のサイトには使用しないでください。

1. login.html

<!DOCTYPE html>
<html>
  <head>
    <meta charset="UTF-8">
    <title>認証サンプル</title>
  </head>
  <body>
    <form method="post" action="auth.php">
      <table>
        <tr>
          <td>ユーザー名:</td>
          <td><input name="username" type="text" size="30"></td>
        </tr>
        <tr>
          <td>パスワード:</td>
          <td><input name="password" type="text" size="30"></td>
        </tr>
        <tr>
          <td colspan="2"><input type="submit" value="ログイン"></td>
        </tr>
      </table>
    </form>
  </body>
</html>

2. auth.php

<?php
  define("PW", "pass"); //パスワード
  define("UN", "user"); //ユーザー名
  if(isset($_POST["password"]) && isset($_POST["username"])) {
    if($_POST["password"]===PW && $_POST["username"]===UN){
      session_start();
      $_SESSION["password"] = md5(PW);
      $_SESSION["username"] = md5(UN);
      print "<!DOCTYPE html>\n";
      print "<html>\n";
      print "  <head>\n";
      print "    <meta charset=\"UTF-8\">\n";
      print "    <title>認証確認</title>\n";
      print "  </head>\n";
      print "  <body>\n";
      print '    <a href="./down.php">ファイルのダウンロード</a>' . "\n";
      print "  </body>\n";
      print "</html>";
    }else{
      http_response_code(401);
    }
  }else{
    http_response_code(403);
  }
?>

3. down.php

<?php
  define("PW", "pass"); //パスワード
  define("UN", "user"); //ユーザー名
  session_start();
  if(isset($_SESSION["password"]) && isset($_SESSION["username"])) {
    if($_SESSION["password"]===md5(PW) && $_SESSION["username"]===md5(UN)){
      $file="./files/sample.pdf";
      header("Content-Type: application/octet-stream");
      header("Content-Disposition: attachment; filename=sample.pdf");
      header("Content-Length: " . filesize($file));
      readfile($file);
    }else{
      http_response_code(401);
    }
  }else{
    http_response_code(403);
  }
  session_destroy();
?>

4. .htaccess

<Files ~ "\.(dat|log|csv|pdf)$">
  deny from all
</Files>

上記テスト環境でファイルをダウンロードするためのVBAコードは下記のようになります。

Option Explicit

Public Sub Sample04()
  Dim req As Object
  Dim dat As Variant
  
  Const UserName = "user" 'ユーザー名
  Const PassWord = "pass" 'パスワード
  Const AuthUrl = "http://localhost/auth/auth.php" '認証ページのURL
  Const FileUrl = "http://localhost/auth/down.php" 'ダウンロード対象のURL
  Const SaveFilePath = "C:\Test\MyFile.pdf"
  
  Const adTypeBinary = 1
  Const adSaveCreateOverWrite = 2
  
  Set req = Nothing '初期化
  Set req = CreateHttpRequest()
  If req Is Nothing Then Exit Sub
  
  '認証
  req.Open "POST", AuthUrl, False
  dat = "username=" & UserName & "&password=" & PassWord 'パラメーター設定
  req.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  req.Send dat
  If req.Status <> 200 Then
    MsgBox "認証に失敗しました。" & vbCrLf & _
           "処理を中止します。", vbCritical + vbSystemModal
    Exit Sub
  End If
  
  'ファイルのダウンロード
  req.Open "GET", FileUrl, False
  'XMLHTTPRequestを考慮してキャッシュ対策
  req.setRequestHeader "Pragma", "no-cache"
  req.setRequestHeader "Cache-Control", "no-cache"
  req.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
  req.Send
  Select Case req.Status
    Case 200
      With CreateObject("ADODB.Stream")
        .Type = adTypeBinary
        .Open
        .Write req.responseBody
        .SaveToFile SaveFilePath, adSaveCreateOverWrite
        .Close
      End With
    Case Else
      MsgBox "エラーが発生しました。" & vbCrLf & _
             "ステータスコード:" & req.Status, _
             vbCritical + vbSystemModal
      Exit Sub
  End Select
  
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Function CreateHttpRequest() As Object
'WinHttpRequest/XMLHTTPRequestオブジェクト作成
'http://www.f3.dion.ne.jp/~element/msaccess/AcTipsWinHTTP1.html 参考
  Dim progIDs As Variant
  Dim ret As Object
  Dim i As Long
  
  Set ret = Nothing '初期化
  progIDs = Array("WinHttp.WinHttpRequest.5.1", _
                  "WinHttp.WinHttpRequest.5", _
                  "WinHttp.WinHttpRequest", _
                  "Msxml2.ServerXMLHTTP.6.0", _
                  "Msxml2.ServerXMLHTTP.5.0", _
                  "Msxml2.ServerXMLHTTP.4.0", _
                  "Msxml2.ServerXMLHTTP.3.0", _
                  "Msxml2.ServerXMLHTTP", _
                  "Microsoft.ServerXMLHTTP", _
                  "Msxml2.XMLHTTP.6.0", _
                  "Msxml2.XMLHTTP.5.0", _
                  "Msxml2.XMLHTTP.4.0", _
                  "Msxml2.XMLHTTP.3.0", _
                  "Msxml2.XMLHTTP", _
                  "Microsoft.XMLHTTP")
  On Error Resume Next
  For i = LBound(progIDs) To UBound(progIDs)
    Set ret = CreateObject(progIDs(i))
    If Not ret Is Nothing Then Exit For
  Next
  On Error GoTo 0
  Set CreateHttpRequest = ret
End Function

ユーザー名やパスワードといったパラメータ(上記コードではdat)を送信し、認証を通過してからファイルのダウンロードを行うやり方です。
(認証のやり方は色々あるので、必ずしも上記コードの方法が使えるわけではありません。)

このとき送信するパラメーターについては、Internet Explorerの開発者ツール(下図はInternet Explorer 9)を使って、実際にログインしたときの挙動をキャプチャーすることで確認できます。

VBA_DownloadFile_03

VBA_DownloadFile_04

VBA_DownloadFile_05

Firefoxの「Live HTTP Headers」アドオンや「Fiddler」といったツールを使っても、POSTした内容を確認することができます。
(特にFiddlerはWeb解析においてとても便利です。)

■ 通知バーを操作してファイルをダウンロードする方法

最後に紹介するのが、ファイルをダウンロードしようとしたときに表示されるInternet Explorerの通知バーを操作してファイルをダウンロードする方法です。

ただし、この方法はOSやInternet Explorerのバージョンによっては動作しなくなる場合があり、環境に大きく依存するため、私としては正直お薦めしません。

※ UIAutomationClient参照時にエラーが発生する場合は「UIAutomationClient参照時にDLL読み込みエラーが発生した時の対処法」参照

Option Explicit

'※ 64ビット版Officeアプリケーションの場合は要修正
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
        ByVal hWndParent As Long, _
        ByVal hWndChildAfter As Long, _
        ByVal lpszClass As String, _
        ByVal lpszWindow As String) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Sub Sample05()
  Dim elmAnc As Object
  Const READYSTATE_COMPLETE = 4
  
  With CreateObject("InternetExplorer.Application")
    .Visible = True
    .Navigate "http://www.e-stat.go.jp/SG1/estat/List.do?bid=000001034991"
    While .Busy Or .ReadyState <> READYSTATE_COMPLETE
      DoEvents
    Wend
    
    On Error Resume Next
    For Each elmAnc In .document.getElementsByTagName("a")
      Select Case elmAnc.getAttribute("tabindex")
        Case 102
          elmAnc.Click '適当なリンクをクリック → ダウンロード通知バー表示
          Exit For
      End Select
    Next
    On Error GoTo 0
    
    DownloadFileNB .Hwnd, "C:\Test\MyFile.csv"
    .Quit
  End With
  
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Sub DownloadFileNB(ByVal hIE As Long, ByVal SaveFilePath As String)
'通知バーを操作してファイルをダウンロード
'※ UIAutomationClient(%SYSTEMROOT%\system32\UIAutomationCore.dll)要参照
' - hIE:InternetExplorerのハンドル
' - SaveFilePath:ファイルのダウンロード先
'
'http://okwave.jp/qa/q8121989.html
'http://okwave.jp/qa/q8320348.html
'https://gist.github.com/kumatti1/7957796 参考

  Dim uiAuto As UIAutomationClient.CUIAutomation
  Dim elmFNB As UIAutomationClient.IUIAutomationElement 'Frame Notification Bar
  Dim elmDropDown As UIAutomationClient.IUIAutomationElement
  Dim elmPopupMenu As UIAutomationClient.IUIAutomationElement
  Dim elmSaveAsButton As UIAutomationClient.IUIAutomationElement
  Dim elmSaveAsDialog As UIAutomationClient.IUIAutomationElement
  Dim elmSaveButton As UIAutomationClient.IUIAutomationElement
  Dim elmFileName As UIAutomationClient.IUIAutomationElement
  Dim elmNBT As UIAutomationClient.IUIAutomationElement 'Notification Bar Text
  Dim elmCloseButton As UIAutomationClient.IUIAutomationElement
  Dim cndDropDownRole As UIAutomationClient.IUIAutomationCondition
  Dim cndSaveAsButtonAK As UIAutomationClient.IUIAutomationCondition
  Dim cndButtonControl As UIAutomationClient.IUIAutomationCondition
  Dim cndEditControl As UIAutomationClient.IUIAutomationCondition
  Dim cndNBTName As UIAutomationClient.IUIAutomationCondition
  Dim cndButtonName As UIAutomationClient.IUIAutomationCondition
  Dim aryButtonControl As UIAutomationClient.IUIAutomationElementArray
  Dim aryEditControl As UIAutomationClient.IUIAutomationElementArray
  Dim ptnAccDropDown As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern
  Dim ptnAccSaveAsButton As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern
  Dim ptnAccSaveButton As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern
  Dim ptnAccCloseButton As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern
  Dim ptnValFileName As UIAutomationClient.IUIAutomationValuePattern
  Dim hFNB As Long
  Dim hPopupMenu As Long
  Dim hSaveAsDialog As Long
  Dim i As Long, j As Long
  Const ROLE_SYSTEM_BUTTONDROPDOWN = &H38&
  
  '初期化
  hFNB = 0: hPopupMenu = 0: hSaveAsDialog = 0
  Set elmSaveButton = Nothing: Set elmFileName = Nothing
  Set uiAuto = New UIAutomationClient.CUIAutomation
  
  'ファイルを事前に削除
  With CreateObject("Scripting.FileSystemObject")
    If .FileExists(SaveFilePath) Then .DeleteFile SaveFilePath, True
  End With
  
  '[通知バー]取得
  Do
    hFNB = FindWindowEx(hIE, 0, "Frame Notification Bar", vbNullString)
    DoEvents
  Loop Until hFNB <> 0
  Set elmFNB = uiAuto.ElementFromHandle(ByVal hFNB)
  
  Sleep 1000 '[保存]ドロップダウンを押せるようになるまで待ち(要改善)
  
  '[保存]ドロップダウン押下
  Set cndDropDownRole = uiAuto.CreatePropertyCondition(UIA_LegacyIAccessibleRolePropertyId, ROLE_SYSTEM_BUTTONDROPDOWN) 'ドロップ ダウン ボタン
  Set elmDropDown = elmFNB.FindFirst(TreeScope_Subtree, cndDropDownRole)
  Set ptnAccDropDown = elmDropDown.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
  ptnAccDropDown.DoDefaultAction
  Do
    hPopupMenu = FindWindowEx(0, 0, "#32768", vbNullString)
    DoEvents
  Loop Until hPopupMenu <> 0
  
  '[名前を付けて保存(A)]ボタン押下
  Set elmPopupMenu = uiAuto.ElementFromHandle(ByVal hPopupMenu)
  Set cndSaveAsButtonAK = uiAuto.CreatePropertyCondition(UIA_AccessKeyPropertyId, "a")
  Set elmSaveAsButton = elmPopupMenu.FindFirst(TreeScope_Subtree, cndSaveAsButtonAK)
  Set ptnAccSaveAsButton = elmSaveAsButton.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
  ptnAccSaveAsButton.DoDefaultAction
  Do
    hSaveAsDialog = FindWindowEx(0, 0, "#32770", "名前を付けて保存")
    DoEvents
  Loop Until hSaveAsDialog <> 0
  
  '[名前を付けて保存]ダイアログ操作
  Set elmSaveAsDialog = uiAuto.ElementFromHandle(ByVal hSaveAsDialog)
  '[保存(S)ボタン]取得
  Set cndButtonControl = uiAuto.CreatePropertyCondition(UIA_ControlTypePropertyId, UIA_ButtonControlTypeId)
  Do
    Set aryButtonControl = elmSaveAsDialog.FindAll(TreeScope_Subtree, cndButtonControl)
    DoEvents
  Loop Until aryButtonControl.Length > 1
  For i = 0 To aryButtonControl.Length - 1
    If LCase(aryButtonControl.GetElement(i).CurrentAccessKey) = "alt+s" Then
      Set elmSaveButton = aryButtonControl.GetElement(i)
      Exit For
    End If
  Next
  If elmSaveButton Is Nothing Then Exit Sub
  '[ファイル名:]取得
  Set cndEditControl = uiAuto.CreatePropertyCondition(UIA_ControlTypePropertyId, UIA_EditControlTypeId)
  Do
    Set aryEditControl = elmSaveAsDialog.FindAll(TreeScope_Subtree, cndEditControl)
    DoEvents
  Loop Until aryEditControl.Length > 1
  For j = 0 To aryEditControl.Length - 1
    If LCase(aryEditControl.GetElement(j).CurrentAccessKey) = "alt+n" Then
      Set elmFileName = aryEditControl.GetElement(j)
      Exit For
    End If
  Next
  If elmFileName Is Nothing Then Exit Sub
  
  'ファイルパス設定
  Set ptnValFileName = elmFileName.GetCurrentPattern(UIA_ValuePatternId)
  ptnValFileName.SetValue SaveFilePath
  
  '保存(S)ボタン押下
  Set ptnAccSaveButton = elmSaveButton.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
  ptnAccSaveButton.DoDefaultAction
  
  'ダウンロード完了待ち
  Set cndNBTName = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "通知バーのテキスト")
  Set elmNBT = elmFNB.FindFirst(TreeScope_Subtree, cndNBTName)
  Do
    DoEvents
  Loop Until InStr(elmNBT.GetCurrentPropertyValue(UIA_ValueValuePropertyId), "ダウンロードが完了しました") > 0
  
  '閉じるボタン押下
  Set cndButtonName = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "閉じる")
  Set elmCloseButton = elmFNB.FindFirst(TreeScope_Subtree, cndButtonName)
  Set ptnAccCloseButton = elmCloseButton.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
  ptnAccCloseButton.DoDefaultAction
End Sub

上記の通り、とても冗長でややこしいですね・・・。
一応Windows 7 + InternetExplorer 9、Windows 7 + InternetExplorer 11、Windows 8.1 + InternetExplorer 11で動作確認はしましたが、動作の保証はできません。

また、上記コードはループで止まったときのことも考慮していませんので、実際にコードを動かす際には、一定時間ループで引っ掛かったら処理を抜ける、というようなコードも追加しておいた方が良いでしょう。

一応通知バーも操作できる!ということで、あくまでも最終手段として頭の隅にでも置いておいていただければ…、というようなコードです。

繰り返しになりますが、この方法はお薦めしません。できれば、URLDownloadToFileやWinHttpRequest(XMLHTTPRequest) + ADODB.Streamを使ってファイルをダウンロードすることをお薦めします。

2014/09/27 追記:
kumattiさんから下記情報をいただきました。
64ビット環境でコードが上手く動作しない場合はお試しください。

2015/10/14 追記:
UI Automationを使うコードを一部修正しました。
動作確認:Windows 10 x86 + Office 2016 x86 + Internet Explorer 11

Option Explicit

#If Win64 Then
  Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
  Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Public Sub Sample06()
  Dim elmAnc As Object
  Const READYSTATE_COMPLETE = 4
  
  With CreateObject("InternetExplorer.Application")
    .Visible = True
    .Navigate "https://www.java.com/ja/download/manual.jsp"
    While .Busy Or .ReadyState <> READYSTATE_COMPLETE
      DoEvents
    Wend
    On Error Resume Next
    For Each elmAnc In .document.getElementsByTagName("a")
      If elmAnc.getAttribute("title") = "Javaソフトウェアのダウンロード対象: Windows オフライン" Then
        elmAnc.Click '適当なリンクをクリック -> ダウンロード通知バー表示
        Exit For
      End If
    Next
    On Error GoTo 0
    DownloadFileNB .Hwnd, "C:\Test\jre-8u60-windows-i586.exe"
    .Quit
  End With
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Sub DownloadFileNB(ByVal hIE As Long, ByVal SaveFilePath As String)
'通知バーを操作してファイルをダウンロード
'※ UIAutomationClient(%SYSTEMROOT%\system32\UIAutomationCore.dll)要参照
' - hIE:InternetExplorerのハンドル
' - SaveFilePath:ファイルのダウンロード先

  Dim uiAuto As UIAutomationClient.CUIAutomation
  Dim elmRoot As UIAutomationClient.IUIAutomationElement
  Dim elmIE As UIAutomationClient.IUIAutomationElement
  Dim elmNotificationBar As UIAutomationClient.IUIAutomationElement
  Dim elmSplitButton As UIAutomationClient.IUIAutomationElement
  Dim elmMenuControl As UIAutomationClient.IUIAutomationElement
  Dim elmMenuItem As UIAutomationClient.IUIAutomationElement
  Dim elmSaveAsDialog As UIAutomationClient.IUIAutomationElement
  Dim elmSaveButton As UIAutomationClient.IUIAutomationElement
  Dim elmFileName As UIAutomationClient.IUIAutomationElement
  Dim elmTextControl As UIAutomationClient.IUIAutomationElement
  Dim elmCloseButton As UIAutomationClient.IUIAutomationElement
  Dim cndNotificationBar As UIAutomationClient.IUIAutomationCondition
  Dim cndSplitButton As UIAutomationClient.IUIAutomationCondition
  Dim cndSplitButtonLCT As UIAutomationClient.IUIAutomationCondition
  Dim cndSplitButtonLIR As UIAutomationClient.IUIAutomationCondition
  Dim cndMenuControl As UIAutomationClient.IUIAutomationCondition
  Dim cndMenuItem As UIAutomationClient.IUIAutomationCondition
  Dim cndSaveAsDialog As UIAutomationClient.IUIAutomationCondition
  Dim cndSaveAsDialogN As UIAutomationClient.IUIAutomationCondition
  Dim cndSaveAsDialogCN As UIAutomationClient.IUIAutomationCondition
  Dim cndFileName As UIAutomationClient.IUIAutomationCondition
  Dim cndFileNameN As UIAutomationClient.IUIAutomationCondition
  Dim cndFileNameCT As UIAutomationClient.IUIAutomationCondition
  Dim cndSaveButton As UIAutomationClient.IUIAutomationCondition
  Dim cndSaveButtonN As UIAutomationClient.IUIAutomationCondition
  Dim cndSaveButtonCT As UIAutomationClient.IUIAutomationCondition
  Dim cndTextControl As UIAutomationClient.IUIAutomationCondition
  Dim cndCloseButton As UIAutomationClient.IUIAutomationCondition
  Dim iptnSplitButton As UIAutomationClient.IUIAutomationInvokePattern
  Dim iptnMenuItem As UIAutomationClient.IUIAutomationInvokePattern
  Dim iptnSaveButton As UIAutomationClient.IUIAutomationInvokePattern
  Dim iptnCloseButton As UIAutomationClient.IUIAutomationInvokePattern
  Dim vptnFileName As UIAutomationClient.IUIAutomationValuePattern
  Const ROLE_SYSTEM_BUTTONDROPDOWN = &H38&
  
  Set uiAuto = New UIAutomationClient.CUIAutomation
  Set elmRoot = uiAuto.GetRootElement
  Set elmIE = uiAuto.ElementFromHandle(ByVal hIE)
  
  'ファイルを事前に削除
  With CreateObject("Scripting.FileSystemObject")
    If .FileExists(SaveFilePath) Then .DeleteFile SaveFilePath, True
  End With
  
  '[通知バー]取得
  Set cndNotificationBar = uiAuto.CreatePropertyCondition(UIA_AutomationIdPropertyId, "IENotificationBar")
  While elmNotificationBar Is Nothing
    Set elmNotificationBar = elmIE.FindFirst(TreeScope_Subtree, cndNotificationBar)
    DoEvents
  Wend
  
  '[保存]ドロップダウン押下 -> [名前を付けて保存(A)]ボタン押下
  Set cndSplitButtonLCT = uiAuto.CreatePropertyCondition(UIA_LocalizedControlTypePropertyId, "ボタンの分割")
  Set cndSplitButtonLIR = uiAuto.CreatePropertyCondition(UIA_LegacyIAccessibleRolePropertyId, ROLE_SYSTEM_BUTTONDROPDOWN)
  Set cndSplitButton = uiAuto.CreateAndCondition(cndSplitButtonLCT, cndSplitButtonLIR)
  Set cndMenuControl = uiAuto.CreatePropertyCondition(UIA_ControlTypePropertyId, UIA_MenuControlTypeId)
  Set cndMenuItem = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "名前を付けて保存(A)")
  Set elmSplitButton = elmNotificationBar.FindFirst(TreeScope_Subtree, cndSplitButton)
  Set iptnSplitButton = elmSplitButton.GetCurrentPattern(UIA_InvokePatternId)
  While elmMenuItem Is Nothing '[保存]メニューが表示されるまでInvoke
    Sleep 200
    iptnSplitButton.Invoke
    Set elmMenuControl = elmRoot.FindFirst(TreeScope_Subtree, cndMenuControl)
    If Not elmMenuControl Is Nothing Then
      Set elmMenuItem = elmMenuControl.FindFirst(TreeScope_Subtree, cndMenuItem)
    End If
  Wend
  Set iptnMenuItem = elmMenuItem.GetCurrentPattern(UIA_InvokePatternId)
  iptnMenuItem.Invoke
  
  '[名前を付けて保存]ダイアログ取得
  Set cndSaveAsDialogN = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "名前を付けて保存")
  Set cndSaveAsDialogCN = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "#32770")
  Set cndSaveAsDialog = uiAuto.CreateAndCondition(cndSaveAsDialogN, cndSaveAsDialogCN)
  While elmSaveAsDialog Is Nothing
    Set elmSaveAsDialog = elmRoot.FindFirst(TreeScope_Subtree, cndSaveAsDialog)
    DoEvents
  Wend
  
  'ファイルパス設定
  Set cndFileNameN = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "ファイル名:")
  Set cndFileNameCT = uiAuto.CreatePropertyCondition(UIA_ControlTypePropertyId, UIA_EditControlTypeId)
  Set cndFileName = uiAuto.CreateAndCondition(cndFileNameN, cndFileNameCT)
  Set elmFileName = elmSaveAsDialog.FindFirst(TreeScope_Subtree, cndFileName)
  Set vptnFileName = elmFileName.GetCurrentPattern(UIA_ValuePatternId)
  vptnFileName.SetValue SaveFilePath
  
  '[保存(S)ボタン]押下
  Set cndSaveButtonN = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "保存(S)")
  Set cndSaveButtonCT = uiAuto.CreatePropertyCondition(UIA_ControlTypePropertyId, UIA_ButtonControlTypeId)
  Set cndSaveButton = uiAuto.CreateAndCondition(cndSaveButtonN, cndSaveButtonCT)
  Set elmSaveButton = elmSaveAsDialog.FindFirst(TreeScope_Subtree, cndSaveButton)
  Set iptnSaveButton = elmSaveButton.GetCurrentPattern(UIA_InvokePatternId)
  iptnSaveButton.Invoke
  
  'ダウンロード完了待ち
  Set cndTextControl = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "通知バーのテキスト")
  Set cndCloseButton = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "閉じる")
  While Not elmNotificationBar Is Nothing
    Set elmTextControl = elmNotificationBar.FindFirst(TreeScope_Subtree, cndTextControl)
    If Not elmTextControl Is Nothing Then
      If InStr(elmTextControl.GetCurrentPropertyValue(UIA_ValueValuePropertyId), "ダウンロードが完了しました") > 0 Then
        Set elmCloseButton = elmNotificationBar.FindFirst(TreeScope_Subtree, cndCloseButton)
        If Not elmCloseButton Is Nothing Then
          Set iptnCloseButton = elmCloseButton.GetCurrentPattern(UIA_InvokePatternId)
          iptnCloseButton.Invoke
        End If
      End If
    End If
    Set elmNotificationBar = elmIE.FindFirst(TreeScope_Subtree, cndNotificationBar)
    DoEvents
  Wend
End Sub

・・・といったわけで、今回はVBAでインターネット上のファイルをダウンロードする色々な方法をまとめてみました。

ファイルのダウンロードに限らずVBAからWebページを操作する場合、開発者ツールやFiddlerを使って通信内容を確認する、Webページのソースを確認する、といったことは基本中の基本とも言え、どうしても必要になってきます。

ファイルのダウンロード処理で躓いたときは、まずは対象となるサイトをよく見てみることをお薦めします。

関連記事

  1. Office関連

    Office 2007のサポートが2017年10月10日に終了します。

    2007年1月にパッケージ版が発売されてから早10年、長らく活躍してき…

  2. Office アドイン

    [Officeアドイン]マニフェストファイルをデバッグする方法

    Office アドイン本体はF12ツール等を使ってデバッグすることがで…

  3. Office関連

    コントロールID 一覧(Office 2013)

    2013/03/25 追記:Office 2013のコントロールI…

  4. Office関連

    「図のリセット」を実行するExcelマクロ

    Msdn フォーラムに「Excel2010-VBA 画像「図の書式設定…

  5. Office アドイン

    [Officeアドイン]アドイン コマンド(Add-In Commands)の紹介(2)

    昨年末に書いた記事で「アドイン コマンド」を紹介しているのですが、知ら…

  6. Office関連

    PDFを分割するVBAマクロ

    「VBA PDF 分割」といったキーワード検索でのアクセスがありました…

コメント

    • 匿名
    • 2017年 6月 28日

    はじめまして。
    VBAでCSVファイルをDLしたいと考えていますが、ページ上にプルダウンメニューが2個あり必須選択
    期間入力ボックスがありここも必須入力
    それらを選択したうえでCSVファイルがDLできるサイトで名前を付けて保存の動作をVBAでさせたいです。
    【やりたいこと】
    1.IEの名前を付けて保存を実行させたい。
    2.DLするのはcsvファイルのみ。
    3.デスクトップに「データ」というフォルダを自動で作成させそのフォルダー内に保存をしたい
    ※同じ名前があった場合は任意にフォルダ名に付け足す。
    4.csvファイルの名前はsheet1のA3セルに記載された名前に書き換え保存を行う。

    よろしくお願いします。

  1. この記事へのトラックバックはありません。

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP