求图号名称分离宏添加新代码 - iCAx开思网

'定义变数名称
Dim S1 As Integer
Dim S2 As Integer
Dim Path_Name As String
Dim Code_Name_C As String
Dim Code_ As String
Dim Name_ As String
Dim strmat As String
Dim Part As Object
Dim swApp As SldWorks.SldWorks
Dim swModelDoc As SldWorks.ModelDoc2
Dim swConfig As SldWorks.Configuration
Dim CustPropMgr As SldWorks.CustomPropertyManager
Dim swModel As SldWorks.ModelDoc2
Sub main()
Set swApp = Application.SldWorks
Set swModelDoc = swApp.ActiveDoc
Set swConfig = swModelDoc.ConfigurationManager.ActiveConfiguration
Set swModel = swApp.ActiveDoc
Set CustPropMgr = swModel.Extension.CustomPropertyManager(swModel.ConfigurationManager.ActiveConfiguration.Name) '配置特定的延伸设定
'设定变量
Path_Name = swApp.ActiveDoc.GetPathName '取得"路径名称及扩展名",不管扩展名是否隐藏
S1 = InStrRev(Path_Name, "") '\符号在路径的最后位置数
Code_Name_C = Right(Path_Name, Len(Path_Name) - S1) '取得"件号名称.扩展名"
S2 = InStr(Code_Name_C, " ") '符号在"件号名称扩展名"的位置数
Code_ = Left(Code_Name_C, S2 - 1) '取得"件号"
Name_ = Mid(Code_Name_C, S2 + 1, Len(Code_Name_C) - S2 - 7) '取得“名称”
strmat = Chr(34) + Trim("SW-Material" + "@@") + "@" + Code_Name_C + Chr(34) '材料属性
'删除栏
CustPropMgr.Delete ("代号")
CustPropMgr.Delete ("名称")
CustPropMgr.Delete ("材料")
'新增
CustPropMgr.Add2 "代号", swCustomInfoText, Code_
CustPropMgr.Add2 "名称", swCustomInfoText, Name_
CustPropMgr.Add2 "数量", swCustomInfoText, " "
CustPropMgr.Add2 "材料", swCustomInfoText, strmat
CustPropMgr.Add2 "单重", swCustomInfoText, " "
CustPropMgr.Add2 "总重", swCustomInfoText, " "
CustPropMgr.Add2 "备注", swCustomInfoText, " "
End Sub

复制代码