Option Explicit
Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modDownloadFile
' By Chip Pearson, chip@cpearson.com, www.cpearson.com/Excel/DownloadFile.aspx
' Date: 23-April-2003
' This module contains the DownloadFile function and supporting players to
' download a file from a URL to a local file name.
'
' Example Usage:
'
' Dim URL As String
' Dim LocalFileName As String
' Dim B As Boolean
' Dim ErrorText As String
'
' URL = "http://www.cpearson.com/Zips/FindAll.zip"
' LocalFileName = "C:\Test\FindAll.zip"
' B = DownloadFile(UrlFileName:=URL, _
' DestinationFileName:=LocalFileName, _
' Overwrite:=OverwriteRecycle, _
' ErrorText:=ErrorText)
' If B = True Then
' Debug.Print "Download successful"
' Else
' Debug.Print "Download unsuccessful: " & ErrorText
' End If
'
' The Overwrite parameter of DownloadFile indicates how to handle the
' case when LocalFileName already exists. It is one of the following
' values:
' OverwriteKill use Kill to delete the existing file.
' OverwriteRecycle send the existing file to the Recycle Bin.
' DoNotOverwrite do not overwrite and terminate the procedure.
' PromptUser prompt the user asking whether to overwrite file.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Enum DownloadFileDisposition
OverwriteKill = 0
OverwriteRecycle = 1
DoNotOverwrite = 2
PromptUser = 3
End Enum
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Windows API functions, constants,and types.
' Used for RecycleFile.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function SHFileOperation Lib "shell32.dll" Alias _
"SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Declare Function PathIsNetworkPath Lib "shlwapi.dll" _
Alias "PathIsNetworkPathA" ( _
ByVal pszPath As String) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" _
Alias "GetSystemDirectoryA" ( _
ByVal lpBuffer As String, _
ByVal nSize As Long) As Long
Private Declare Function SHEmptyRecycleBin _
Lib "shell32" Alias "SHEmptyRecycleBinA" _
(ByVal hwnd As Long, _
ByVal pszRootPath As String, _
ByVal dwFlags As Long) As Long
Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_NOCONFIRMATION = &H10
Private Const MAX_PATH As Long = 260
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
'''''''''''''''''''''''''''
' Download API function.
''''''''''''''''''''''''''''''''''''''
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
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DownloadFile
' This downloads a file from a URL to a local filename.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function DownloadFile(UrlFileName As String, _
DestinationFileName As String, _
Overwrite As DownloadFileDisposition, _
ErrorText As String) As Boolean
Dim Disp As DownloadFileDisposition
Dim Res As VbMsgBoxResult
Dim B As Boolean
Dim S As String
Dim L As Long
ErrorText = vbNullString
If Dir(DestinationFileName, vbNormal) <> vbNullString Then
Select Case Overwrite
Case OverwriteKill
On Error Resume Next
Err.Clear
Kill DestinationFileName
If Err.Number <> 0 Then
ErrorText = "Error Kill'ing file '" & DestinationFileName & "'." & vbCrLf & Err.Description
DownloadFile = False
Exit Function
End If
Case OverwriteRecycle
On Error Resume Next
Err.Clear
B = RecycleFileOrFolder(DestinationFileName)
If B = False Then
ErrorText = "Error Recycle'ing file '" & DestinationFileName & "." & vbCrLf & Err.Description
DownloadFile = False
Exit Function
End If
Case DoNotOverwrite
DownloadFile = False
ErrorText = "File '" & DestinationFileName & "' exists and disposition is set to DoNotOverwrite."
Exit Function
'Case PromptUser
Case Else
S = "The destination file '" & DestinationFileName & "' already exists." & vbCrLf & _
"Do you want to overwrite the existing file?"
Res = MsgBox(S, vbYesNo, "Download File")
If Res = vbNo Then
ErrorText = "User selected not to overwrite existing file."
DownloadFile = False
Exit Function
End If
B = RecycleFileOrFolder(DestinationFileName)
If B = False Then
ErrorText = "Error Recycle'ing file '" & DestinationFileName & "." & vbCrLf & Err.Description
DownloadFile = False
Exit Function
End If
End Select
End If
L = URLDownloadToFile(0&, UrlFileName, DestinationFileName, 0&, 0&)
If L = 0 Then
DownloadFile = True
Else
ErrorText = "Buffer length invalid or not enough memory."
DownloadFile = False
End If
End Function
Private Function RecycleFileOrFolder(FileSpec As String) As Boolean
Dim FileOperation As SHFILEOPSTRUCT
Dim lReturn As Long
If (Dir(FileSpec, vbNormal) = vbNullString) And _
(Dir(FileSpec, vbDirectory) = vbNullString) Then
RecycleFileOrFolder = True
Exit Function
End If
With FileOperation
.wFunc = FO_DELETE
.pFrom = FileSpec
.fFlags = FOF_ALLOWUNDO
' Or
.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
End With
lReturn = SHFileOperation(FileOperation)
If lReturn = 0 Then
RecycleFileOrFolder = True
Else
RecycleFileOrFolder = False
End If
End Function
Sub example()
Dim URL As String
Dim LocalFileName As String
Dim B As Boolean
Dim ErrorText As String
Dim c As Range
For Each c In Columns("K:L").SpecialCells(xlCellTypeConstants, 23)
URL = c
LocalFileName = "C:\temp\" & Evaluate("TRIM(RIGHT(SUBSTITUTE(""" & c & """,""/"",REPT("" "",1000)),1000))")
B = DownloadFile(UrlFileName:=URL, _
DestinationFileName:=LocalFileName, _
Overwrite:=DoNotOverwrite, _
ErrorText:=ErrorText)
If B = True Then
Debug.Print "Download successful"
Else
Debug.Print "Download unsuccessful: " & ErrorText
End If
Next c
End Sub
