VBA中从网上下载文件

如果你开发的程序需要从网上下载一个文件，一般比较容易的方法是使用API函数URLDownloadToFile，本文介绍一个对此函数进一步包装，使得在VBA中更好的使用的VBA函数。这个函数名称为DownloadFile，原型如下：

Public Function DownloadFile(
  UrlFileName As String, _
  DestinationFileName As String, _
  Overwrite As DownloadFileDisposition, _
  ErrorText As String) As Boolean

在函数中各参数意义如下：
UrlFileName: 待下载文件的URL，如http://www.cnhup.com/uploads/DownloadFile-Demo.zip。
DestinationFileName: 文件保存到本机位置的路径，必须为包括文件名的全称，而不仅仅是文件夹路径。
Overwrite: 当DestinationFileName存在时的处理方式，
包括OverwriteKill (= 0):直接删除；
OverwriteRecycle (= 1):删除到回收站；
DoNotOverwrite (= 2):不会对已存在的文件进行覆盖；
PromptUser (= 3):弹出对话框让用户选择处理方式，如选择No不覆盖，Yes删除到回收站。
ErrorText: 当下载失败时此参数将有下载失败原因的说明，如果成功时为空。
如果下载成功，DownloadFile函数返回True，否则为False。

Option Explicit
Option Compare Text

Public Enum DownloadFileDisposition
    OverwriteKill = 0
    OverwriteRecycle = 1
    DoNotOverwrite = 2
    PromptUser = 3
End Enum

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

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

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

使用示例

Dim URL As String
Dim LocalFileName As String
Dim B As Boolean
Dim ErrorText As String

URL = "http://www.cnhup.com/uploads/DownloadFile-Demo.zip"
LocalFileName = "C:\Test\DownloadFile-Demo.zip"
B = DownloadFile(UrlFileName:=URL, _
                 DestinationFileName:=LocalFileName, _
                 Overwrite:=OverwriteRecycle, _
                 ErrorText:=ErrorText)
If B = True Then
    Debug.Print "下载成功"
Else
    Debug.Print "下载失败: " & ErrorText
End If

引用：http://www.cpearson.com/Excel/DownloadFile.aspx　不少资料来自网上，并不知原文出自何处，如您有原文链接，谢谢网友提供。