【遍历宏】在总装配內零件的自定义属性写入页码

gdzsh 发表于 2018-2-28 14:02
我怎么没有发现有一点脏话的意思啊？

俺指截图中的乱码

qxzch 发表于 2018-2-26 21:46
如附图明细栏最后一列所示，需要列出每个零部件的底图张次，就像普通自定义属性一样写在模型文件中的。
...

倒不如写个遍历工程图的宏，寻找零部件处于哪个页面，再写到零部件的属性。
更可作为检查有没有零部件漏做或重复制作工程图。

大鹿 发表于 2018-2-28 14:29
倒不如写个遍历工程图的宏，寻找零部件处于哪个页面，再写到零部件的属性。
更可作为检查有没有零部件漏 ...

谢谢回复！已经用遍历文件夹的方式解决了

qxzch 发表于 2018-2-28 21:43
谢谢回复！已经用遍历文件夹的方式解决了

虽然俺没需要，但也希望qxzch可以分享解决方法，以达投桃报李之效。

大鹿 发表于 2018-3-1 01:27
虽然俺没需要，但也希望qxzch可以分享解决方法，以达投桃报李之效。

支持，解决支持

qxzch 发表于 2018-2-28 21:43
谢谢回复！已经用遍历文件夹的方式解决了

遍历文件夹不适用吧？做设计总不可能文件价里面的零件全部都是装配体里面的零件吧？我的文件夹里面有不少的设计时替换下来的没有用的零件在里面，想删除掉还不好找。

求传个压缩包上来哟，复制代码粘贴后文字全是乱码，运行宏就报错

大鹿 发表于 2018-3-1 01:27
虽然俺没需要，但也希望qxzch可以分享解决方法，以达投桃报李之效。

代码如下，希望不要贻笑大方才好：

1. Dim swApp           As SldWorks.SldWorks
   
2. Dim swDoc           As SldWorks.ModelDoc2
   
3. Dim longstatus      As Long
   
4. Dim longwarnings    As Long
   
5. Dim PathName        As String
   
6. Dim FilePath        As String
   
7. Dim FullFileName    As String
   
8. 
   
9. Dim swDocName       As String
   
10. Dim swDocType       As Long
    
11. 
    
12. Dim fso             As New Scripting.FileSystemObject
    
13. Dim MYext           As String
    
14. 
    
15. Sub main()
    
16.     On Error Resume Next
    
17.     Set swApp = Application.SldWorks
    
18.     FilePath = InputBox("本程序将向指定路径下的模型文件填写“页码”属性。" & Chr(13) & "请输入或粘贴完整路径后按“确定”。")
    
19.     If FilePath = "" Then Exit Sub
    
20.     FilePath = FilePath & ""
    
21.     BatchFolder FilePath, ".SLDPRT", ".SLDASM", True
    
22. End Sub
    
23. 
    
24. '批量处理文件夹的递归过程
    
25. Sub BatchFolder(folder As String, ext As String, ext2 As String, silent As Boolean)
    
26.     Dim swModelDocExt As ModelDocExtension
    
27.     Dim swCustProp    As CustomPropertyManager
    
28.     Dim Page_Pre      As String
    
29.     Dim Page_Qty      As String
    
30.    
    
31.     If Right(folder, 1) <> "" Then folder = folder & ""
    
32.     ChDir (folder)
    
33.     PathName = Dir(folder)
    
34.    
    
35.     Page_Pre = InputBox("请输入页码的前缀再按“确定”，无前缀按任意键。")
    
36.     Page_Qty = 0    '页码递增基数
    
37.    
    
38.     Do Until PathName = ""
    
39.         FullFileName = folder & PathName
    
40.         MYext = Right(UCase$(PathName), 7)
    
41.         
    
42.         If MYext = ext Or MYext = ext2 Then    '如果这个文件类型是所需的，就进行处理
    
43.             swDocType = Switch(MYext = ".SLDPRT", swDocPART, MYext = ".SLDDRW", swDocDRAWING, MYext = ".SLDASM", swDocASSEMBLY, True, -1)
    
44.             Set swDoc = swApp.OpenDoc6(FullFileName, swDocType, swOpenDocOptions_Silent, "", longstatus, longwarnings)
    
45.             Set swDoc = swApp.ActiveDoc
    
46.             
    
47.             swDocName = Mid(swDoc.GetPathName, InStrRev(swDoc.GetPathName, "") + 1)
    
48.             swDocName = Left(swDocName, InStrRev(swDocName, ".") - 1)
    
49.             
    
50.             Page_Qty = Page_Qty + 1    '页码递增基数+1
    
51.             swDoc.DeleteCustomInfo2 "", ("底图张次")
    
52.             swDoc.AddCustomInfo3 "", ("底图张次"), 30, Page_Pre & Page_Qty
    
53.             swDoc.Save    '保存
    
54.             
    
55.             swApp.CloseDoc swDoc.GetTitle    '关闭文件
    
56.             
    
57.             Set swDoc = Nothing
    
58.         End If
    
59.         PathName = Dir
    
60.     Loop
    
61.    
    
62.     '如果有子文件夹，进行递归处理
    
63. '    Dim myFolder As folder
    
64. '    Dim mySub As folder
    
65. '
    
66. '    Set myFolder = fso.GetFolder(folder)
    
67. '    For Each mySub In myFolder.SubFolders
    
68. '        BatchFolder mySub.Path, ext, ext2, silent
    
69. '    Next
    
70. End Sub

复制代码

gdzsh 发表于 2018-3-1 16:07
遍历文件夹不适用吧？做设计总不可能文件价里面的零件全部都是装配体里面的零件吧？我的文件夹里面有不少 ...

窃以为遍历文件夹也是好的，把总装所属的零部件放在一个文件夹里，其它诸如标准件、外购件等等分好类，该放哪放哪，借用件跟随原所属总装存放，避免文件夹像个垃圾桶。

贡献值啊