0

次のことを行うマクロがあります。

-フォルダー選択ボックスを開く (ユーザーがフォルダーを選択する場所)

-選択したフォルダ内のすべての図面ファイルを開きます (1 つずつ、1 つずつ)

-ディレクトリに「PDF」というフォルダがあるかどうかを確認し、ない場合は作成します

-開いている図面ファイルを pdf として保存し、参照モデルのカスタム プロパティから名前を付けて保存を作成します。

-図面を閉じる

-次に進みます

これで、私のコード マクロは 1 つの図面を完成させ、図面を閉じて、その "PDF" フォルダーが存在する場合は msgbox を表示します。フォルダーが存在しない場合は、フォルダーを作成し、開いている図面を保存し、図面を閉じて、"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
4

1 に答える 1

0

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
于 2015-09-02T01:29:11.837 に答える