У меня есть макрос, который должен делать следующее:
-Откройте окно выбора папки (где пользователь выбирает папку)
-Открыть все файлы чертежей в выбранной папке (один за другим, один за другим)
-Проверьте, есть ли в каталоге папка с именем «PDF», если нет, то создайте ее.
- Сохраните открытый файл чертежа в формате pdf, создав имя для сохранения из пользовательских свойств в модели, на которую ссылаются.
-Закрыть рисунок
-Перейти к следующему
Теперь мой макрос кода завершит один рисунок, закроет рисунок и покажет окно сообщения, если эта папка «PDF» существует, если папка не существует, он создаст папку, сохранит открытый рисунок, закроет рисунок и завершится ошибкой на «sFileName = Реж.
Если я закомментирую "If Dir(PDFpath, vbDirectory) = "" Then MkDir PDFpath" и сделаю "pdfpath=currpath", он будет работать отлично и сохранит все рисунки в выбранном каталоге.
Как мне создать эту папку и сохранить в нее PDF-файлы?
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc
Dim swDraw As SldWorks.DrawingDoc
Dim swCustProp As CustomPropertyManager
Dim swView As SldWorks.View
Dim sFileName As String
Dim vFileName As String
Dim Path As String
Dim nPath As String
Dim nErrors As Long
Dim nWarnings As Long
Dim ConfigName As String
Dim i As Long
Dim valOut1 As String
Dim valOut2 As String
Dim resolvedValOut1 As String
Dim resolvedValOut2 As String
Dim PartNo As String
Dim nFileName As String
Dim swDocs As Variant
Dim PDFpath As String
Dim currpath As String
Dim PartNoDes As String
Sub main()
Set swApp = Application.SldWorks
Path = BrowseFolder("Select a Path/Folder")
Path = Path + "\"
sFileName = Dir(Path & "*.slddrw")
Do Until sFileName = ""
Set swModel = swApp.OpenDoc6(Path + sFileName, swDocDRAWING, swOpenDocOptions_Silent, "", nErrors, nWarnings)
Set swModel = swApp.ActiveDoc
Set swDraw = swApp.ActiveDoc
Set swView = swDraw.GetFirstView
Set swView = swView.GetNextView
Set swModel = swView.ReferencedDocument
currpath = Left(swDraw.GetPathName, InStrRev(swDraw.GetPathName, "\"))
PDFpath = currpath & "PDF"
If Dir(PDFpath, vbDirectory) = "" Then MkDir PDFpath
If swModel.GetType = swDocPART Then
PartNoDes = Mid(swDraw.GetPathName, InStrRev(swDraw.GetPathName, "\") + 1)
PartNoDes = Right(PartNoDes, Len(PartNoDes) - 14)
PartNoDes = Left(PartNoDes, Len(PartNoDes) - 7)
PartNo = Mid(swModel.GetPathName, InStrRev(swModel.GetPathName, "\") + 1)
PartNo = Left(PartNo, Len(PartNo) - 7)
Set swCustProp = swModel.Extension.CustomPropertyManager(swView.ReferencedConfiguration)
ConfigName = swView.ReferencedConfiguration
swCustProp.Get2 "Description", valOut1, resolvedValOut1
swCustProp.Get2 "Revision", valOut2, resolvedValOut2
nFileName = PDFpath & "\" & PartNo & "-" & ConfigName & "-" & resolvedValOut2 & " " & PartNoDes
swDraw.SaveAs3 nFileName & ".PDF", 0, 0
ElseIf swModel.GetType = swDocASSEMBLY Then
PartNoDes = Mid(swDraw.GetPathName, InStrRev(swDraw.GetPathName, "\") + 1)
PartNoDes = Right(PartNoDes, Len(PartNoDes) - 11)
PartNoDes = Left(PartNoDes, Len(PartNoDes) - 7)
PartNo = Mid(swModel.GetPathName, InStrRev(swModel.GetPathName, "\") + 1)
PartNo = Left(PartNo, Len(PartNo) - 7)
Set swCustProp = swModel.Extension.CustomPropertyManager("")
swCustProp.Get2 "Description", valOut1, resolvedValOut1
swCustProp.Get2 "Revision", valOut2, resolvedValOut2
nFileName = PDFpath & "\" & PartNo & "-" & resolvedValOut2 & " " & PartNoDes
swDraw.SaveAs3 nFileName & ".PDF", 0, 0
End If
swApp.QuitDoc swDraw.GetPathName
Set swDraw = Nothing
Set swModel = Nothing
sFileName = Dir
Loop
MsgBox "All Done"
End Sub
FileSystemObject
вместоDir
, так как вы имеете дело с двумя разными папками. - person PatricK   schedule 01.09.2015