用宏来完成批量改名并另存
' -----------------------------------------------------------
'批量重命名后批量保存
'程序说明：
'程序实现在Product下，对第一层结构树内零件批量重命名，
'并将重命名后的零件以新零件名保存在当前路径下。
'程序运行前应先手动将不需要重命名的零部件隐藏（如外购件等）。
' -----------------------------------------------------------
Sub CATMain()
On Error Resume Next
Set rootDoc = CATIA.ActiveDocument
On Error GoTo 0
If TypeName(rootDoc) <> "ProductDocument" Then
MsgBox "错误！" & vbLf & _
"本程序仅能在Product下运行！" & vbLf & vbLf & _
"程序将被关闭！", vbOKOnly + vbCritical
Exit Sub
End If
MsgBox "注意！" & vbLf & _
"运行前请先隐藏外购件及标准件！", vbOKOnly + vbInformation
Set productDocument1 = CATIA.ActiveDocument
Set selection = productDocument1.Selection
Set visPropertySet = selection.VisProperties
Set product1 = productDocument1.Product
Set products1 = product1.Products
DocPath = productDocument1.Path '获取当前文档保存路径或改成你想要的路径
'初始化
strName = Inputbox("请输入产品编号"&chr(13)&chr(13)&"取消输入则退出","","401-0000")
If strName=False Then '取消命名则退出程序
Exit Sub
End If
j=0
k=0
'寻找相同的part，并隐藏
For m=1 to products1.Count-1
For n=m+1 to products1.Count
str1 = products1.Item(m).PartNumber
str2 = products1.Item(n).PartNumber
if (Instr(str1,str2)) Then
Set producti = products1.Item(n)
Set products1 = producti.Parent
selection.Add producti
Set visPropertySet = visPropertySet.Parent
visPropertySet.SetShow 1
selection.Clear
end if
Next
Next
'重命名
For i=1 to products1.Count
Set producti = products1.Item(i)
Set products1 = producti.Parent
selection.Add producti
Set visPropertySet = visPropertySet.Parent
visPropertySet.GetShow showstate
selection.Clear
If showstate <> 1 Then '隐藏为1
If not(Instr(products1.Item(i).PartNumber,strName)) Then
j=j+1
str = CStr(int(j))
if j<10 then
str = "0" & str
end if
if 10<j<=100 then
str = "0" & str '零件号尾部
end if
products1.Item(i).PartNumber= strName & "-" & str '批量修改零件号
strPartNumber = products1.Item(i).PartNumber
products1.Item(i).name = strPartNumber & "." & 1
'保存重命名的文件
CATIA.DisplayFileAlerts = False
products1.Item(i).ReferenceProduct.Parent.SaveAs DocPath & "\" & products1.Item(i).PartNumber
On Error Resume Next
CATIA.DisplayFileAlerts = False
end if
end if
Next
'寻找相同的part，并编号
k2=1
For m=1 to products1.Count-1
Set producti = products1.Item(m)
Set products1 = producti.Parent
selection.Add producti
Set visPropertySet = visPropertySet.Parent
visPropertySet.GetShow showstate
selection.Clear
If showstate <> 1 Then
For n=m+1 to products1.Count
str1 = products1.Item(m).PartNumber
str2 = products1.Item(n).PartNumber
If (Instr(str1,str2)) Then
k2=k2+1
products1.Item(n).name = str2 & "." & k2
End if
Next
' k2=1
End if
Next
Msgbox "所有文件已保存至--->" & vbLf & vbLf & DocPath
End Sub |
发表于 2013-10-22 14:26:03
QQ好友和群
QQ空间
腾讯微博
腾讯朋友
收藏
淘帖
赞一下！
发表于 2013-10-22 14:32:31
