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

标题: 求一键备份宏 [打印本页]
作者: david82    时间: 2021-12-17 00:39
标题: 求一键备份宏
因工作需要，求大神帮我制作个宏。
1：在当前工程图目录自动新建指定名字的文件夹（比如：XX模块新图上传受控）
2：在工程图模式下一键复制当前的工程图及对应的零件到这个文件夹里
3：如果已经有了这个文件夹，就直接存进去。如这个文件夹有同名的工程图、零件，就替换掉旧的。
4：不影响装配体的零件链接关系


谢谢！
作者: UDF998    时间: 2021-12-17 13:40
这个难度有点大，免费的应该没有，找大神有偿定制吧
作者: xiantong    时间: 2021-12-19 13:01
很不错，顶一下！
作者: xiaofly888    时间: 2021-12-20 15:46
顶一下，坐等高手！
作者: xiaofly888    时间: 2021-12-20 15:49
活到老学到老！
作者: Allate    时间: 2021-12-28 11:57
' ******************************************************************************
' 快速打包.swp - By Allate, 2021-12-28
' 说明：
' 1. 大部分代码源自VBA帮助文档Pack and Go an Assembly (VBA)
' 2. 默认打包到同一目录下的“打包”文件夹中（自动新建），也可以另外设定统一目录。
' 3. 代码的注释中，包含目录输入提示框，有需要的可以解除注释。
' 4. 如果打包的目录中已经有相应文件时，删除对应文件再打包（相当于覆盖文件）。
' ******************************************************************************

宏文件：
快速打包_2022-02-08.zip (7.85 KB, 下载次数: 72, 售价: 20 金币)
2022-02-08更新，把所有字母转为大写

作者: 刘茂机械    时间: 2022-1-3 17:45
楼主辛苦了！
作者: david82    时间: 2022-1-7 22:20
Allate 发表于 2021-12-28 11:57
' ******************************************************************************
' 快速打包.swp - B ...

感谢大神!!!!!!
作者: david82    时间: 2022-1-27 22:17
Allate 发表于 2021-12-28 11:57
' ******************************************************************************
' 快速打包.swp - B ...

大神，保存后名字变小写了，能帮忙改下吗，谢谢
作者: 淡淡的雲    时间: 2022-1-28 08:19
太有才了，膜拜中……
作者: Allate    时间: 2022-2-8 19:42
david82 发表于 2022-1-27 22:17
大神，保存后名字变小写了，能帮忙改下吗，谢谢

你可以重新下载附件，我更改为全大写了，得空再弄一个保持原有大小写的。
作者: nmgfjm    时间: 2022-2-9 08:52


黄金广告位招租

太有才了，膜拜中……
作者: Allate    时间: 2022-2-10 11:32
' ******************************************************************************
' 快速打包.swp - By Allate, 2022-02-10
' 说明：
' 1. 大部分代码源自VBA帮助文档Pack and Go an Assembly (VBA)
' 2. 默认打包到同一目录下的“打包”文件夹中（自动新建），也可以另外设定统一目录。
' 3. 代码的注释中，包含目录输入提示框，有需要的可以解除注释。
' 4. 如果打包的目录中已经有相应文件时，删除对应文件再打包（相当于覆盖文件）。
' 5. 保持打包前后文件名的大小写状态。
' ******************************************************************************


宏文件：
快速打包_2024-02-03.zip (13.6 KB, 下载次数: 180, 售价: 20 金币)

作者: lxr8833661    时间: 2022-2-10 12:42
Allate 发表于 2022-2-10 11:32
' ******************************************************************************
' 快速打包.swp - B ...

https://www.swbbsc.com/thread-356632-1-1.html，麻烦大神看看我的这个帖子被，谢谢
作者: 淡淡的雲    时间: 2022-2-11 08:08
活到老学到老！
作者: wwwerzhou    时间: 2022-2-17 09:17
SW机械工程师网，找到组织了！
作者: wwwerzhou    时间: 2022-2-17 11:54
很不错，找到组织了！
作者: clowery    时间: 2022-2-18 16:13
这个好像有点厉害的
作者: Alex_Wang    时间: 2022-3-29 09:02
打包时，当前装配体下存在子装配体，报错，希望大神再次帮忙优化一下，非常感谢！！
作者: SWding    时间: 2022-3-29 14:27
顶一下，坐等高手！
作者: UDF998    时间: 2022-4-13 19:47
顶一下，坐等高手！
作者: maxingjun20    时间: 2022-4-28 11:27
活到老学到老！
作者: 淡淡的雲    时间: 2022-5-5 15:45
太有才了，膜拜中……
作者: Alex_Wang    时间: 2022-5-13 09:14
Allate 发表于 2022-2-10 11:32
' ******************************************************************************
' 快速打包.swp - B ...

