在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

dragon045

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

创建快捷键：

工具 → 自定义 → 键盘

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

运行逻辑：

打开装配体文件

插入设计库零件

运行宏 → 自动完成：

✅ 识别库零件

✅ 复制零件到装配体目录

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

✅ 智能处理重名文件

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

Yemao丶

   经典图书

楼主很专业，写得很好！

wjbg2019

感谢楼主分享，很不错！

Kerwin1314

   经典案例图书

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

JCCFOREVER

这些代码怕不是AI写的吧

jian_w1@163.com

   经典案例图书

有人试过吗？

why2024

感谢楼主分享，很不错！

葛特曼

写的不错没敢写

lai8130356

   经典图书

有人用过吗？

Kerwin1314

楼主辛苦了！

184651474

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

1215956038

感谢楼主分享，很不错！

葛特曼

感谢楼主分享，很不错！

cwzjd123

加入QQ群
参与讨论和学习

或扫描二维码加入

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

Yemao丶

   经典案例图书

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

suetee

加入QQ群
参与讨论和学习

或扫描二维码加入

没图，不知道是什么！

clj1426178706

   经典案例图书

很不错，顶一下！