Excel~批量提取超链接文件【支持多种格式】

对于一些经常使用 Excel 整理文档资料的工作，我们可以将需要整理的文件资料上传到网络空间，然后链接到 Excel 报表中，这样随时随地只要我们打开报表就可以查阅相关资料了。 但是 Excel 默认点击链接会直接打开文件，如果我们想要下载下来会比较麻烦，特别是对于报表中有数量较多链接文档时，如果一个个打开下载，工作量可想而知。如题，该功能可以自动获取 Excel 中的链接文件，并批量下载到本地指定文件夹下。

目前该功能我测试了一下文件，都可以正常下载，速度还可以，大家可以自行测试一下。

话不多说，直接上代码。

首先进入 VBE 编辑器，新建一个模块(M),将下面的代码丢进去。

#If VBA7 And Win64 Then
    Private Declare PtrSafe 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
    Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
#Else
    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
    Private Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
#End If

Sub qggExportHyperlinkFiles()

    On Error Resume Next

    Application.ScreenUpdating = False
    
    Dim numHL, i As Integer
    Dim Arr() As Variant
    Dim selectedFolder, savePath, fileHL As Hyperlink

    '弹窗选择文件保存路径
    Set FolderDialogObject = Application.FileDialog(msoFileDialogFolderPicker)
        With FolderDialogObject
            .Title = "请选择要保存的文件夹"
            .InitialFileName = "C:\"
        End With
        FolderDialogObject.Show
        savePath = FolderDialogObject.SelectedItems(1) & "\qggExportFiles"
    
    '生成保存文件夹路径下文件夹
    Set fso = CreateObject("Scripting.FileSystemobject")
        '检查文件夹是否存在
        If fso.FolderExists(savePath) Then
            warningMsg = MsgBox("文件夹已存在，是否将其删除？", vbCritical + vbOKCancel, 警告)
            If warningMsg = vbOK Then
                fso.DeleteFolder savePath
            Else
            Do While fso.FolderExists(savePath)
                Call MsgBox("文件夹已存在，请选择新的文件夹！", vbExclamation + vbOK, "请选择要保存的文件夹")
                FolderDialogObject.Show
                savePath = FolderDialogObject.SelectedItems(1) & "\qggExportFiles"
            Loop
            
            End If
            
        End If
        '未选择任何文件夹时提示
        If savePath = "" Then
        Call MsgBox("未选择任何文件夹！", vbCritical + vbOK, "警告")
        Exit Sub
        Else
            creatPath = fso.CreateFolder(savePath)
        End If
       
    '遍历文档，计算所有超链接数目
    numHL = 0
    For Each fileHL In ActiveSheet.Hyperlinks
        numHL = numHL + 1
    Next
    
    '进度条显示下载进度
    With ProgressBarForm
        .Show 0   '//显示进度条窗体
        IntTotalLen = 1000  ''(UBound(ARRSH) + 1) * (UBound(SQLARR, 1) + 1)
        IntCurrentLen = 0
        
        For iProgress = 4 To IntTotalLen   '//iProgress 是循环变量
        
            IntCurrentLen = IntCurrentLen + 1
            
            .ProgressBarLabel.Width = Int(IntCurrentLen / IntTotalLen * 300)
            .ProgressBarLabel.Caption = CStr(Round((IntCurrentLen / IntTotalLen * 100), 4)) & "%"
            '.Caption = "文件下载中，请稍候......"
            DoEvents

            '遍历文档，查找所有超链接并存在数组中
            ReDim Arr(numHL) As Variant
            i = 0
            For Each fileHL In ActiveSheet.Hyperlinks
                i = i + 1
                Arr(i) = fileHL.Address
                Set fso = CreateObject("Scripting.FileSystemobject")
                theFileName = fso.GetFileName(Arr(i))
                Call URLDownloadToFile(0, Arr(i), creatPath & "\" & theFileName, 0, 0)
            Next
    
        Next iProgress
    End With
    Unload ProgressBarForm  '//关闭窗体
    
    '弹窗提示保存成功
    Call MsgBox("恭喜，所有文件已成功保存至" & vbCrLf & savePath & vbLf & "文件夹下 ！", vbInformation + vbOKOnly, 保存成功)
    
    Application.ScreenUpdating = True
End Sub

然后插入一个 Form 控件，命名为ProgressBarForm，在 Form 控件里插入一个名为 ProgressBarLabel 的标签，用于设置进度条，参数什么的自己设置下感觉好看即可。如果想要隐藏 Form 弹窗的关闭按钮“X”，插入下面代码即可：

' 隐藏 Form 弹窗的关闭按钮“X”
Private Declare PtrSafe Function FindWindow Lib "user32" Alias _
    "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias _
    "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    
Private Sub UserForm_Initialize()
    SetWindowLong FindWindow(vbNullString, Me.Caption), -16, &H6C10000
End Sub

如果不需要隐藏，只是禁用，插入下面这段代码即可。

'禁用 Form 弹窗的关闭按钮“X”
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode <> 1 Then Cancel = True
End Sub

最后将文件保存为 xlsm 或 xlam 格式文档即可。最后为了避免大家不清楚怎么设置，放几张 VBE 编辑器截图。