在SolidWorks2022装配体中插入右栏设计库的零件，同时把零件及同名工程图同时复制...

dragon045

   经典图书

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Const LIBRARY_PATH = "D:\设计库\" ' 修改为实际库路径

Sub Main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    If Not IsAssembly(swModel) Then Exit Sub

    Dim comp As Component2
    For Each comp In GetComponents(swModel)
        ProcessComponent comp
    Next
End Sub

Function IsAssembly(doc As ModelDoc2) As Boolean
    IsAssembly = (doc.GetType = swDocumentTypes_e.swDocASSEMBLY)
    If Not IsAssembly Then MsgBox "请先打开装配体文件！"
End Function

Function GetComponents(doc As ModelDoc2) As Variant
    Dim vComps As Variant
    vComps = doc.GetComponents(True)
    GetComponents = vComps
End Function

Sub ProcessComponent(comp As Component2)
    If comp.IsVirtual Then Exit Sub

    Dim srcPath As String
    srcPath = comp.GetPathName

    If IsFromLibrary(srcPath) Then
        Dim destFolder As String
        destFolder = GetAssemblyFolder(swModel)

        ' 复制零件文件
        Dim prtDest As String
        prtDest = CopyFileWithRename(srcPath, destFolder)

        ' 查找并复制工程图
        CopyDrawing srcPath, destFolder

        ' 更新装配体引用（可选）
        swModel.ReplaceReferencedDocument srcPath, prtDest, False
    End If
End Sub

Function IsFromLibrary(path As String) As Boolean
    IsFromLibrary = (InStr(1, path, LIBRARY_PATH, vbTextCompare) > 0)
End Function

Function GetAssemblyFolder(doc As ModelDoc2) As String
    Dim fullPath As String
    fullPath = doc.GetPathName
    GetAssemblyFolder = Left(fullPath, InStrRev(fullPath, "\"))
End Function

Function CopyFileWithRename(src As String, destFolder As String) As String
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim baseName As String: baseName = fso.GetBaseName(src)
    Dim ext As String: ext = fso.GetExtensionName(src)

    Dim counter As Long: counter = 1
    Dim destPath As String
    Do
        destPath = destFolder & baseName & IIf(counter > 1, "_" & counter, "") & "." & ext
        counter = counter + 1
    Loop While fso.FileExists(destPath)

    fso.CopyFile src, destPath
    CopyFileWithRename = destPath
End Function

Sub CopyDrawing(prtPath As String, destFolder As String)
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim drwPath As String: drwPath = fso.BuildPath(fso.GetParentFolderName(prtPath), fso.GetBaseName(prtPath)) & ".SLDDRW"

    If fso.FileExists(drwPath) Then
        CopyFileWithRename drwPath, destFolder
    End If
End Sub

clj1426178706

很不错，顶一下！

suetee

   经典图书

没图，不知道是什么！

Yemao丶

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

cwzjd123

   经典案例图书

For Each comp In GetComponents(swModel)提示运行时错误424，要求对象

葛特曼

感谢楼主分享，很不错！

1215956038

   经典案例图书

感谢楼主分享，很不错！

184651474

For Each comp In GetComponents(swModel)提示运行时错误424，要求对象

Kerwin1314

楼主辛苦了！

lai8130356

   经典图书

有人用过吗？

葛特曼

写的不错没敢写

why2024

感谢楼主分享，很不错！

jian_w1@163.com

有人试过吗？

JCCFOREVER

这些代码怕不是AI写的吧

Kerwin1314

加入QQ群
参与讨论和学习

或扫描二维码加入

For Each comp In GetComponents(swModel)提示运行时错误424，要求对象

wjbg2019

   经典案例图书

感谢楼主分享，很不错！

Yemao丶

加入QQ群
参与讨论和学习

或扫描二维码加入

楼主很专业，写得很好！

dragon045

   经典案例图书

修改库路径：将代码中的LIBRARY_PATH改为实际设计库路径

创建快捷键：

工具 → 自定义 → 键盘

搜索"宏" → 分配快捷键（如Ctrl+Shift+C）

运行逻辑：

打开装配体文件

插入设计库零件

运行宏 → 自动完成：

✅ 识别库零件

✅ 复制零件到装配体目录

✅ 自动查找同名工程图并复制

✅ 智能处理重名文件

✅ 自动更新装配体引用（可选）