宏-按顺序特征重命名 - iCAx开思网

'PYCZT2018/5/26下载于https://www.codestack.net
'This macro renames all the features in active model in the order, preserving the base names.
'该宏按顺序重命名活动模型中的所有特征名，保留原基本名称。
'Only indices are renamed and the base name is preserved. For example Sketch21 will be renamed to Sketch1 for
'the first appearance of the sketch feature.
'只有索引被重命名，基本名称被保留。例如，对于草图特性的第一次出现，Sketch 21将被重命名为Sketch 1.
'Notes注意事项:
'1.Only features with number at the end will be renamed (e.g. Front Plane will not be renamed to Front Plane1 and My1Feature will not be renamed)
'只在结尾处有编号的特征将被重命名(例如，Front Plane不会被重命名为Front Plane1，以及My1Feature也不会被重命名)
'2.Case is ignored (case insensitive search)
'大小写是忽略的
'3.Only modelling features are renamed (the ones created after the Origin feature)
'只重命名建模用的特征名(在原点特征之后的)
'*****************************************************************
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Dim passedOrigin As Boolean
passedOrigin = False
If Not swModel Is Nothing Then
Dim featNamesTable As Object
Dim processedFeats As Collection
Set featNamesTable = CreateObject("Scripting.Dictionary")
Set processedFeats = New Collection
featNamesTable.CompareMode = vbTextCompare 'case insensitive
Dim swFeat As SldWorks.Feature
Set swFeat = swModel.FirstFeature
While Not swFeat Is Nothing
If passedOrigin Then
If Not Contains(processedFeats, swFeat) Then
processedFeats.Add swFeat
RenameFeature swFeat, featNamesTable
End If
Dim swSubFeat As SldWorks.Feature
Set swSubFeat = swFeat.GetFirstSubFeature
While Not swSubFeat Is Nothing
If Not Contains(processedFeats, swSubFeat) Then
processedFeats.Add swSubFeat
RenameFeature swSubFeat, featNamesTable
End If
Set swSubFeat = swSubFeat.GetNextSubFeature
Wend
End If
If swFeat.GetTypeName2() = "OriginProfileFeature" Then
passedOrigin = True
End If
Set swFeat = swFeat.GetNextFeature
Wend
Else
MsgBox "Please open model"
End If
End Sub
Sub RenameFeature(feat As SldWorks.Feature, featNamesTable As Object)
Dim regEx As Object
Set regEx = CreateObject("VBScript.RegExp")
regEx.Global = True
regEx.IgnoreCase = True
regEx.Pattern = "(.+?)(\d+)$"
Dim regExMatches As Object
Set regExMatches = regEx.Execute(feat.Name)
If regExMatches.Count = 1 Then
If regExMatches(0).SubMatches.Count = 2 Then
Dim baseFeatName As String
baseFeatName = regExMatches(0).SubMatches(0)
Dim nextIndex As Integer
If featNamesTable.Exists(baseFeatName) Then
nextIndex = featNamesTable.item(baseFeatName) + 1
featNamesTable.item(baseFeatName) = nextIndex
Else
nextIndex = 1
featNamesTable.Add baseFeatName, nextIndex
End If
feat.Name = baseFeatName & nextIndex
End If
End If
End Sub
Function Contains(coll As Collection, item As Object) As Boolean
Dim i As Integer
For i = 1 To coll.Count
If coll.item(i) Is item Then
Contains = True
Exit Function
End If
Next
Contains = False
End Function

复制代码

