URLDownloadToFile APIを使用してダウンロードしてみた

メルマガ発行内容

＜URLDownloadToFile APIを使用してダウンロードしてみた＞
今回は、
Web上のpdfファイルをダウンロードしてみたいと質問をもらったので、
チャレンジしてみます。

サンプルファイルは、
http://www.ken3.org/vba/lzh/vba120.lzh
にvba120.xlsが保存されています。

/*
 * １. 今回のキッカケ
*/

掲示板に下記の質問をもらいました。
-----
 >以前のものでExcelからIeを立ち上げて、ユーザー名、パスワードを
 >入力して開くということが書かれていました。また、リンク先を拾うと
 >言う処理も書かれていました。さて、ここからなんですが、リンク先に
 >設定されているPDFファイルを特定のフォルダへ保存するという処理は
 >どうやったらいいのでしょうか？
-----

リンク先を保存かぁ、あるよね、そんな処理。

/*
 * ２．保存方法を探る
*/

Webで保存方法を探るが、なかなか、ヒットしない。
みなさん、ダイアログにSendKeysしたりとイロイロ苦労しているみたいです。

しかたないので、マイクロソフトのページをみてみる。

使えそうな？
URLDownloadToFile？ってヤツが載ってました。
日本語のサポートかと思ったら、ヘッダ部分だけ日本語？
こんなのアリなの？
なんて、文句は置いといて、下記のURLに情報載ってます。

http://support.microsoft.com/support/kb/articles/q244/7/57.asp

The WebBrowser control and Internet Explorer have Save and Save As options 
that can be used to save files using the ExecWB command. However, 
this involves prompting from the user. 
There is no way to suppress this prompt. 
To save files to the hard-disk without prompting, 
use the URLDownloadToFile API from URLMON. 

MORE INFORMATION

The declaration for URLDownloadToFile is as follows: 

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

The function can be called as follows: 

returnValue = URLDownloadToFile(0, "http://www.microsoft.com/ms.htm" _
"c:\ms.htm", 0, 0)
				
Note that when downloading HTML files, 
embedded content like images and objects will not be downloaded. 

/*
 * ３．単体でテストを行う
*/

URLDownloadToFile って API が URLMON ってところにあるらしい。
APIの宣言文はそのままコピーして、下記のように使ってみた。

'URLDownloadToFile API from URLMON.
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

Sub aaa()

    Const strURL = "http://www.ken3.org/index.html"
    Dim strFNAME As String  'ダウンロード先（パス＋ファイル名）
    Dim returnValue

    'ファイル名をブックのパス＋test.htmlとする
    strFNAME = ThisWorkbook.Path & "\test.html"

    'URLDownloadToFile API をコールする
    returnValue = URLDownloadToFile(0, strURL, strFNAME, 0, 0)

    '結果の表示
    MsgBox "結果は：" & returnValue
    MsgBox strFNAME & "に保存されました"
End Sub

ポイントは
^^^^^^^^^^
特に無く、マイクロソフトのサンプルの変数を変えただけです。（オイオイ）
http://www.ken3.org/index.html
を
ThisWorkbook.Path & "\test.html"とブックと同じ位置のtest.htmlに保存しました。

実行すると、おっ、できてますね。
一安心したところで、pdfファイルをダウンロードしてみます。

IODATAのカタログページから１つテストで落としてみます。
なんて書いてるけど、ＵＲＬとファイル名が違うだけで同じプログラムです。

Sub bbb()
    'IODATAのカタログをダウンロードしてみた
    Const strURL = "http://www.iodata.co.jp/products/pdf/20030809/memory_n-s-p.pdf"
    Dim strFNAME As String  'ダウンロード先（パス＋ファイル名）
    Dim returnValue

    'ファイル名をブックのパス＋test.pdfとする
    strFNAME = ThisWorkbook.Path & "\test.pdf"

    'URLDownloadToFile API をコールする
    returnValue = URLDownloadToFile(0, strURL, strFNAME, 0, 0)

    '結果の表示
    MsgBox "結果は：" & returnValue
    MsgBox strFNAME & "に保存されました"

