HOME > エクセルVBA > サンプル > URLDownloadToFile

URLDownloadToFile


【ファイル名】URLDownloadToFile.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年07月06日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】URLDownloadToFile.zip
【説明】Windows APIの URLDownloadToFile 関数でファイルをダウンロードします。
画面

【外部リンク】Windows > Apps > Win32 > API > Windows Internet > Wininet.h >  DeleteUrlCacheEntryW function (wininet.h)
【外部リンク】Docs > Previous Versions > Windows > Internet Explorer > Internet Explorer for Developers > Platform APIs > URL Monikers and Asynchronous Pluggable Protocols > URL Monikers and Asynchronous Pluggable Protocol Reference > Functions >  URLDownloadToFile function

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="URLDownloadToFile">
          <box id="Box1" boxStyle="vertical">
            <editBox id="URLEditBox" label="URL:" keytip="U" maxLength="1024" getText="getText" onChange="onChange"
                     supertip="URLを入力して、Enter キーを押してください。"
                     sizeString="WWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMM" />
            <editBox id="FileNameEditBox" label="保存先のファイル名:" keytip="F" maxLength="1024" getText="getText" onChange="onChange"
                     supertip="保存先のファイル名を入力して、Enter キーを押してください。"
                     sizeString="WWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMM" />
            <button id="DownloadButton" label="ダウンロード" keytip="D" imageMso="HappyFace"
                    supertip="URLからファイルをダウンロードします。" onAction="onAction" />
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

Module1
Option Explicit

Private Const MAX_PATH = 260& ' パスの最大文字数

Private rbRibbonUI As IRibbonUI   ' リボン
Private rbURLText As String ' editBoxの文字列
Private rbFileNameText As String ' editBoxの文字列

#If Win64 Then
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wininet/nf-wininet-deleteurlcacheentryw
  Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryW" (ByVal lpszUrlName As LongPtr) As Long
  
  ' https://docs.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/platform-apis/ms775123(v=vs.85)
  Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileW" (ByVal pCaller As LongPtr, ByVal szURL As LongPtr, _
          ByVal szFileName As LongPtr, ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As Long

#Else
  Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryW" (ByVal lpszUrlName As Long) As Long
  Private Declare Function URLDownloadToFile Lib "Urlmon.dll" Alias "URLDownloadToFileW" (ByVal pCaller As Long, ByVal szURL As Long, _
          ByVal szFileName As Long, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Private Sub DownloadFile(Url As String, Filename As String) ' ダウンロード
  DeleteUrlCacheEntry StrPtr(Url)
  
  If URLDownloadToFile(0, StrPtr(Url), StrPtr(Filename), 0, 0) <> 0 Then
    MsgBox Prompt:="ファイルをダウンロードできませんでした。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
  Else
    Shell "Explorer.exe /select," & Filename, vbNormalFocus
  End If
End Sub

Private Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbURLText = "http://suyamasoft.blue.coocan.jp/ExcelVBA/Sample/URLDownloadToFile/Screen.jpg"
  rbFileNameText = "C:\Windows\temp\Screen.jpg"
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Private Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "DownloadButton"
      If Len(rbURLText) < 1 Then
        MsgBox Prompt:="URLを入力してください!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
        Exit Sub
      End If
      
      If Len(rbFileNameText) < 1 Then
        MsgBox Prompt:="ファイル名を入力してください!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
        Exit Sub
      End If
      
      DownloadFile rbURLText, rbFileNameText
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
  End Select
  
  Exit Sub
'
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub

Private Sub getText(control As IRibbonControl, ByRef returnedVal) ' editBoxに文字列を代入する
  Select Case control.ID
    Case "URLEditBox"
      returnedVal = rbURLText
    Case "FileNameEditBox"
      returnedVal = rbFileNameText
  End Select
End Sub

Private Sub onChange(control As IRibbonControl, text As String) ' editBoxで[Enter]キーを押したか、他のコントロールに移動した場合のイベント
  Select Case control.ID
    Case "URLEditBox"
      rbURLText = text
    Case "FileNameEditBox"
      rbFileNameText = text
  End Select
End Sub
このページの上