'PYCZT2018/5/26下载于https://www.codestack.net,2018/6/11修改
'This macro renames all the features in active model in the order, preserving the base names.
'该宏按顺序重命名活动模型中的所有特征名，保留原基本名称。
'Only indices are renamed and the base name is preserved. For example Sketch21 will be renamed to Sketch1 for
'the first appearance of the sketch feature.
'只有索引被重命名，基本名称被保留。例如，对于第一次出现的草图特性Sketch21将被重命名为Sketch1.
'Notes注意事项:
'1.Only features with number at the end will be renamed (e.g. Front Plane will not be renamed to Front Plane1 and My1Feature will not be renamed)
'只在结尾处有编号的特征将被重命名(例如，Front Plane不会被重命名为Front Plane1，以及My1Feature也不会被重命名)---因为正则表达式为开始(任意字符)(任意数字)结束
'2.Case is ignored (case insensitive search)
'大小写是忽略的
'3.Only modelling features are renamed (the ones created after the Origin feature)
'只重命名建模用的特征名(在原点特征之后的)
'*****************************************************************
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Dim passedOrigin As Boolean '定义一个过原点的逻辑变量
passedOrigin = False
If Not swModel Is Nothing Then
Dim featNamesTable As Object
Dim processedFeats As Collection ' 定义为记录集合类(Collection)。
Set featNamesTable = CreateObject("Scripting.Dictionary") '变量为字典Dictionary对象
Set processedFeats = New Collection
featNamesTable.CompareMode = vbTextCompare '比较模式为字符串(不分大小写)
Dim swFeat As SldWorks.Feature
Set swFeat = swModel.FirstFeature
While Not swFeat Is Nothing
If passedOrigin Then
Debug.Print swFeat.Name
If Not Contains(processedFeats, swFeat) Then '比对特征记录集合与特征
processedFeats.Add swFeat '将特征增加到记录集合中
RenameFeature swFeat, featNamesTable '改名子程序
End If
Dim swSubFeat As SldWorks.Feature
Set swSubFeat = swFeat.GetFirstSubFeature '子特征
While Not swSubFeat Is Nothing
If Not Contains(processedFeats, swSubFeat) Then
processedFeats.Add swSubFeat
RenameFeature swSubFeat, featNamesTable
End If
Set swSubFeat = swSubFeat.GetNextSubFeature
Wend
End If
If swFeat.GetTypeName2() = "OriginProfileFeature" Then
OriginName = swFeat.Name '预留原点特征名,以后使用
passedOrigin = True
End If
Set swFeat = swFeat.GetNextFeature
Wend
'以下语名为已顺序的特征名去除后缀$
Set swFeat = swModel.FeatureByName(OriginName)
While Not swFeat Is Nothing
Set swFeat = swFeat.GetNextFeature
If Not swFeat Is Nothing Then
If Right(swFeat.Name, 1) = "$" Then swFeat.Name = Left(swFeat.Name, Len(swFeat.Name) - 1) '去除后缀$
End If
Wend
Else
MsgBox "Please open model请打开模型文件"
End If
End Sub
Sub RenameFeature(feat As SldWorks.Feature, featNamesTable As Object)
Dim regEx As Object
Set regEx = CreateObject("VBScript.RegExp") '创建正则表达式(RegEx)对象
regEx.Global = True '设置全程匹配
regEx.IgnoreCase = True '设置忽略区分大小写
regEx.Pattern = "(.+?)(\d+)$" '设置正则表达式:开始(任意字符)(任意数字)结束
Dim regExMatches As Object
Set regExMatches = regEx.Execute(feat.Name) '用于对指定正则表达式进行匹配检测，其值返回一个Matches集合，其中
'包含了所有检测到匹配的Match对象。如果没有检测到任何匹配则返回一个空的Matches集合
If regExMatches.Count = 1 Then
Debug.Print regExMatches(0)
If regExMatches(0).SubMatches.Count = 2 Then 'SubMatches数量为2,说明符合正则表达式
' SubMatches 集合包含了单个的子匹配字符串，只能用 RegExp 对象的 Execute 方法创建。
'SubMatches 集合的属性是只读的。运行一个正则表达式时，当圆括号中捕捉到子表达式时可以有零个或多个子匹配。
'SubMatches 集合中的每一项是由正则表达式找到并捕获的的字符串。
Dim baseFeatName As String
baseFeatName = regExMatches(0).SubMatches(0) '取正则表达式的第一个子匹配字符串,也就是基本特征名
'Debug.Print baseFeatName
Dim nextIndex As Integer
If featNamesTable.Exists(baseFeatName) Then '如果指定的键(基本特征名)存在，返回True，否则返回False,
nextIndex = featNamesTable.item(baseFeatName) + 1 'Items() 返回该键的条目数,增1
featNamesTable.item(baseFeatName) = nextIndex '将条目数赋值,即特征顺序号
Else
nextIndex = 1
featNamesTable.Add baseFeatName, nextIndex '增加键到字典Dictionary,条目数为1
End If
feat.Name = baseFeatName & nextIndex & "$" '原宏没有增加$后缀,可能造成改名失败
Debug.Print "已改名为:" & feat.Name
End If
End If
End Sub
Function Contains(coll As Collection, item As Object) As Boolean '(比对processedFeats特征记录集合与swFeat是否相同,以免子特征改名重复)
Dim i As Integer
Debug.Print "特征记录集合数量为" & coll.Count '记录集合数量
For i = 1 To coll.Count
Debug.Print "比对" & item.Name & " " & i
Debug.Print
If coll.item(i) Is item Then '记录中特征相同
Contains = True
Exit Function
End If
Next
Contains = False
End Function

复制代码

