iCAx开思网

标题: 谁有CATIA批量改名的宏程序啊 [打印本页]

作者: zzx211402 时间: 2017-7-28 20:45
标题: 谁有CATIA批量改名的宏程序啊
谁有CATIA批量改名的宏程序啊？

作者: lhy123606 时间: 2018-3-12 14:52
' -----------------------------------------------------------
'批量重命名后批量保存
'程序说明：
'程序实现在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<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

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

作者: mingbincool 时间: 2018-10-30 22:05
有否替换字符串批量改名方法？

作者: chenpan1992 时间: 2018-11-12 11:49
这个好像是重新命名宏，没法替换其中摸一个字符

作者: seanyu2016 时间: 2018-11-13 00:04
正好是我需要的

欢迎光临 iCAx开思网 (https://www.icax.org/)