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

wwy9158

   经典图书

由于平时需要在工程图中填写页码（底图张次），于是在版大“【遍历宏】在总装配內零件的自定义属性写入配套数量”一贴的基础上修改为写入页码，页码是都填写出来，可是它不一定按总装设计树的顺序编号，有点随机，以下代码不知道能否修改一下，使得页码按总装设计树的顺序编号？请教各位大侠！







Dim TopDocPathOnly As String
Dim PartsCollect() As String '遍历清单（阵列）
Dim InCollectCount As Double '遍历清单长度
Dim CustomInfoQTY As String

'*******************************************************
Dim Page_Qty As String
Dim Page_Pre As String
Dim swApp As SldWorks.SldWorks
Dim swModelDoc As SldWorks.ModelDoc2
Dim swConfig As SldWorks.Configuration
Dim CustPrOPMgr As SldWorks.CustomPropertyManager

Sub main()

Answer = MsgBox("① 本程序将遍历装配体填写“页码”属性，请确认顶层装配体已保存！" & Chr(13) & "② 不在顶层装配体目录或子目录、压缩、轻化、虚拟、封套、不包括在BOM中的零部件不作处理。", vbOKCancel + 48)
If Answer = vbOK Then
Set swApp = Application.SldWorks 'SW对象
Set TopDoc = swApp.ActiveDoc '顶层装配体对象
If TopDoc.GetType  2 Then Exit Sub '如果不是装配体则退出
TopDocPathSplit = Split(TopDoc.GetPathName, "") '分割
TopDocName = TopDocPathSplit(UBound(TopDocPathSplit)) '顶层装配体文件名称
TopDocName = Left(TopDocName, Len(TopDocName) - 7) '顶层装配体文件名称（排除.SLDASM）
TopDocPathOnly = Mid(TopDoc.GetPathName, 1, InStrRev(TopDoc.GetPathName, "", -1)) '顶层装配体的完整目录
TopConfString = TopDoc.GetActiveConfiguration.Name '顶层装配体配置名称
CustomInfoQTY = "配套数量" '可根据需要改为其它
Page_Qty = 1 '页码递增基数
InCollectCount = 1 '遍历清单长度基数
ReDim PartsCollect(InCollectCount) '定义阵列项数
Else: Exit Sub
End If

'*******************************************************
Page_Pre = InputBox("输入页码前缀再按“确定”，无前缀请按任意键。")
Set TopCustPropMgr = TopDoc.Extension.CustomPropertyManager("")
TopCustPropMgr.Delete ("页码")
TopCustPropMgr.Add2 "页码", swCustomInfoText, Page_Pre & "" & "1" '指定顶层装配体的页码为“1”
'*******************************************************

SubAsm TopDoc, TopConfString '遍历

Beep '响铃

End Sub

Function SubAsm(AsmDoc, ConfString)

Set Configuration = AsmDoc.GetConfigurationByName(ConfString)
Set RootComponent = Configuration.GetRootComponent
Components = RootComponent.GetChildren
For Each Child In Components
Set ChildModel = Child.GetModelDoc
If Not (ChildModel Is Nothing) Then '排除压缩及轻化
ChildConfString = Child.ReferencedConfiguration '零件配置名称
ChildType = ChildModel.GetType
ChildPathSplit = Split(Child.GetPathName, "") '分割
ChildName = ChildPathSplit(UBound(ChildPathSplit)) '零件文件名称

ChildPathOnly = Mid(Child.GetPathName, 1, InStrRev(Child.GetPathName, "", -1)) '零件的完整目录
If ChildPathOnly = Replace(ChildPathOnly, TopDocPathOnly, "") Then SamePath = False Else SamePath = True '零件是否在顶层装配体目录或子目录中

If SamePath And (Not Child.ExcludeFromBOM) And (Not Child.IsEnvelope) Then '跳过：不在顶层装配体目录或子目录 及 不包括在BOM中 及 封套
'If (Not Child.ExcludeFromBOM) And (Not Child.IsEnvelope) Then '跳过：不包括在BOM中 及 封套
UNIT_OF_MEASURE_Name = ChildModel.CustomInfo2("", "UNIT_OF_MEASURE") '备用量属性名称
UNIT_OF_MEASURE = ChildModel.CustomInfo2("", UNIT_OF_MEASURE_Name) '备用量
If (UNIT_OF_MEASURE = 0) Or (UNIT_OF_MEASURE = "") Then UNIT_OF_MEASURE = 1 '备用量除错
inCollect = False '重置判断变量
For Each PartinCollect In PartsCollect '判断是否已在遍历清单内
If "" & "@" & ChildName = PartinCollect Then inCollect = True
Next
If inCollect Then '已在遍历清单内
' ht_Qty = ChildModel.CustomInfo2("", CustomInfoQTY) + 1 * UNIT_OF_MEASURE
' ChildModel.DeleteCustomInfo2 "", CustomInfoQTY
' ChildModel.AddCustomInfo3 "", CustomInfoQTY, 30, ht_Qty
Else '不在遍历清单内（首次处理）
' ChildModel.DeleteCustomInfo2 "", CustomInfoQTY
' ChildModel.AddCustomInfo3 "", CustomInfoQTY, 30, UNIT_OF_MEASURE
InCollectCount = InCollectCount + 1 '遍历清单长度基数+1
ReDim Preserve PartsCollect(InCollectCount) '重新定义阵列项数（保留内含数据）
PartsCollect(InCollectCount - 1) = "" & "@" & ChildName '加入到遍历清单中

