|
|
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
大佬，加了个文件选择报错，能帮看下吗
|
|
[复制链接]
发表于 2023-6-7 11:04:28
发表于 2024-2-3 16:37:20
鲁公网安备 37028502190335号