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,如/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 = "/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 不少资料来自网上,并不知原文出自何处,如您有原文链接,谢谢网友提供。
CnHUP on 十月 22nd, 2009
Of course you can.
CnHUP on 十二月 25th, 2009
Of course.