' -----------------------------------------------------------

'批量重命名后批量保存

'程序说明：

'程序实现在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 & _

"运行前请先隐藏外购件！" & vbLf & 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("输入组件名","请输入组件名","")

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

str = "0" & str  '零件号尾部

end if

products1.Item(i).PartNumber= strName & "-" & str      '批量修改零件号

strPartNumber = products1.Item(i).PartNumber

products1.Item(i).name = strPartNumber & "." & 1

SaveToFile products1.Item(i), DocPath '保存重命名的文件

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 "文件已保存至该路径--->" & DocPath

End Sub

' -----------------------------------------------------------

' 文件保存路径

' -----------------------------------------------------------

Sub SaveToFile(oProduct, DocPath)

'loop inside the product

Dim i 'As Integer

Dim intIncrement 'As Integer

On Error Resume Next

oProduct.ReferenceProduct.Parent.SaveAs DocPath & "\" & oProduct.PartNumber

On Error GoTo 0

For i = 1 To oProduct.Products.Count

Set prdSubProduct = oProduct.Products.Item(i)

If prdSubProduct.HasAMasterShapeRepresentation() Then

Set prdRefProduct = prdSubProduct.ReferenceProduct

Set docSubDocument = prdRefProduct.Parent

strSubFullPath = docSubDocument.FullName

'identification of the component (CATPart or CATProduct)

Dim extension 'As String

If InStr(strSubFullPath, ".CATPart") Then

extension = ".CATPart"

Else

extension = ".CATProduct"

End If

docSubDocument.SaveAs DocPath & "\" & prdRefProduct.Name & extension

CATIA.DisplayFileAlerts = False

Else

Dim oSubSubProds 'As Products

Set oSubSubProds = prdSubProduct.Products

If oSubSubProds.Count > 0 Then

Call SaveToFile(prdSubProduct, DocPath)

End If

End If

Next

strSubFullPath =""

prdSubProduct =""

prdRefProduct =""

docSubDocument =""

oSubSubProds =""

folderpath =""

End Sub