End Sub

無事にＰＤＦファイルも、
URLDownloadToFile API で落とせました。

ただ、気になったのは、
^^^^^^^^^^^^^^^^^^^^^^
処理中砂時計のまんまなので、大きいファイルをダウンロードする時、
固まった（止まっている）イメージを受けてしまう。
ＩＥのダウンロードだとバーが出たり、残り時間が表示されるけど、
男は黙って仕事する・・・じゃないけど、無言で処理が走っている・・・

メッセージとか、一工夫必要かなぁ・・・と思いました。

あと、２回目のダウンロードが早過ぎる。
^^^^^^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
これは、キャッシュから取ってきているんだろうけど、
毎回変わるファイルの時は、少し不安かなぁ
（古いデータを取得する可能性がある？）

/*
 * ４．リンクオブジェクトからリンク先を見て、保存する
*/

さてと、単体テストが終了したので、
PDFファイルを取り出してみますか。
※ＰＤＦと思ったけど、ＰＤＦファイルって、サイズ大きいので、
　.htmlをテストでダウンロードしてます。
　目的のファイルへ拡張子のチェック部分を変更してくださいね。

リンク先のオブジェクトの取り出しは、
http://www.ken3.org/backno/backno_vba15.html#71
の
No.71 IE操作 リンク先を取出す .Document.links(i).href
で、
.Documentオブジェクトのリンクを探り、
.href .outertext .outerHTML を使ってみました。

objIE.Document.links.Length
でリンクの数を取得できるので、

    'リンク数分まわす
    For i = 0 To objIE.Document.links.Length - 1
        Cells(nYLINE, "A") = "'" & objIE.Document.links(i).outerText
        Cells(nYLINE, "B") = "'" & objIE.Document.links(i).href
        Cells(nYLINE, "C") = "'" & objIE.Document.links(i).outerHTML
        nYLINE = nYLINE + 1 'セット位置を＋1する
    Next i

みたいにして、リンクを取り出してました。
ここに、ファイルのダウンロード処理をいれてみます。

メインのルーチンで
^^^^^^^^^^^^^^^^^^
・ＩＥ起動
・目的の画面表示、
・リンクのループ、リンク先ＵＲＬをサブに渡す

サブのルーチンで、リンク先ＵＲＬを受け取り
^^^^^^^^^^^^^^^^^^
・拡張子のチェック
・ファイル名の作成
・実際のダウンロードを行う

と処理を分けてみたいと思います。

'URLDownloadToFile API from URLMON.
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
とＡＰＩの宣言をしてから、
まずは、メインのルーチンを作成します。

Sub test_main()

    Dim objIE   As Object
    Dim time10  As Date
    Dim strURL  As String
    Dim i       As Integer
    Dim nYLINE  As Integer

    On Error GoTo EMSG

    'IEの起動
    Set objIE = CreateObject("InternetExplorer.application")
    objIE.Visible = True  '見えるようにする
    
    objIE.GoHome  '初期ページの表示
    Do While objIE.Busy = True  '起動まで待つ
        DoEvents
    Loop
    
    'Excelをアクティブにする。
    AppActivate "Microsoft Excel"
    
    '初期処理
    Rows("13:1000").Select  '結果の表示エリアをクリアする
    Selection.Delete Shift:=xlUp
    nYLINE = 13 '13行目からデータをセットするので
    
    '読み込むページのURLを代入
    strURL = "http://www.ken3.org/backno/backno_vba15.html"
    objIE.Navigate "" & strURL  'アドレスを渡し表示する

    '読みこみ完了まで待つ
    '30秒後を計算して、待つ
    time10 = DateAdd("s", 30, Now())
    Do While objIE.Busy = True
        DoEvents
        If time10 < Now() Then
            Exit Do
        End If
        DoEvents
    Loop

    If objIE.Busy = True Then
        Cells(nYLINE, "A") = "タイムアウトです、読み込みに失敗しました"
        MsgBox "タイムアウトです、読み込みに失敗しました"
        Exit Sub '関数を抜ける
    End If

    'リンクを探す
    'リンク数分まわす
    For i = 0 To objIE.Document.links.Length - 1
        Cells(nYLINE, "A").Select '遊びでカーソル移動
        DoEvents
        Cells(nYLINE, "A") = "'" & objIE.Document.links(i).outerText
        Cells(nYLINE, "B") = "'" & objIE.Document.links(i).href
        '後ろが.htmlならファイルダウンロードの関数を呼ぶ
        If Right(objIE.Document.links(i).href, 4) = "html" Then
            Cells(nYLINE, "C") = Now '遊びで開始時刻をセット
            'ダウンロード関数を呼ぶ
            Call get_url_file(objIE.Document.links(i).href)
            Cells(nYLINE, "D") = Now
        End If
        '次のセット位置にする
        nYLINE = nYLINE + 1 'セット位置を＋1する
    Next i
    
    objIE.Quit   'ＩＥを閉じる

    MsgBox "終了しました"

    Exit Sub
    