'*******************************************************
Set CustPropMgr = ChildModel.Extension.CustomPropertyManager("")
Page_Qty = Page_Qty + 1
ChildModel.DeleteCustomInfo2 "", ("页码")
ChildModel.AddCustomInfo3 "", ("页码"), 30, Page_Pre & Page_Qty
'*******************************************************

ChildModel.SketchManager.Insert3DSketch True '插入3D草图，从而激活零件的“需存盘标签”
ChildModel.SketchManager.Insert3DSketch True '离开3D草图

End If
If ChildType = 2 Then
SubAsm ChildModel, ChildConfString '如果是装配体则向下遍历
End If

End If
End If
Next

End Function

复制代码

sjj988

顶起来，很实用的宏 复制代码运行报错

mengcole

   经典图书

请问报了什么错？

seaninter200

上传报错附件

panyunwen

   经典案例图书

俺好象看到脏话

lpz1111

页码是工程图的东东吧，怎么要写到零件属性？

wudongxiang1

   经典案例图书

奇怪！我这里运行正常啊，SW2017。

huanggang2

如附图明细栏最后一列所示，需要列出每个零部件的底图张次，就像普通自定义属性一样写在模型文件中的。

jxphklibin

我也是SW2017啊

lazyhaidao

   经典图书

我怎么没有发现有一点脏话的意思啊？

shizhf

俺指截图中的乱码

qinwei945

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

zhshspark

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

zhang1128

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

likerang

加入QQ群
参与讨论和学习

或扫描二维码加入

支持，解决支持

yangbaiyi

   经典案例图书

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

lnlzzhe

加入QQ群
参与讨论和学习

或扫描二维码加入

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

qwqwqw00

   经典案例图书

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

Dim swApp           As SldWorks.SldWorks
Dim swDoc           As SldWorks.ModelDoc2
Dim longstatus      As Long
Dim longwarnings    As Long
Dim PathName        As String
Dim FilePath        As String
Dim FullFileName    As String

Dim swDocName       As String
Dim swDocType       As Long

Dim fso             As New Scripting.FileSystemObject
Dim MYext           As String

Sub main()
    On Error Resume Next
    Set swApp = Application.SldWorks
    FilePath = InputBox("本程序将向指定路径下的模型文件填写“页码”属性。" & Chr(13) & "请输入或粘贴完整路径后按“确定”。")
    If FilePath = "" Then Exit Sub
    FilePath = FilePath & ""
    BatchFolder FilePath, ".SLDPRT", ".SLDASM", True
End Sub

'批量处理文件夹的递归过程
Sub BatchFolder(folder As String, ext As String, ext2 As String, silent As Boolean)
    Dim swModelDocExt As ModelDocExtension
    Dim swCustProp    As CustomPropertyManager
    Dim Page_Pre      As String
    Dim Page_Qty      As String
   
    If Right(folder, 1) <> &quot;&quot; Then folder = folder & &quot;&quot;
    ChDir (folder)
    PathName = Dir(folder)
   
    Page_Pre = InputBox(&quot;请输入页码的前缀再按“确定”，无前缀按任意键。&quot;)
    Page_Qty = 0    '页码递增基数
   
    Do Until PathName = &quot;&quot;
        FullFileName = folder & PathName
        MYext = Right(UCase$(PathName), 7)
        
        If MYext = ext Or MYext = ext2 Then    '如果这个文件类型是所需的，就进行处理
            swDocType = Switch(MYext = &quot;.SLDPRT&quot;, swDocPART, MYext = &quot;.SLDDRW&quot;, swDocDRAWING, MYext = &quot;.SLDASM&quot;, swDocASSEMBLY, True, -1)
            Set swDoc = swApp.OpenDoc6(FullFileName, swDocType, swOpenDocOptions_Silent, &quot;&quot;, longstatus, longwarnings)
            Set swDoc = swApp.ActiveDoc
            
            swDocName = Mid(swDoc.GetPathName, InStrRev(swDoc.GetPathName, &quot;&quot;) + 1)
            swDocName = Left(swDocName, InStrRev(swDocName, &quot;.&quot;) - 1)
            
            Page_Qty = Page_Qty + 1    '页码递增基数+1
            swDoc.DeleteCustomInfo2 &quot;&quot;, (&quot;底图张次&quot;)
            swDoc.AddCustomInfo3 &quot;&quot;, (&quot;底图张次&quot;), 30, Page_Pre & Page_Qty
            swDoc.Save    '保存
            
            swApp.CloseDoc swDoc.GetTitle    '关闭文件
            
            Set swDoc = Nothing
        End If
        PathName = Dir
    Loop
   
    '如果有子文件夹，进行递归处理
'    Dim myFolder As folder
'    Dim mySub As folder
'
'    Set myFolder = fso.GetFolder(folder)
'    For Each mySub In myFolder.SubFolders
'        BatchFolder mySub.Path, ext, ext2, silent
'    Next
End Sub

复制代码

0011312

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

harold1982

贡献值啊