标题: 求大神将此宏,改为装配体可以用 [打印本页] 作者: dyb9166 时间: 2024-7-24 21:12 标题: 求大神将此宏,改为装配体可以用 Dim swApp As Object
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim Part As SldWorks.PartDoc
Dim vCustInfoNameArr2, vCustInfoName2 As Variant
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set Part = swModel
'删除所有属性
vCustInfoNameArr2 = swModel.GetCustomInfoNames
If Not IsEmpty(vCustInfoNameArr2) Then
For Each vCustInfoName2 In vCustInfoNameArr2
swModel.DeleteCustomInfo vCustInfoName2
Next
End If
CurCFGname = Part.GetConfigurationNames
CurCFGnameCount = Part.GetConfigurationCount
For i = 0 To CurCFGnameCount - 1
Set CusPropMgr = Part.Extension.CustomPropertyManager(CurCFGname(i))
Vnamearr = CusPropMgr.GetNames
If Not IsEmpty(Vnamearr) Then
For Each Vnamearr2 In Vnamearr
Part.DeleteCustomInfo2 CurCFGname(i), Vnamearr2
Next
End If
Next
'图号分离
swApp.ActiveDoc.ActiveView.FrameState = 1
Set CurCFG = Part.GetActiveConfiguration()
ConfName = CurCFG.Name
Name = swApp.ActiveDoc.GetTitle()
c = InStr(Name, " ") - 1 '重点:分隔标识符,这里是一个空格,也可用其他符号区分
If c > 0 Then
t = Left(Name, c)
b = Mid(Name, c + 2)
e = Right(Name, 7)
If e = ".SLDPRT" Or e = ".SLDASM" Or e = ".sldprt" Or e = ".sldasm" Then
j = Len(b) - 7 '消除后缀(区分大小写,即含4种)
Else
j = Len(b)
End If
s = Left(b, j)
Else
e = Right(Name, 7)
If e = ".SLDPRT" Or e = ".SLDASM" Or e = ".sldprt" Or e = ".sldasm" Then
j = Len(Name) - 7 '消除后缀(区分大小写,即含4种)
Else
j = Len(Name)
End If
t = Left(Name, j)
s = ""
End If
'swModel.AddCustomInfo3 "", "图号", swCustomInfoText, t
'swModel.AddCustomInfo3 "", "名称", swCustomInfoText, s
'设置属性,赋默认值
swModel.AddCustomInfo3 "", "图号", swCustomInfoText, t
swModel.AddCustomInfo3 "", "名称", swCustomInfoText, s
Part.EditRebuild3
swModel.Save
Set swApp = Application.SldWorks
End Sub
作者: huaxqhsb 时间: 2024-7-24 21:14
SolidWorks机械工程师网,顶一下。作者: 3869 时间: 2024-7-25 08:00
顶一下,坐等高手!作者: 董东咚 时间: 2024-7-25 08:49
SW机械工程师网,找到组织了!作者: Ivan1994 时间: 2024-7-25 09:24
好东西,努力学习学习!作者: peng7s 时间: 2024-7-25 14:40
可以在装配体下运行的啊 代码没有相关限制 Dim Part As SldWorks.PartDoc Set Part = swModel 这段报错了 Dim Part As SldWorks.PartDoc 这段删掉或者注释掉就行了 sw2020作者: peng7s 时间: 2024-7-25 14:43