hello A神，这个打包的装配体里有几个子装配体的情况下会 报错，A神有空的时候帮忙研究一下，谢谢！
作者: snycef    时间: 2022-5-25 09:46
楼主太有才了，膜拜中……
作者: hhh001    时间: 2022-5-31 13:50
很不错，找到组织了！
作者: yun6yun7    时间: 2022-7-5 19:52
SW机械工程师网，找到组织了！
作者: hhh001    时间: 2022-7-21 07:07
SolidWorks机械工程师网，顶一下。
作者: wsh710904    时间: 2022-8-18 13:34
活到老学到老！学习了
作者: 184651474    时间: 2022-8-19 09:38
楼主太有才了，膜拜中……
作者: 184651474    时间: 2022-8-19 20:07
楼主辛苦了！
作者: 184651474    时间: 2022-8-19 20:09
很不错，顶一下！
作者: 184651474    时间: 2022-8-19 20:14
好好学习，天天向上！
作者: 184651474    时间: 2022-8-19 20:14
很不错，顶一下！
作者: 184651474    时间: 2022-8-19 20:15
好好学习，天天向上！
作者: 184651474    时间: 2022-8-19 20:16
楼主辛苦了！
作者: 184651474    时间: 2022-8-19 20:17
活到老学到老！
作者: 184651474    时间: 2022-8-19 20:18
很不错，找到组织了！
作者: 184651474    时间: 2022-8-19 20:20
活到老学到老！
作者: 184651474    时间: 2022-8-19 20:22
好好学习，天天向上！
作者: 184651474    时间: 2022-8-19 20:24
楼主太有才了，膜拜中……
作者: 184651474    时间: 2022-8-19 20:27
活到老学到老！
作者: 184651474    时间: 2022-8-19 21:16
楼主辛苦了！
作者: 184651474    时间: 2022-8-19 21:16
很不错，找到组织了！
作者: 184651474    时间: 2022-8-19 21:18
楼主太有才了，膜拜中……
作者: 184651474    时间: 2022-8-19 21:36
感谢楼主分享，很不错！
作者: 184651474    时间: 2022-8-20 10:21
楼主辛苦了！
作者: 184651474    时间: 2022-8-20 10:22
好好学习，天天向上！
作者: 184651474    时间: 2022-8-20 10:33
楼主太有才了，膜拜中……
作者: 184651474    时间: 2022-8-20 10:37
活到老学到老！
作者: 184651474    时间: 2022-8-21 10:35
楼主辛苦了！
作者: east2017    时间: 2022-9-27 10:28
不错的想法。我也想要
作者: east2017    时间: 2022-9-28 15:15
等待大佬，顶一下
作者: a785997392    时间: 2022-10-18 14:48
楼主，装配体有压缩零件打包会失败，请有空解决下，谢谢
作者: 184651474    时间: 2022-10-19 16:17
楼主辛苦了！
作者: ningxin4567    时间: 2022-12-5 08:16
版大辛苦了
作者: 烦心天使    时间: 2022-12-9 16:20
跪求更新版啊
SolidWorks原本打包 容易丢失零件，连接关系  断不干净
作者: zxt0824    时间: 2022-12-20 11:01
楼主辛苦了！
作者: zxt0824    时间: 2023-2-6 09:38
SW机械工程师网，找到组织了！
作者: zhangkai535356    时间: 2023-2-7 17:13
厉害，学习中
作者: yyy924    时间: 2023-6-7 11:04
顶一下，坐等高手！
作者: yyy924    时间: 2023-6-10 10:52
感谢楼主分享，很不错！
作者: 轩辕龙    时间: 2023-12-8 13:52
我的SW，打包经常漏东西，楼主 这个能全部打包吧
作者: 轩辕龙    时间: 2023-12-8 14:07
付了2次金币，还下载不了，怎么回事
作者: sunsu168    时间: 2023-12-26 16:10
Allate 发表于 2021-12-28 11:57
' ******************************************************************************
' 快速打包.swp - B ...

A大 ，可否改一版 ，只打包选中零件（带图） （ 支持多选）。  这样能比去文件夹搜索复制高效
作者: fcSW工程师    时间: 2023-12-27 09:57
Allate 发表于 2021-12-28 11:57
' ******************************************************************************
' 快速打包.swp - B ...

A大出手，一定就有，学习了学习了
作者: Allate    时间: 2024-2-3 16:37
sunsu168 发表于 2023-12-26 16:10
A大 ，可否改一版 ，只打包选中零件（带图） （ 支持多选）。  这样能比去文件夹搜索复制高效

理论上可以做到的，有空再弄
作者: 懒懒的高贵    时间: 2024-2-3 16:46
很不错，顶一下！
作者: Kerwin1314    时间: 2024-3-30 08:33
Allate 发表于 2022-2-10 11:32
' ******************************************************************************
' 快速打包.swp - B ...

老大，把选择位置弄出来会报错，是改的不对吗？

2024-03-30_083148.jpg

