宏-按顺序特征重命名

只看该作者 · 发表于 2018-6-8 09:18:35

马上注册，结交更多同行朋友，交流，分享，学习。

您需要登录才可以下载或查看，没有帐号？注册

x

以前搞过一个宏是英文名改中文的,有网友问能不能按顺序特征重命名.正好下载了一个,供大家分享.其中的语名值得学习

'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