Vba 创建文件夹并保存PDF
我有一个宏,应该执行以下操作: -打开文件夹选择框,用户在其中选择文件夹 -逐个打开选定文件夹中的所有图形文件 -检查目录中是否有名为PDF的文件夹,如果没有,则创建一个 -将打开的图形文件另存为pdf,从参照模型中的自定义特性生成另存为名称 -关闭图形 -继续下一个 现在,my code宏将完成一个图形,关闭图形并显示msgbox(如果该PDF文件夹存在),如果该文件夹不存在,则将创建文件夹,保存打开的图形,关闭图形并在sFileName=Dir时失败 如果我注释掉If DirPDFpath,vbDirectory=Then MkDir PDFpath并使PDFpath=currpath,它将完美运行并将所有图形保存在选定的目录中 如何创建该文件夹并将PDF保存到其中Vba 创建文件夹并保存PDF,vba,solidworks,Vba,Solidworks,我有一个宏,应该执行以下操作: -打开文件夹选择框,用户在其中选择文件夹 -逐个打开选定文件夹中的所有图形文件 -检查目录中是否有名为PDF的文件夹,如果没有,则创建一个 -将打开的图形文件另存为pdf,从参照模型中的自定义特性生成另存为名称 -关闭图形 -继续下一个 现在,my code宏将完成一个图形,关闭图形并显示msgbox(如果该PDF文件夹存在),如果该文件夹不存在,则将创建文件夹,保存打开的图形,关闭图形并在sFileName=Dir时失败 如果我注释掉If DirPDFpath,
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解决了这个问题 见下面的代码
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
我会使用FileSystemObject而不是Dir,因为您处理的是两个不同的文件夹。