2024-03-30_083125.jpg
作者: Allate    时间: 2024-4-3 10:44
Kerwin1314 发表于 2024-3-30 08:33
老大，把选择位置弄出来会报错，是改的不对吗？

位置最后那里少了个“\”，你需要加一个判断，或者自己每次写的时候就加上这个符号
作者: Kerwin1314    时间: 2024-4-3 14:46
Allate 发表于 2024-4-3 10:44
位置最后那里少了个“\”，你需要加一个判断，或者自己每次写的时候就加上这个符号

好的，谢谢大佬
作者: Kerwin1314    时间: 2024-4-11 15:01
Allate 发表于 2022-2-10 11:32
' ******************************************************************************
' 快速打包.swp - B ...

Option Explicit
Dim swApp           As SldWorks.SldWorks
Dim swModel         As SldWorks.ModelDoc2

Sub main()
    Dim swModelDocExt   As SldWorks.ModelDocExtension
    Dim swPackAndGo     As SldWorks.PackAndGo
    Dim pgFileNames     As Variant
    Dim CompNames       As Variant
    Dim status          As Boolean
    Dim statuses        As Variant
    Dim FileName        As String
    Dim vFileName       As String
    Dim myPath          As String
    Dim i               As Integer
    Dim objshell        As Object
    Dim objFolder       As Object
    Dim path            As String

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    If swModel Is Nothing Then MsgBox "请打开模型或工程图再运行本宏！": End

    FileName = swModel.GetPathName
    If FileName = "" Then MsgBox "请保存文档后再运行本宏！": End

    Set swModelDocExt = swModel.Extension
    Set swPackAndGo = swModelDocExt.GetPackAndGo

    '打包的设置
    swPackAndGo.IncludeDrawings = True
    swPackAndGo.IncludeSimulationResults = True
    swPackAndGo.IncludeToolboxComponents = True
    swPackAndGo.FlattenToSingleFolder = True

    status = swPackAndGo.GetDocumentNames(pgFileNames)
    pgCompNames swModel, CompNames, FileName                    '获取名字列表
    pgFixNames pgFileNames, CompNames                           '修复名称的大小写
    status = swPackAndGo.SetDocumentSaveToNames(pgFileNames)

    '目录输入提示框
   ' myPath = InputBox("" & vbCrLf & vbCrLf & "请输入打包的位置：", "填写打包的目录", myPath)
    'If Not Len(myPath) > 0 Then Exit Sub

    Set objshell = CreateObject("Shell.Application")
    Set objFolder = objshell.BrowseForFolder(0, "请选择打包保存的位置", 0)
    If Not objFolder Is Nothing Then

        myPath = objFolder.Self.path

    Else

       If myPath = "" Then

        MsgBox ("请选择保存文件夹")

        Exit Sub

    End If

     End If

    '删除以前曾经打包过的文件
    For i = 0 To UBound(pgFileNames)
        vFileName = myPath & Right(pgFileNames(i), Len(pgFileNames(i)) - InStrRev(pgFileNames(i), "\"))
        If Dir(vFileName, 16) <> Empty Then Kill vFileName
    Next i

    status = swPackAndGo.SetSaveToName(True, myPath)
    statuses = swModelDocExt.SavePackAndGo(swPackAndGo)                 '打包

    MsgBox "打包结束！"
End Sub

'获取名字列表
Private Sub pgCompNames(swDoc As ModelDoc2, CompNames As Variant, FileName As String)
    Dim Components          As Variant
    Dim SingleComponent     As Variant
    Dim i                   As Integer
    Dim n                   As Integer

    ReDim CompNames(0)
    CompNames(0) = FileName
    i = 1
    If swDoc.GetType() = 2 Then
        swDoc.ResolveAllLightWeightComponents (True)
        Components = swModel.GetComponents(False)
        For Each SingleComponent In Components
            If SingleComponent.GetSuppression = 2 Then
                ReDim Preserve CompNames(i)
                CompNames(i) = SingleComponent.GetModelDoc().GetPathName
                i = i + 1
            End If
        Next
    End If
    CompNames = RemoveDuplicate(CompNames)                  '去重
End Sub

'去重
Private Function RemoveDuplicate(Rng As Variant) As Variant
    Dim i                   As Integer
    Dim Dic                 As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 0 To UBound(Rng)
        Dic(Rng(i)) = i
    Next i
    RemoveDuplicate = Dic.keys
End Function

'修复名称的大小写
Private Sub pgFixNames(pgFileNames As Variant, CompNames As Variant)
    Dim i                   As Integer
    Dim j                   As Integer

    For i = 0 To UBound(pgFileNames)
        For j = 0 To UBound(CompNames)
            If LCase(pgFileNames(i)) = LCase(CompNames(j)) Then
                pgFileNames(i) = CompNames(j)
                Exit For
            End If
            If j = UBound(CompNames) Then pgFileNames(i) = ""
        Next j
    Next i
End Sub
大佬，加了个文件选择报错，能帮看下吗





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