SolidWorks宏

lin105725366

Dim TopDocPathOnly As String

Dim swModel As SldWorks.ModelDoc2

Dim swApp As SldWorks.SldWorks

Dim longstatus As Long, longwarnings As Long

Sub main()

Set swApp = Application.SldWorks

Set TopDoc = swApp.ActiveDoc '總裝對象

If TopDoc.GetType <> 2 Then

    MsgBox ("Open Assembly")

    Exit Sub '不是裝配=退出

End If

TopDocPathSplit = Split(TopDoc.GetPathName, "") '分割

TopDocName = TopDocPathSplit(UBound(TopDocPathSplit)) '總裝文件名稱

Path_ = TopDoc.GetPathName

TopDocName = Left(TopDocName, Len(TopDocName) - 7) '總裝文件名稱（排除.SLDASM）

TopDocPathOnly = TopDocPathSplit(UBound(TopDocPathSplit) - 1) '總裝目錄名稱

TopConfString = TopDoc.GetActiveConfiguration.Name '總裝配置名稱

SubAsm TopDoc, TopConfString '遍歷

End Sub

Function SubAsm(AsmDoc, ConfString)

Dim name_ay() As String

Set swModel = swApp.ActiveDoc

Set Configuration = AsmDoc.GetConfigurationByName(ConfString)

Set RootComponent = Configuration.GetRootComponent

Components = RootComponent.GetChildren

For Each Child In Components '總裝抓全部零件名稱

    i = i + 1

    ReDim Preserve name_ay(i)

    Set ChildModel = Child.GetModelDoc

    ChildPathSplit = Split(Child.GetPathName, "") '分割

    ChildName = ChildPathSplit(UBound(ChildPathSplit)) '零件文件名稱

    name_ay(i) = Left(ChildName, Len(ChildName) - 7) '編號_名稱

    swModel.DeleteCustomInfo2 "", name_ay(i)

    swModel.AddCustomInfo2 name_ay(i), swCustomInfoText, """SW-Material@" & name_ay(i) & ".SLDPRT"""

Next

'~~~~~~~ parts_property ~~~~~~~

Dim longstatus As Long, longwarnings As Long

Dim retval As String

Set Part = swApp.ActiveDoc

path_name = Part.GetPathName

TopDocPathSplit = Split(path_name, "") '分割

TopDocName = TopDocPathSplit(UBound(TopDocPathSplit))

Path_ = Left(path_name, Len(path_name) - Len(TopDocName))

For n = 1 To i

    Set Part = swApp.OpenDoc6(Path_ & name_ay(n) & ".SLDPRT", 1, 0, "", longstatus, longwarnings)

    swApp.ActivateDoc2 name_ay(n) & ".SLDPRT", False, longstatus

    Set swModel = swApp.ActiveDoc

    '~~~ 注意 L1 設定 ~~~

    L1 = InStrRev(name_ay(n), "_", , 0) '編號_名稱是以 "_" 之符號分隔,可依需要更改所需之符號

    '~~~

    code_part = Left(name_ay(n), L1 - 1) ' 編號

    name_part = Right(name_ay(n), Len(name_ay(n)) - L1) '名稱

    retval = swModel.DeleteCustomInfo("材質")

    retval = swModel.AddCustomInfo3("", "材質", swCustomInfoText, """SW-Material@" & name_ay(n) & ".SLDPRT"""

    retval = swModel.DeleteCustomInfo("名稱")

    retval = swModel.AddCustomInfo3("", "名稱", swCustomInfoText, name_part)

    retval = swModel.DeleteCustomInfo("編號")

    retval = swModel.AddCustomInfo3("", "編號", swCustomInfoText, code_part)

    swModel.Save

    swApp.CloseDoc name_ay(n) & ".SLDPRT"

Next

End Function

样胜

66666666666666

qiminger

TopDocPathSplit = Split(TopDoc.GetPathName, "\") '分割

吉林晔华

没管用，哪里有问题？