Создать папку и сохранить PDF

Question

У меня есть макрос, который должен делать следующее;

-Open Selection Box Folder (где пользователь выбирает папку)

-open все чертежные файлы в выбранной папке (один на один, один за другим)

-Check видеть если есть папка под названием «PDF» в каталоге, если нет, то создать один

-Save открытого файла чертеж в формате PDF, строительство сохранения как имя из пользовательских свойств в указанной модели

-Ряд чертеж

-Move на следующий

Теперь мой код макро завершит один рисунок, закрыть рисунок и показать MsgBox, если эта папка «PDF» существует, если папка не существует, она будет создана папка, сохранить открытый чертеж, закрыть чертеж и выйти из строя на «sFileName = Dir»

Если я прокомментирую «If Dir (PDFpath, vbDirectory) =» «Тогда 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 

Answer 1

Я решил это с помощью файловой системы.

См. Код ниже;

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 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 PartNoDes  As String 
Dim FSO    As Object 
Dim FolderPath  As String 
Dim strquotes(110) As String 
Dim lngIndex  As Long 

Sub main() 
    Set swApp = Application.SldWorks 
    Path = BrowseFolder("Select a Path/Folder") 
    Path = Path + "\" 
    PDFpath = Path & "PDF" 

    Set FSO = CreateObject("scripting.filesystemobject") 

    FolderPath = PDFpath 
    If Right(FolderPath, 1) <> "\" Then 
     FolderPath = FolderPath & "\" 
    End If 

    If FSO.FolderExists(FolderPath) = False Then 
     MkDir (PDFpath) 
    Else 
     'MsgBox "Folder exist" 
    End If 

    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 

     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 drawings in " & Path & " saved as PDF!" & vbNewLine & vbNewLine & "Lormanism of the day :" & vbNewLine & strquotes(lngIndex)) 

End Sub