超链接文件操作

krampaul82 · 发表于 2009-5-1 09:10:50

嘿，盖伊&#039；我在一个图形中有许多块，所有块都有指向服务器上与块相关的PDF文档库的超链接
我的问题；是否有Lisp或VBA可以复制这些内容；“超链接”；PDF将图纸剪切到名为“剪切图纸”的新目录，该目录将位于当前项目类型目录树中
标记

Matt__W · 发表于 2009-5-1 09:20:29

那么，您想扫描所有块，找到任何超链接，然后将超链接指向的文件复制到项目文件夹
假设这确实是你想要做的，这应该行得通
你&#039；我需要添加对Microsoft脚本运行时的引用

copy

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 [color=green]' In case we encounter any blocks that DON'T have hyperlinks[/color]
            fso.CopyFile colHyps.Item(0).URL, "E:\Temp"  [color=green]' replace E:\Temp\ with your project directory[/color]
        End If
    Next objEnt
    
    Set fso = Nothing
End Sub

krampaul82 · 发表于 2009-5-1 12:03:42

马特，谢谢你的快速回复！你提到Microsoft运行时脚本？我需要买些软件吗？或者引用一个我已经准备好的软件？（在PO Gramming上非常新）。参见代码中的注释&nbsp；Dim objBlock As AcadBlockReference作为对象块参考&nbsp；模糊对象作为身份&nbsp；暗colHyps作为AcadHyperlinks&nbsp；将fso设置为文件系统对象&nbsp
&nbsp；设置fso=New FileSystemObject&nbsp
&nbsp；对于本图纸中的每个对象。模型空间&nbsp&nbsp&nbsp；如果对象的类型是AcadBlockReference，则&nbsp&nbsp&nbsp&nbsp&nbsp；设置objBlock=objEnt&nbsp&nbsp&nbsp&nbsp&nbsp；设置colHyps=objBlock。超链接&nbsp&nbsp&nbsp&nbsp&nbsp；出错时继续下一步&#039；如果我们遇到任何不&#039；T有超链接（有没有办法让程序使用当前工作图来知道路径？）
&nbsp&nbsp&nbsp&nbsp&nbsp；fso。CopyFile colHyps。项（0）。URL，&quot；E： “温度”&nbsp' 将E:\Temp\替换为项目目录（这将是PDF源文件？）
&nbsp&nbsp&nbsp；如果结束&nbsp；下一个目标&nbsp
&nbsp；设置fso=Nothing

Matt__W · 发表于 2009-5-1 13:16:26

要添加对Microsoft脚本运行时的引用，请在IDE中单击工具-引用（请参见第一个图像），然后选择Microsoft脚本运行时间（请参见第二个图像）

krampaul82 · 发表于 2009-5-1 13:53:52

Matt，再次感谢您抽出时间查看代码中的注释
选项显式&nbsp；Dim objBlock As AcadBlockReference作为对象块参考&nbsp；模糊对象作为身份&nbsp；暗colHyps作为AcadHyperlinks&nbsp；将fso设置为文件系统对象&nbsp
&nbsp；设置fso=New FileSystemObject&nbsp
&nbsp；对于本图纸中的每个对象。模型空间&nbsp&nbsp&nbsp；如果对象的类型是AcadBlockReference，则&nbsp&nbsp&nbsp&nbsp&nbsp；设置objBlock=objEnt&nbsp&nbsp&nbsp&nbsp&nbsp；设置colHyps=objBlock。超链接&nbsp&nbsp&nbsp&nbsp&nbsp；出错时继续下一步&#039；如果我们遇到任何不&#039；T有超链接（有没有办法让程序使用当前工作图来知道路径？）
你是指当前的图纸吗；s位置&nbsp；那条路？？！？（是的，当前工作图纸位于项目目录中，项目目录中也有一个名为Cut_Sheets的目录。这是我希望PDF剪切图纸结束的地方。）&nbsp&nbsp&nbsp&nbsp&nbsp；fso。CopyFile colHyps。项（0）。URL，&quot；E： “温度”&nbsp' 将E:\Temp\替换为项目目录（这将是PDF源文件？）
文件将复制到此处&nbsp&nbsp&nbsp；如果结束&nbsp；下一个目标&nbsp
&nbsp；设置fso=Nothing

krampaul82 · 发表于 2009-5-1 14:25:39

马特，这是我写的一个小程序，为我的公司启动一个新项目#039；的具体需求
这可能有助于了解移动超链接剪切图纸的必要性

krampaul82 · 发表于 2009-5-1 15:27:04

马特，让&#039；例如，我使用数据提取创建BOM表，在模型空间中有5个多块装配图，但在图纸空间布局中仅显示1个装配。还有什么方法可以防止将重复的PDF剪切页移动到同一目录中，或者程序会崩溃，或者它会提示我覆盖出现的任何重复文件吗&nbsp；此外，我们的项目发生了很大变化，一些块将被删除，其他块将被添加，我再次运行此程序，是否可以删除Cut_Sheet目录中的现有文件，并用新修改的当前图形切割表重新填充
标记

Matt__W · 发表于 2009-5-4 08:10:25

这将自动删除特定目录中的所有PDF，在本例中为E:\Temp&nbsp；将其更改为存储PDF的项目文件夹

copy

[color=red]If Len(Dir("E:\Temp\*.pdf"))  0 Then[/color]      [color=green]' Checks to see if there are any PDFs in E:Temp[/color]
    [color=red]fso.DeleteFile "E:\Temp\*.pdf", True[/color]    [color=green]' If there are, delete them[/color]
[color=red]End If[/color]

该行将自动覆盖任何可能与所复制PDF同名的PDF

copy

fso.CopyFile colHyps.Item(0).URL, "E:\Temp", True

当你把这一切放在一起，你会得到这个…

copy

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
    [color=red]If Len(Dir("E:\Temp\*.pdf"))  0 Then[/color]      [color=green]' Checks to see if there are any PDFs in E:Temp[/color]
        [color=red]fso.DeleteFile "E:\Temp\*.pdf", True[/color]    [color=green]' If there are, delete them[/color]
    [color=red]End If[/color]
    
    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
            [color=red]fso.CopyFile colHyps.Item(0).URL, "E:\Temp", True[/color]  [color=green]' replace E:\Temp\ with your project directory[/color]
                                                                [color=green]' The TRUE option will automatically overwrite any existing files with the same name[/color]
        End If
    Next objEnt
    
    Set fso = Nothing
End Sub