SolidWorks机械工程师网——最大的SolidWorks学习平台

标题: 求大神将此宏,改为装配体可以用 [打印本页]

作者: 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

'设置单位为"自定义"
swModel.Extension.SetUserPreferenceInteger 263, 0, 4       '设置单位为"自定"
swModel.Extension.SetUserPreferenceInteger 259, 0, 3       '最后一个值，1毫克，2克，3千克，4镑
swModel.Extension.SetUserPreferenceInteger 258, 0, 2       '长度
swModel.Extension.SetUserPreferenceInteger 260, 0, 6       '体积
swModel.ClearSelection2 True
swModel.Save '存档

'图号分离
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

Dim Part As SldWorks.PartDoc

复制代码

这段删掉

作者: 沉默的人 时间: 2024-7-25 16:16
顶一下，坐等高手！

欢迎光临 SolidWorks机械工程师网——最大的SolidWorks学习平台 (https://www.swbbsc.com/)