宏-按顺序特征重命名

只看该作者 · 发表于 2018-6-11 15:18:30

ryouss 发表于 2018-6-10 10:14
如圖所示,請教pyczt大大是用什麼樣的簡体字型,用簡繁轉譯有些字型還是沒轉成!

以下代码我在简体系统下,控制面板中修改了语言区域导出,看能不能转换正常。

'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

复制代码

只看该作者 · 发表于 2018-6-11 17:24:44

pyczt 发表于 2018-6-11 15:00
原宏有缺陷,修改过的应该OK了,增加注释,供大家一起学习

還是不行,如圖就可.

只看该作者 · 发表于 2018-6-12 07:54:15

ryouss 发表于 2018-6-11 17:24
還是不行,如圖就可.

UTF-8格式的请试下

只看该作者 · 发表于 2018-6-12 10:42:35

pyczt 发表于 2018-6-12 07:54
UTF-8格式的请试下

也不行!

謝謝pyczt大大一再提供資料測試,
也知道了碰到這樣問題,可以直接copy譯成繁体再丟進VBA.

只看该作者 · 发表于 2018-6-12 12:31:27

ryouss 发表于 2018-6-11 17:24
還是不行,如圖就可.

请教这是什么工具，是否这工具的问题。

只看该作者 · 发表于 2018-6-12 13:22:53

本帖最后由 ryouss 于 2018-6-12 13:34 编辑

大鹿发表于 2018-6-12 12:31
请教这是什么工具，是否这工具的问题。

https://www.skycn.com/soft/appid/5797.html
繁簡字轉譯

謝謝鹿大關心,如上參考一直以來都是用這軟件解決VBA的繁簡字亂碼.

只看该作者 · 发表于 2018-6-12 13:41:31

ryouss 发表于 2018-6-12 13:22
https://www.skycn.com/soft/appid/5797.html
繁簡字轉譯

试过这工具，没有问题呀！

只看该作者 · 发表于 2018-6-12 14:13:56

本帖最后由 ryouss 于 2018-6-12 14:15 编辑

大鹿发表于 2018-6-12 13:41
试过这工具，没有问题呀！

是的COPY直接轉譯沒問題,
之前傻傻的COPY到VBA後再轉譯就不成,
但是之前也都是COPY諸大的宏到VBA後再轉譯都行(如12#),
所以才好奇想知道P大是用了什麼字型.

只看该作者 · 发表于 2018-6-16 14:16:16

如何使用？还有这是什么软件用的啊？

只看该作者 · 发表于 2018-9-26 22:58:01

特来支持

[分享] 宏-按顺序特征重命名

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源