批量下载EXCEL中的链接到本地

废话不说，直接上代码：

模块名：iGt

模块名也可以是其他任意合法名，这里只是我自己取的名字。

Option Explicit
Dim okCount As Long, noCount As Long, nCount As Long, nRow As Long
Dim iSht As Worksheet, iErrSht As Worksheet
Dim iIRibbonUI As IRibbonUI
Sub GetDownload(URL As String, 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 Then
        okCount = okCount + 1
        Debug.Print "下载成功"
    Else
        noCount = noCount + 1
        iSht.Rows(Replace("{}:{}", "{}", nCount)).Copy Destination:=iErrSht.Rows(Replace("{}:{}", "{}", noCount))
        Debug.Print "下载失败: " & ErrorText
    End If
    iErrSht.Cells(1, 12).Value = CStr("'" & nCount & "/" & nRow)
End Sub

Sub iRunDownFile(control As IRibbonControl)
    Dim irow As Long, i As Long  ', j As Long
    Dim TempRng As Range
    Dim iUrl
    Dim iFileName As String, iDirPath As String
    Dim iUrlArr
    On Error Resume Next
    nCount = 0
    noCount = 0
    okCount = 0
    Set iSht = ActiveSheet
    With iSht
        Set iErrSht = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
        iErrSht.Name = "下载失败" & ActiveWorkbook.Worksheets.Count
        iErrSht.Tab.Color = RGB(255, 0, 0)
        iErrSht.Cells(1, 11) = "进度"
        iErrSht.Activate
        irow = .Rows(1).SpecialCells(xlCellTypeConstants, 23).Count                 '标题的列数，决定每个结果集的行数
        nRow = .Range("A65536").End(xlUp).Row                                       '取原始数据的有效行数，如果是2007及以上的版本可以为：A1048576
        If nRow = 1 Then
            MsgBox "没有找到内容,程序无法执行！", vbOKOnly, "警告"
            Exit Sub
        End If
        iDirPath = ActiveWorkbook.Path & "\" & Replace(CStr(Now), ":", "_") & "[" & nRow & "]"
        VBA.MkDir (iDirPath)
        For i = 1 To nRow                                                               '从Sht1的第二行开始遍历非空单元格区域，并将需要的值写入Sht2对应的单元格
            Set TempRng = .Range(Replace("a{0}:c{0}", "{0}", i))
                iUrl = TempRng(1, 3)
                iFileName = RemovePunctuation(CStr(TempRng(1, 1).Value))
                iUrlArr = Split(iUrl, "|")
                For Each iUrl In iUrlArr
                    Debug.Print i, iUrl
                    If InStr(1, iUrl, "//") > 0 Then
                        nCount = nCount + 1
                        GetDownload CStr(iUrl), iDirPath & "\" & iFileName & "_" & Right(iUrl, 12)
                    Else
                        noCount = noCount + 1
                    End If
                Next iUrl
                'iIRibbonUI.InvalidateControl (control.ID)
        Next i
    End With
    Set iErrSht = Nothing
    MsgBox "总共图片数量：" & nCount & vbCrLf _
           & "下载成功：" & okCount & vbCrLf _
           & "下载失败：" & noCount & vbCrLf _
           & "文件目录：" & vbCrLf _
           & iDirPath
    Shell "explorer.exe " & iDirPath, vbNormalFocus
End Sub

Sub rxIRibbonUI_onLoad(ribbon As IRibbonUI)
    Set iIRibbonUI = ribbon
End Sub

Sub NDFgetLabel(control As IRibbonControl, ByRef returnedVal)
'    If nCount = 0 Then
        returnedVal = "下载助手"
'    Else
'        returnedVal = Format((okCount + noCount) / nCount, "0.00%")
'    End If
End Sub

Function RemovePunctuation(Txt As String) As String
    With CreateObject("VBScript.RegExp")
    .Pattern = "[^a-zA-Z\u4e00-\u9fa5][^a-zA-Z0-9\u4e00-\u9fa5]+"
    .IgnoreCase = True
    .Global = True
    RemovePunctuation = .Replace(Txt, "")
    End With
End Function

下面这是核心代码：

取名为iFc 

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

再就是IRibbon：

<customUI
    xmlns="http://schemas.microsoft.com/office/2006/01/customui"
    onLoad="rxIRibbonUI_onLoad"
    xmlns:nsHost="My Shared Ribbon">
    <ribbon startFromScratch="false">
        <tabs>
            <tab idMso="TabHome">

              <group idQ="nsHost:rxGrpNetDownFiles"
                    label="下载助手"
                    insertAfterMso="GroupFont">
                    <button id="rxNetDownFiles"
                            getLabel="NDFgetLabel"
                            image="Down"
                            size="large"
                            screentip="文件下载工具"
                            supertip="此工具可以将A列的作为文件名，下载C列的网络图片地址到文件所在目录下的文件夹，C出现多个地址用'|'分割，需要帮助请联系作者QQ：442691556"
                            onAction="iRunDownFile"/>
                </group>
            </tab>
        </tabs>
    </ribbon>
</customUI>

image="Down"

是一个名为Down的图片文件，放在资源中

格式可以是jpg,png,bmp,tif,gif

尺寸建议是40*40px