麻烦增加一个同时导出DWG

doszmw · 发表于 2024-5-31 11:36:18

每页工程图保存为一个单独pdf，希望增加一个同时导出dwg，同时增加保存位置为工程图所在文件夹里新建一个文件夹

doszmw · 发表于 2024-5-31 11:38:51

Option Explicit
Dim swApp As SldWorks.SldWorks
Dim part As SldWorks.ModelDoc2
Dim swSheet As SldWorks.Sheet
Dim vSheetNames As Variant
Dim swExportPDFData As SldWorks.ExportPdfData
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim SheetCount As Integer
Dim boolstatus As Boolean
Dim i As Long
Dim Foldname As String
Dim PDFname As String
Dim lErrors As Long
Dim lWarnings As Long
Dim AllSheetName
Dim SheetProperty
Sub main()

Foldname = "D:\Desktop\导图\"
'指定PDF保存目录手动改写
Set swApp = Application.SldWorks
swApp.Visible = True
Set part = swApp.ActiveDoc
Set swModelDocExt = part.Extension
Set swExportPDFData = swApp.GetExportFileData(1)
SheetCount = part.GetSheetCount
AllSheetName = part.GetSheetNames
For i = 0 To SheetCount - 1
part.ActivateSheet (AllSheetName(i))
Set swSheet = part.GetCurrentSheet
SheetProperty = swSheet.GetProperties
PDFname = Foldname & AllSheetName(i) & ".dwg"
vSheetNames = AllSheetName
boolstatus = swExportPDFData.SetSheets(swExportData_ExportCurrentSheet, vSheetNames)
swExportPDFData.ViewPdfAfterSaving = True

boolstatus = swModelDocExt.SaveAs(PDFname, 0, 0, swExportPDFData, lErrors, lWarnings)
Next i
End Sub

董东咚 · 发表于 2024-5-31 13:39:57

经典图书

就一个宏的事嘛。我就有一键转PDF/DWG/STEP

doszmw · 发表于 2024-5-31 14:57:58

董东咚发表于 2024-5-31 13:39
就一个宏的事嘛。我就有一键转PDF/DWG/STEP

就是找这个宏，要把带零件设计表的工程图每一页导出dwg和pdf

doszmw · 发表于 2024-5-31 14:59:04

经典案例图书

大佬改一下很简单，外行就费劲了

kaogeshishen · 发表于 2024-6-22 11:16:27

试试是否满足

ylwsmyyy · 发表于 2024-6-23 15:36:43

经典案例图书

你用这个宏试一下看看满足你要求不。

doszmw · 发表于 2024-6-24 09:54:10

多谢各位，不求宏了，上面宏主要用于零件设计表设计零件，用外行的方法改一下自己用了，把代码pdf改为dwg即可，相对于自带导出区别，每个导出文件名字是每个图纸名称

doszmw · 发表于 2024-6-24 09:55:57

pdf改为dwg，多一个宏，多点一下了

doszmw · 发表于 2024-6-25 10:39:12

经典图书

搞定了，分享一下，纯外行找不同，有高手可以指点一下
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim part As SldWorks.ModelDoc2
Dim swSheet As SldWorks.Sheet
Dim vSheetNames As Variant
Dim swExportPDFData As SldWorks.ExportPdfData
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim SheetCount As Integer
Dim boolstatus As Boolean
Dim i As Long
Dim Foldname As String
Dim PDFname As String
Dim DWGname As String
Dim lErrors As Long
Dim lWarnings As Long
Dim AllSheetName
Dim SheetProperty
Sub main()

Foldname = "D:\Desktop\导图\"
'指定PDF保存目录手动改写
Set swApp = Application.SldWorks
swApp.Visible = True
Set part = swApp.ActiveDoc
Set swModelDocExt = part.Extension
Set swExportPDFData = swApp.GetExportFileData(1)
SheetCount = part.GetSheetCount
AllSheetName = part.GetSheetNames
For i = 0 To SheetCount - 1
part.ActivateSheet (AllSheetName(i))
Set swSheet = part.GetCurrentSheet
SheetProperty = swSheet.GetProperties
PDFname = Foldname & AllSheetName(i) & ".pdf"
DWGname = Foldname & AllSheetName(i) & ".dwg"
vSheetNames = AllSheetName
boolstatus = swExportPDFData.SetSheets(swExportData_ExportCurrentSheet, vSheetNames)
swExportPDFData.ViewPdfAfterSaving = True

boolstatus = swModelDocExt.SaveAs(PDFname, 0, 0, swExportPDFData, lErrors, lWarnings)
boolstatus = swModelDocExt.SaveAs(DWGname, 0, 0, swExportPDFData, lErrors, lWarnings)
Next i
End Sub

沉默的人 · 发表于 2024-6-25 13:36:20

感谢楼主分享，很不错！

穿拖鞋开车 · 发表于 2024-7-13 08:08:12

感谢楼主分享，很不错！

		自动登录	找回密码
密码			立即注册

麻烦增加一个同时导出DWG

最佳新人

活跃会员

热心会员

宣传达人

灌水之王

突出贡献