超链接文件操作

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

嘿，盖伊的
我在绘图中有很多块，都有超链接到服务器所在的与块相关的PDF文档库。
我的问题是，是否有Lisp或VBA将这些“超链接”的PDF剪切表复制到一个名为剪切表的新目录
，该目录将位于当前项目类型目录树中。
马克

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

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

因此，您希望扫描所有块，找到所有超链接，然后将超链接指向的文件复制到项目文件夹中？
假设这确实是您想要做的，这应该可以。
您需要添加对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 [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

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=无
结束子

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

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

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

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

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

Matt，
这是我写的一个小程序，用于启动一个新项目，以满足公司的特定需求。
这可能有助于了解移动超链接剪切页的需要

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

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[/code]
此行将自动覆盖任何可能与正在复制的 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

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

要获取当前绘图的位置，您可以使用this drawing . path。
要测试它，只需将它放在一个空的SUB中并运行它。它将显示一个带有绘图路径的对话框。

copy

MsgBox ThisDrawing.Path

然后，您可以使用

copy

MsgBox ThisDrawing.Path & "\Cut_Sheets"

Matt__W · 发表于 2009-5-4 08:13:19

马特＜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。出现错误时的超链接&lt；br&gt；如果遇到任何没有超链接&gt；fso的块，请继续下一步。复制文件colHyps.Item（0）。URL，“E:\Temp\”，（我将如何放置此项？ThisDrawing.Path&“\Cut_Sheets\”，True）“将E:\Temp\替换为项目目录
”。如果
下一个对象
，
设置为fso=Nothing
End Sub，则True选项将自动覆盖具有相同名称的任何现有文件
End

krampaul82 · 发表于 2009-5-4 09:26:42

嗯哼。

超链接文件操作

发表回复

精选推荐

浏览过的版块