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

标题: 求part打包的VB代码 [打印本页]

作者: belibe 时间: 2022-7-30 14:49
标题: 求part打包的VB代码
本人在做一个宏，宏是在Excel表中的，最后一步打包的宏搞不定了，寻求帮助。目前零件已经打开(是part)，现在需要打包存储在当前Excel表所在文件夹下(工程图也要打包)，然后文件名和Excel表中Range("A" & N)单元格一致。不要用SolidWorks的宏给我，我们公司软件加密的，代码不能辅助，给我个word或者TXT都行。

作者: srl_mm 时间: 2022-8-1 16:38
顶一下，坐等高手！

作者: belibe 时间: 2022-8-3 12:35

作者: wetiuer 时间: 2022-8-3 13:31
楼主你最好把你Excel宏发出来，大家看了才好补充成你需要的。

作者: belibe 时间: 2022-8-3 14:00

wetiuer 发表于 2022-8-3 13:31
楼主你最好把你Excel宏发出来，大家看了才好补充成你需要的。

Sub 打包()
Dim Swapp As Object
Dim Part As Object
Dim Gtol As Object
Dim longstatus As Long
Dim longwarbings As Long
Dim boolstatus As Boolean
N = 1
Do Until ThisWorkbook.Sheets(1).Range("A" & N) = ""
WLBM = ThisWorkbook.Sheets(1).Range("A" & N)
Set Swapp = CreateObject("SldWorks.Application")
Set Part = Swapp.OpenDoc6(ThisWorkbook.Path & "\" & "零件.SLDPRT", 1, 0, "", longstatus, longwarbings)
Set Part = Swapp.ActiveDoc
bRet = Part.AddCustomInfo3("", "物料编码", 30, WLBM)

这里把打开的零件在当前文件夹下打包，文件名称改成和Range("A" & N) 一致


Swapp.CloseDoc  "零件.SLDPRT"
N = N + 1
Loop
End Sub

作者: wetiuer 时间: 2022-8-3 14:42

belibe 发表于 2022-8-3 14:00
Sub 打包()
Dim Swapp As Object
Dim Part As Object

参考SolidWorks官方API帮助示例如图一所示，在使用SavePackAndGo方法执行打包前，调用SetDocumentSaveToNames方法修改打包后的文件路径即可实现。

作者: belibe 时间: 2022-8-3 17:30

wetiuer 发表于 2022-8-3 14:42
参考SolidWorks官方API帮助示例如图一所示，在使用SavePackAndGo方法执行打包前，调用SetDocumentSav ...

就是没搞明白，所以求助

作者: belibe 时间: 2022-8-5 11:32
换了个方法，大致解决了目前的问题。但发现打包加前缀或者后缀，文件名会变成小写，怎么解决，有知道的没

作者: Allate 时间: 2022-8-9 10:11

belibe 发表于 2022-8-5 11:32
换了个方法，大致解决了目前的问题。但发现打包加前缀或者后缀，文件名会变成小写，怎么解决，有知道的没

使用笨一点的办法解决吧，代码见链接13楼
https://www.swbbsc.com/thread-342679-1-1.html

作者: belibe 时间: 2022-8-11 09:55

Allate 发表于 2022-8-9 10:11
使用笨一点的办法解决吧，代码见链接13楼
https://www.swbbsc.com/thread-342679-1-1.html

大神，这是我现在的代码，帮忙看看怎么能改成大写
Sub 打包()

Dim swApp As Object
Dim Part As Object
Dim Gtol As Object
Dim longstatus As Long
Dim longwarbings As Long
Dim boolstatus As Boolean
Dim swModelDoc As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swPackAndGo As SldWorks.PackAndGo
Dim status As Boolean
Dim statuses As Variant
Dim fullpath, myPath As String
N = 1
Do Until ThisWorkbook.Sheets(1).Range("A" & N) = ""
TH = Left(ThisWorkbook.Sheets(1).Range("A" & N), 6)
Name1 = ThisWorkbook.Sheets(1).Range("A" & N)
Name2 = Right(Name1, Len(Name1) - 6)
.....中间省略

Set swModelDoc = swApp.ActiveDoc
swModelDoc.Save
Set swModelDocExt = swModelDoc.Extension
Set swPackAndGo = swModelDocExt.GetPackAndGo
swPackAndGo.IncludeDrawings = True
swPackAndGo.IncludeToolboxComponents = True
fullpath = swModelDoc.GetPathName()
myPath = UCase(Left(fullpath, Len(fullpath) - 7))
swPackAndGo.AddSuffix = Name2

status = swPackAndGo.SetSaveToName(True, UCase(myPath))
myPath = UCase(myPath)
statuses = swModelDocExt.SavePackAndGo(swPackAndGo)



swApp.CloseDoc (ThisWorkbook.Path & "\" & TH & ".SLDPRT")
N = N + 1
Loop

End Sub

作者: fenzhi 时间: 2023-3-11 09:45
感谢楼主分享，很不错！

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