求大神将此宏,改为装配体可以用

dyb9166

   经典图书

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

SolidWorks机械工程师网，顶一下。

3869

   经典图书

顶一下，坐等高手！

董东咚

SW机械工程师网，找到组织了！

Ivan1994

   经典案例图书

好东西，努力学习学习！

peng7s

可以在装配体下运行的啊 代码没有相关限制   Dim Part As SldWorks.PartDoc  Set Part = swModel  这段报错了 Dim Part As SldWorks.PartDoc  这段删掉或者注释掉就行了 sw2020

peng7s

   经典案例图书

1. Dim Part As SldWorks.PartDoc

复制代码

这段删掉

沉默的人

顶一下，坐等高手！