重新访问的超链接文件

'---------------------------------------------------------------------------------------
' Module    : Module_get_hyperlink_cut_sheets
' DateTime  : 5/01/2009 13:21
' Author    : Mark
' Purpose   : The Program will sort through the current drawings model space blocks
'           : and find any associated hyperlinks to a PDF Cut Sheet and move that cut
'           : sheet to the PATH v:\Current_Project\Cut Sheets\ Directory.
'---------------------------------------------------------------------------------------
Option Explicit
Public Sub Gartner_Get_Hyperlink_Main()
    Dim objBlock As AcadBlockReference
    Dim objEnt As AcadEntity
    Dim colHyps As AcadHyperlinks
    Dim fso As FileSystemObject
    
    
    Set fso = New FileSystemObject
    
    If Len(Dir(ThisDrawing.Path & "\Cut Sheets\*.pdf"))  0 Then
    ' Checks to see if there are any PDFs in CURRENT_Project\Cut Sheets\
        fso.DeleteFile ThisDrawing.Path & "\Cut Sheets\*.pdf", True
        ' If there are, delete them
    End If
    
    For Each objEnt In ThisDrawing.ModelSpace
        If TypeOf objEnt Is AcadBlockReference Then
            Set objBlock = objEnt
            Set colHyps = objBlock.Hyperlinks
            On Error Resume Next
            ' In case we encounter any blocks that DON'T have hyperlinks
            fso.CopyFile colHyps.Item(0).URL, ThisDrawing.Path & "\Cut Sheets\*.pdf", True
           ' The TRUE option will automatically overwrite any existing files with the same name
        End If
    Next objEnt
    
    Set fso = Nothing
End Sub

fso.CopyFile colHyps.Item(0).URL, ThisDrawing.Path & "\Cut Sheets\*.pdf", True

fso.CopyFile colHyps.Item(0).URL, ThisDrawing.Path & "\Cut Sheets", True