超链接文件操作
嘿，盖伊的我在绘图中有很多块，都有超链接到服务器所在的与块相关的PDF文档库。
我的问题是，是否有Lisp或VBA将这些“超链接”的PDF剪切表复制到一个名为剪切表的新目录
，该目录将位于当前项目类型目录树中。
马克
**** Hidden Message ***** 因此，您希望扫描所有块，找到所有超链接，然后将超链接指向的文件复制到项目文件夹中？
假设这确实是您想要做的，这应该可以。
您需要添加对Microsoft脚本运行时的引用。
Option Explicit
Public Sub Main()
Dim objBlock As AcadBlockReference
Dim objEnt As AcadEntity
Dim colHyps As AcadHyperlinks
Dim fso As FileSystemObject
Set fso = New FileSystemObject
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, "E:\Temp\"' replace E:\Temp\ with your project directory
End If
Next objEnt
Set fso = Nothing
End Sub
Matt，
感谢您的快速回复！您提到了Microsoft运行时脚本？我需要一些软件吗？或者参考我已经拥有的软件？（PO-Gramming的相当新）。请参阅代码中的注释
选项显式
Public Sub Main（）
Dim obBlock As AcadBlockAudi
Dim colHyps As AcadHyperlink
Dim fso As FileSystemObject
设置fso=New FileSystemObject
对于ThisDrawing.ModelSpace
中的每个对象
如果TypeOf obEnt是AcadBlockResources，则
设置对象块=对象块
设置Colps=objBlock.Hyperlinks
在错误恢复下一步'如果我们遇到任何没有超链接的块
（有没有办法让程序通过使用当前工作图来了解PATH？）
fso.CopyFilecolHyps.Item（0）。URL，"E：\Temp\"'将E：\Temp\替换为您的项目目录（这将是PDF源文件？）
结束如果
下一个对象Ent
设置fso=无
结束子
要添加对Microsoft脚本运行时的引用，请在IDE中单击工具-引用（参见第一张图片），然后选择Microsoft脚本运行时（参见第二张图片）。
Matt，
再次感谢您抽出宝贵时间查看代码中的注释。
Option Explicit
Public Sub Main（）
Dim objBlock As AcadBlockReference
Dim objEnt as AcadEntity
Dim colHyps as AcadHyperlinks
Dim fso As FileSystemObject
Set fso = New FileSystemObject
For Each objEnt In ThisDrawing.ModelSpace
if TypeOf objEnt Is AcadBlockReference then
Set objBlock = objEnt
Set colHyps = objBlock.Hyperlinks
在错误恢复下一个'如果我们遇到任何没有超链接的块
（有没有办法让程序通过使用当前工作图形来了解PATH？
您是指当前绘图的位置吗？ 那条路??!?（是的，当前工作图形驻留在项目目录中，也称为Cut_Sheets驻留在项目目录中。这是我希望PDF剪切表结束的地方。
fso.CopyFile colHyps.Item（0）.URL， “E：\Temp\” ' 将 E：\Temp\ 替换为您的项目目录
（这将是 PDF 源文件？
这是文件将被复制到的位置。
如果
下一个 objEnt
Set fso = Nothing
End Sub
Matt，
这是我写的一个小程序，用于启动一个新项目，以满足公司的特定需求。
这可能有助于了解移动超链接剪切页的需要 Matt，
假设我使用数据提取创建BOM表，在模型空间中有5个多块部件图形，但在图纸空间布局中仅显示1个部件。还有没有办法防止将重复的PDF剪切表移动到同一目录，或者程序会崩溃，或者它会提示我覆盖提交的任何重复文件？此外，我们的项目发生了很大变化，一些块将被删除，其他块将被添加。我再次运行此程序，是否可以删除Cut_Sheet目录中的现有文件并重新填充新修改的当前图纸切割表 0 Then ' Checks to see if there are any PDFs in E:Temp
fso.DeleteFile "E:\Temp\*.pdf", True ' If there are, delete them
End If
此行将自动覆盖任何可能与正在复制的 PDF 同名的 PDF。
fso.CopyFile colHyps.Item(0).URL, "E:\Temp\", True
当你把它们放在一起时，你会得到这个...
Option Explicit
Public Sub Main()
Dim objBlock As AcadBlockReference
Dim objEnt As AcadEntity
Dim colHyps As AcadHyperlinks
Dim fso As FileSystemObject
Set fso = New FileSystemObject
If Len(Dir("E:\Temp\*.pdf"))0 Then ' Checks to see if there are any PDFs in E:Temp
fso.DeleteFile "E:\Temp\*.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, "E:\Temp\", True' replace E:\Temp\ with your project directory
' The TRUE option will automatically overwrite any existing files with the same name
End If
Next objEnt
Set fso = Nothing
End Sub
要获取当前绘图的位置，您可以使用this drawing . path。
要测试它，只需将它放在一个空的SUB中并运行它。它将显示一个带有绘图路径的对话框。
MsgBox ThisDrawing.Path
然后，您可以使用
MsgBox ThisDrawing.Path & "\Cut_Sheets"
马特＜br＞再次感谢您，请原谅我的心理障碍＜br＞见红色代码，
将
选项显式标记为
Public Sub-Main（）
将对象块设置为acadblock引用
将目标块设置为AcadIdentity
把colHyps设置为AcadHyperlinks
设置为FileSystemObject
如果Len（Dir（“E:\Temp\*.pdf”）0，则“检查E:Temp
fso中是否有pdf。删除文件“E:\Temp\*.pdf”，如果存在，则为True，如果此图形中的每个对象都存在，则将其删除
结束
。模型空间
如果对象的类型是AcadBlockReference，则
设置objBlock=objEnt
设置colHyps=objBlock。出现错误时的超链接<；br>；如果遇到任何没有超链接>；fso的块，请继续下一步。复制文件colHyps.Item（0）。URL，“E:\Temp\”，（我将如何放置此项？ThisDrawing.Path&“\Cut_Sheets\”，True）“将E:\Temp\替换为项目目录
”。如果
下一个对象
，
设置为fso=Nothing
End Sub，则True选项将自动覆盖具有相同名称的任何现有文件
End 嗯哼。
页:
[1]
2