EMSG:
    Cells(nYLINE, 2) = "ERR"
    objIE.Quit   '
    MsgBox "errが発生しました"
    Exit Sub

End Sub

次にサブルーチンを作成します。
ＵＲＬを引数で受け取って、ダウンロードしてみます。

'URLを受け取り、ファイルをダウンロードする
'関数内でＵＲＬからファイル名を作成する（/を探す）
Sub get_url_file(strURL As String)

    Dim strFNAME As String  'ダウンロード先（パス＋ファイル名）
    Dim strWORK  As String  '後ろから/を探し、ファイル名を取り出す
    Dim returnValue
    Dim n As Integer

    'ファイル名を取り出す
    For n = Len(strURL) To 1 Step -1 '後ろから/を探す
        If Mid(strURL, n, 1) = "/" Then
            Exit For  '/が見つかったらループを抜ける
        End If
    Next n
    strWORK = Mid(strURL, n + 1) '/の次からファイル名なのでn+1から
    
    'ファイル名をブックのパス＋\＋取り出したファイル名とする
    strFNAME = ThisWorkbook.Path & "\" & strWORK
    'strFNAME = "C:\DATA\AAA\" & strWORK と固定のパスでもＯＫだけど

    'URLDownloadToFile API をコールする
    returnValue = URLDownloadToFile(0, strURL, strFNAME, 0, 0)

End Sub

ポイントは、特に無いんだけど、
http://www.ken3.org/backno/backno_vba15.html
と、urlを受け取るので、
/を探して、
backno_vba15.html
とファイル名を取り出して、
strFNAME = ThisWorkbook.Path & "\" & strWORK
と、ファイル名を作成しました。

固定のフォルダーに落としたい時は、
strFNAME = "d:\data\" & strWORK
なんてやると、
d:\data\backno_vba15.html
に保存されると思います。

pdfファイルも同様にダウンロード可能だと思います。

/*
 * ５．終わりの挨拶
*/

今回は、
Web上のファイルを
URLDownloadToFile APIを使用してダウンロードしてみました。

サンプルファイルは、
http://www.ken3.org/vba/lzh/vba120.lzh
にvba120.xlsが保存されています。

テストして、遊んでみてください。

何かの参考となれば幸いです。

Ｅｘｃｅｌ／Ａｃｃｅｓｓ大好き、三流プログラマーＫｅｎ３でした。

フィードバック

評価・感想

ページフッター(リンクや広告など)

書籍の購入

コンピュータ書籍の発送がハヤイ専門店

コンピュータの本・専門店

※種類が豊富で探し易いです。※在庫ありが48時間以内発送が急ぎで資料や書籍がほしい時、とても助かります。 お奨め本の目次を見るだけでも勉強になったり

amazon.co.jpでキーワード別チェック