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

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

• URLDownloadToFileを使ってファイルをダウンロードする方法
• WinHttpRequest(XMLHTTPRequest) + ADODB.Streamを使ってファイルをダウンロードする方法
• Basic認証によるアクセス制限がかかったサイトのファイルをダウンロードする方法
• フォーム認証によるアクセス制限がかかったサイトのファイルをダウンロードする方法
• 通知バーを操作してファイルをダウンロードする方法

■ 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認証です。

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ページ上でユーザー名やパスワードを入力してログインするのが必要なサイト(フォーム認証とします)からファイルをダウンロードする方法を紹介します。



ここでは、下記のようにごく簡単な構成のテスト環境を用意してみました。
.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)を使って、実際にログインしたときの挙動をキャプチャーすることで確認できます。







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ビット環境でコードが上手く動作しない場合はお試しください。

@kinuasa ども。そう言えばダウンロード用のコードを纏めたページでUI Automationのサンプルは 64BitのVBAで確認しましたが、IsZoomed APIで判定してShowWindowでIE最大化しないと 通知バーのオブジェクトを取得出来ませんでした。 #感想

— kumatti (@kumatti1) 2014, 9月 26

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

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

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