AnsweredAssumed Answered

Macro Help: Open All Drawing or/and Part or_and Assembly In Folder and Save As

Question asked by Mateusz Urowski on Mar 22, 2020
Latest reply on Mar 23, 2020 by Fifi Riri

I have created a macro  that is supposed to do the following;


-Open a Folder Selection Box (where the user selects a folder)

-Open all  files in the selected folder (one by one, one after the other)

-Check to see if there is a folder called "customproperties" in the directory, if not then create one

-Save the open  file as a pdf/step, building the save as name from custom properties in the referenced model

-Close the file

-Move on to next one


Now in my code below (and I have attached the macro file because there is the browse folder module attached) the macro will complete one file, close the file and show the msgbox if that "customproperties" folder exists, if the folder does not exist it will create the folder, save the open file, close the drawing and fail on "filename = Dir" (run-time error '5')


If I comment out the "If Dir(saveFolder2, vbDirectory) = "" Then MkDir saveFolder2" it runs perfectly and saves the drawings all in the selected directory.


Can anyone please help me solve this? I need Yours help. I dont konw what is happend. Where did I make a mistake?


Dim swApp As Object
Dim longStatus As Long
Dim longWarning As Long
Dim openFolder, saveFolder, saveFolder2 As String
Dim newModelExtension, newDrawingExtension As String, newDrawing2Extension As String
Dim customProperty As String

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function

Sub SaveAs(swModel As ModelDoc2, filename As String)
Dim Errors As Long
Dim Warnings As Long
Dim value As Boolean


value = swModel.extension.SaveAs(filename, swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, Errors, Warnings)

End Sub

Function GetCustomProperty(swModel As ModelDoc2, propertyName As String) As String
GetCustomProperty = ""

Dim valueOut As String
Dim evaluatedOut As String
Dim wasResolved As Boolean
Dim result As Integer

result = swModel.extension.CustomPropertyManager("").Get5(propertyName, False, valueOut, evaluatedOut, wasResolved)

If result = 2 And wasResolved = True Then
GetCustomProperty = evaluatedOut
End If

End Function

Sub Convert(filePath As String, filename As String, propertyToAppend As String, propertyValue As String, covertReferences As Boolean)
Dim swModel As ModelDoc2
Dim propVal As String
Dim docType As swDocumentTypes_e
Dim newExtension As String
Dim newExtension2 As String
Dim newFilename As String
Dim Errors As Long

newFilename = filename
saveFolder2 = saveFolder

docType = GetDocType(filePath)

If docType = swDocNONE Then
GoTo Skip_File
End If

newExtension = GetNewExtension(docType)
newExtension2 = GetNewExtension2(docType)

' Open
Set swModel = swApp.OpenDoc6(filePath, docType, swOpenDocOptions_e.swOpenDocOptions_LoadModel, "", longStatus, longWarning)

If newExtension = ".stl" Or newExtension = ".igs" Or newExtension = ".step" Or newExtension = ".stp" Or newExtension = ".iges" Then
'Activate the doc in order to convert to IGES, STL and STEP
Set swModel = swApp.ActivateDoc3(filename + Right(filePath, 7), True, swRebuildOnActivation_e.swRebuildActiveDoc, Errors)
End If

If swModel Is Nothing Then
GoTo Skip_File
End If

' Append the custom property to the foldername
If Not propertyToAppend = "" Then
If propertyValue = "" Then
propVal = GetCustomProperty(swModel, propertyToAppend)

saveFolder2 = saveFolder2 & "\" & propVal

If Dir(saveFolder2, vbDirectory) = "" Then MkDir saveFolder2

' Force rebuild (ctrl + q)
swModel.ForceRebuild3 (False)

' Convert
SaveAs swModel, saveFolder2 & "\" & newFilename & newExtension
SaveAs swModel, saveFolder2 & "\" & newFilename & newExtension2


saveFolder2 = saveFolder2 & "\" & propVal

If Dir(saveFolder2, vbDirectory) = "" Then MkDir saveFolder2

' Force rebuild (ctrl + q)
swModel.ForceRebuild3 (False)

' Convert
SaveAs swModel, saveFolder2 & "\" & newFilename & newExtension
SaveAs swModel, saveFolder2 & "\" & newFilename & newExtension2

End If
End If

If covertReferences Then
Dim dependencies As Variant
dependencies = swModel.GetDependencies2(False, False, False)

For i = 0 To (UBound(dependencies) - 1) / 2
Convert "" + dependencies(2 * i + 1), "" + dependencies(2 * i), customProperty, propVal, False
Next i
End If

' Close
Set swModel = Nothing

swApp.CloseDoc filePath


End Sub

Function GetDocType(filename As String) As swDocumentTypes_e
Dim extension As String
extension = Right(filename, 3)

Select Case LCase(extension)
Case "drw"
GetDocType = swDocDRAWING

Case "prt"
GetDocType = swDocPART

Case "asm"
GetDocType = swDocASSEMBLY

Case Else
GetDocType = swDocNONE

End Select
End Function

Function GetNewExtension(docType As swDocumentTypes_e) As String
Select Case docType
GetNewExtension = newDrawingExtension

Case swDocPART
GetNewExtension = newModelExtension

GetNewExtension = newModelExtension

Case Else
GetNewExtension = ""

End Select
End Function
Function GetNewExtension2(docType As swDocumentTypes_e) As String
Select Case docType

GetNewExtension2 = newDrawing2Extension

Case Else
GetNewExtension2 = ""

End Select
End Function

Sub main()
Set swApp = Application.SldWorks

Dim UserForm As UserForm1: Set UserForm = New UserForm1

If UserForm.CancelButton.Cancel Then
Exit Sub
End If

openFolder = UserForm.OpenFolderTextBox.Text
saveFolder = UserForm.SaveFolderTextBox.Text
newModelExtension = UserForm.ConvertModeComboBox
newDrawingExtension = UserForm.ConvertDrawingComboBox
newDrawing2Extension = UserForm.ConvertDrawing2ComboBox

If UserForm.AppendRevisionCheckBox.value = True Then
customProperty = "DR-Material"
End If
If UserForm.Savedrawingsas2.value = True Then
newDrawing2Extension = UserForm.ConvertDrawing2ComboBox '----------------------------------????????????
End If

' Create the save to folder if it doesn't exist

If Dir(saveFolder, vbDirectory) = "" Then
MkDir (saveFolder)
End If

Dim filename As String
filename = Dir(openFolder & "\" & UserForm.FilterTextBox.Text)

Do While filename <> ""
' Convert the file
Convert openFolder & "\" & filename, Replace(filename, Right(filename, 7), ""), customProperty, "", UserForm.ConvertReferences.value

filename = Dir

MsgBox "Done!", , "Convert Files"
End Sub