'PYCZT2018/5/26下载于https://www.codestack.net,2018/6/11修改
'This macro renames all the features in active model in the order, preserving the base names.
'该宏按顺序重命名活动模型中的所有特征名，保留原基本名称。
'Only indices are renamed and the base name is preserved. For example Sketch21 will be renamed to Sketch1 for
'the first appearance of the sketch feature.
'只有索引被重命名，基本名称被保留。例如，对于第一次出现的草图特性Sketch21将被重命名为Sketch1.
'Notes注意事项:
'1.Only features with number at the end will be renamed (e.g. Front Plane will not be renamed to Front Plane1 and My1Feature will not be renamed)
'只在结尾处有编号的特征将被重命名(例如，Front Plane不会被重命名为Front Plane1，以及My1Feature也不会被重命名)---因为正则表达式为开始(任意字符)(任意数字)结束
'2.Case is ignored (case insensitive search)
'大小写是忽略的
'3.Only modelling features are renamed (the ones created after the Origin feature)
'只重命名建模用的特征名(在原点特征之后的)
'*****************************************************************
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Dim passedOrigin As Boolean '定义一个过原点的逻辑变量
passedOrigin = False
If Not swModel Is Nothing Then
Dim featNamesTable As Object
Dim processedFeats As Collection ' 定义为记录集合类(Collection)。
Set featNamesTable = CreateObject("Scripting.Dictionary") '变量为字典Dictionary对象
Set processedFeats = New Collection
featNamesTable.CompareMode = vbTextCompare '比较模式为字符串(不分大小写)
Dim swFeat As SldWorks.Feature
Set swFeat = swModel.FirstFeature
While Not swFeat Is Nothing
If passedOrigin Then
Debug.Print swFeat.Name
If Not Contains(processedFeats, swFeat) Then '比对特征记录集合与特征
processedFeats.Add swFeat '将特征增加到记录集合中
RenameFeature swFeat, featNamesTable '改名子程序
End If
Dim swSubFeat As SldWorks.Feature
Set swSubFeat = swFeat.GetFirstSubFeature '子特征
While Not swSubFeat Is Nothing
If Not Contains(processedFeats, swSubFeat) Then
processedFeats.Add swSubFeat
RenameFeature swSubFeat, featNamesTable
End If
Set swSubFeat = swSubFeat.GetNextSubFeature
Wend
End If
If swFeat.GetTypeName2() = "OriginProfileFeature" Then
OriginName = swFeat.Name '预留原点特征名,以后使用
passedOrigin = True
End If
Set swFeat = swFeat.GetNextFeature
Wend
'以下语名为已顺序的特征名去除后缀$
Set swFeat = swModel.FeatureByName(OriginName)
While Not swFeat Is Nothing
Set swFeat = swFeat.GetNextFeature
If Not swFeat Is Nothing Then
If Right(swFeat.Name, 1) = "[ DISCUZ_CODE_0 ]quot; Then swFeat.Name = Left(swFeat.Name, Len(swFeat.Name) - 1) '去除后缀$
End If
Wend
Else
MsgBox "Please open model请打开模型文件"
End If
End Sub
Sub RenameFeature(feat As SldWorks.Feature, featNamesTable As Object)
Dim regEx As Object
Set regEx = CreateObject("VBScript.RegExp") '创建正则表达式(RegEx)对象
regEx.Global = True '设置全程匹配
regEx.IgnoreCase = True '设置忽略区分大小写
regEx.Pattern = "(.+?)(\d+)[ DISCUZ_CODE_0 ]quot; '设置正则表达式:开始(任意字符)(任意数字)结束
Dim regExMatches As Object
Set regExMatches = regEx.Execute(feat.Name) '用于对指定正则表达式进行匹配检测，其值返回一个Matches集合，其中
'包含了所有检测到匹配的Match对象。如果没有检测到任何匹配则返回一个空的Matches集合
If regExMatches.Count = 1 Then
Debug.Print regExMatches(0)
If regExMatches(0).SubMatches.Count = 2 Then 'SubMatches数量为2,说明符合正则表达式
' SubMatches 集合包含了单个的子匹配字符串，只能用 RegExp 对象的 Execute 方法创建。
'SubMatches 集合的属性是只读的。运行一个正则表达式时，当圆括号中捕捉到子表达式时可以有零个或多个子匹配。
'SubMatches 集合中的每一项是由正则表达式找到并捕获的的字符串。
Dim baseFeatName As String
baseFeatName = regExMatches(0).SubMatches(0) '取正则表达式的第一个子匹配字符串,也就是基本特征名
'Debug.Print baseFeatName
Dim nextIndex As Integer
If featNamesTable.Exists(baseFeatName) Then '如果指定的键(基本特征名)存在，返回True，否则返回False,
nextIndex = featNamesTable.item(baseFeatName) + 1 'Items() 返回该键的条目数,增1
featNamesTable.item(baseFeatName) = nextIndex '将条目数赋值,即特征顺序号
Else
nextIndex = 1
featNamesTable.Add baseFeatName, nextIndex '增加键到字典Dictionary,条目数为1
End If
feat.Name = baseFeatName & nextIndex & "[ DISCUZ_CODE_0 ]quot; '原宏没有增加$后缀,可能造成改名失败
Debug.Print "已改名为:" & feat.Name
End If
End If
End Sub
Function Contains(coll As Collection, item As Object) As Boolean '(比对processedFeats特征记录集合与swFeat是否相同,以免子特征改名重复)
Dim i As Integer
Debug.Print "特征记录集合数量为" & coll.Count '记录集合数量
For i = 1 To coll.Count
Debug.Print "比对" & item.Name & " " & i
Debug.Print
If coll.item(i) Is item Then '记录中特征相同
Contains = True
Exit Function
End If
Next
Contains = False
End Function

复制代码