顶一下，坐等高手！
感谢楼主分享，很不错！
我的SW，打包经常漏东西，楼主 这个能全部打包吧
付了2次金币，还下载不了，怎么回事
Allate 发表于 2021-12-28 11:57
' ******************************************************************************
' 快速打包.swp - B ...
A大 ，可否改一版 ，只打包选中零件（带图） （ 支持多选）。这样能比去文件夹搜索复制高效{:2_31:}
Allate 发表于 2021-12-28 11:57
' ******************************************************************************
' 快速打包.swp - B ...
A大出手，一定就有，学习了学习了
sunsu168 发表于 2023-12-26 16:10
A大 ，可否改一版 ，只打包选中零件（带图） （ 支持多选）。这样能比去文件夹搜索复制高效
理论上可以做到的，有空再弄
很不错，顶一下！
Allate 发表于 2022-2-10 11:32
' ******************************************************************************
' 快速打包.swp - B ...
老大，把选择位置弄出来会报错，是改的不对吗？
Kerwin1314 发表于 2024-3-30 08:33
老大，把选择位置弄出来会报错，是改的不对吗？
位置最后那里少了个“\”，你需要加一个判断，或者自己每次写的时候就加上这个符号
Allate 发表于 2024-4-3 10:44
位置最后那里少了个“\”，你需要加一个判断，或者自己每次写的时候就加上这个符号
好的，谢谢大佬
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机械工程师网，顶一下。
好好学习，天天向上！