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
Invalid:
'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
swModel.ViewZoomtofit2
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
Else
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
Skip_File:
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
Case swDocDRAWING
GetNewExtension = newDrawingExtension
Case swDocPART
GetNewExtension = newModelExtension
Case swDocASSEMBLY
GetNewExtension = newModelExtension
Case Else
GetNewExtension = ""
End Select
End Function
Function GetNewExtension2(docType As swDocumentTypes_e) As String
Select Case docType
Case swDocDRAWING
GetNewExtension2 = newDrawing2Extension
Case Else
GetNewExtension2 = ""
End Select
End Function
Sub main()
Set swApp = Application.SldWorks
Dim UserForm As UserForm1: Set UserForm = New UserForm1
UserForm.Show
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
Loop
MsgBox "Done!", , "Convert Files"
End Sub
SolidworksApi/macros