Matt
This is not working
is there a typo problem on my part?
mark
'---------------------------------------------------------------------------------------
' 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