Hello, I am relatively new to macros and have been trying to create a slightly complex macro that:
1. Updates custom fields of an open part depending on whether they exist, and what value they have.
2. Opens the drawing for said part and
If it exists:
Updates the drawing template based on the sheet name, removes the BOM and saves the changes.If it doesn't exist:
Creates a new drawing based on a drawing template, it inserts the part into some predefined views and saves the newly created drawing.
I have no issues with this macro if the drawing already exists. However, if the drawing does not exist it is showing me an error and is not saving the newly created document. I have tried to use SaveAs3 as well as Save3 but I can't seem to get it working.
Thank you in advance, any help is much appreciated.
The macro:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Sub main()
'Declare loval variables for this sub-routine
Dim lErrors As Long
Dim lWarnings As Long
Dim lConfResponse As Long
Dim bForceRebuild As Boolean
Dim bQuietSaveResult As Boolean
Dim sVal As String
Dim lRetCode As Long 'For swCustPropMgr.Get6
Dim sResolvedVal As String 'For custom property values
Dim bWasResolved As Boolean 'For custom property Get6 method
Dim bLinkToProp As Boolean 'For custom property Get6 method
Dim swDrawingDoc As SldWorks.DrawingDoc 'Declare DrawingDoc for activation !!!
'Get the Solidworks application object
Set swApp = Application.SldWorks
'Get the active Solidworks document
Set swModel = swApp.ActiveDoc
'----- Initial Checks -----
'Check that a document is open
If swModel Is Nothing Then
'swApp.SendMsgToUser2 "No solidworks document is open. Please open a Part document.", swMbStop, swMbOk
Debug.Print "No SolidWorks document is open.Exiting." '!!!
Exit Sub
End If
'Check that the document open is a part
If swModel.GetType() <> swDocumentTypes_e.swDocPART Then 'And swModel.GetType() <> swDocumentTypes_e.swDocASSEMBLY
'swApp.SendMsgToUser2 "The active document is not a Part. Please open a Part to continue.", swMbStop, swMbOk
Debug.Print "the active document is not a Part. Exiting." '!!!
Exit Sub
End If
'Get the ModelDocExtension and CustomPropertyManager
Set swModelDocExt = swModel.Extension
Set swCustPropMgr = swModelDocExt.CustomPropertyManager("") 'Empty string to get a document-level property
'----- Ask for confirmation that the part wants to be updated -----
'lConfResponse = swApp.SendMsgToUser2("Do you want to continue updating the current Part and its corresponding drawing to the latest Template?", swMbQuestion, swMbYesNo)
'If lConfResponse = swMbHitNo Then
'swApp.SendMsgToUser2 "Update cancelled.", swMbInformation, swMbOk
'Exit Sub
'End If
'----- Update Custom Properties -----
'Ensure custom properties exist and add them if new
Call EnsureCustomProperty("PROFILING", swCustomInfoText, swCustPropMgr)
Call EnsureCustomProperty("HEAT TREATMENT", swCustomInfoText, swCustPropMgr)
Call EnsureCustomProperty("SURFACE COATING", swCustomInfoText, swCustPropMgr)
'Handle REVISION property
'Check if the property exists
lRetCode = swCustPropMgr.Get6("REVISION", False, sVal, sResolvedVal, bWasResolved, bLinkToProp)
If lRetCode = swCustomInfoGetResult_e.swCustomInfoGetResult_NotPresent Then
'Property does not exist, add it.
swCustPropMgr.Add3 "REVISION", swCustomInfoText, "0", swCustomPropertyOnlyIfNew
Debug.Print "REVISION added successfully."
ElseIf lRetCode = swCustomInfoGetResult_e.swCustomInfoGetResult_ResolvedValue Then
If sVal = "" Then
'Property already exists but is blank. Set to default value "0".
swCustPropMgr.Set2 "REVISION", "0"
Debug.Print "REVISION was blank, successfully set to default (0)."
Else
'Property already exists and has a value. Do nothing
Debug.Print "REVISION verified."
End If
Else
'Some other error ocurred during Get6
Debug.Print "Error checking Custom Property: 'REVISION'. Return Code: " & lRetCode
'swApp.SendMsgToUser2 "Error checking Custom Property 'REVISION'. Return Code: " & lRetCode, swMbStop, swMbOk
End If
'Handle PROJECT NAME property
Dim sTargetValueProjName As String
sTargetValueProjName = "Ask Customer: "
lRetCode = swCustPropMgr.Get6("PROJECT NAME", False, "", sResolvedVal, bWasResolved, bLinkToProp)
'Property exists. Check its value.
If lRetCode = swCustomInfoGetResult_e.swCustomInfoGetResult_ResolvedValue Then
If Trim(sResolvedVal) = sTargetValueProjName Then
swCustPropMgr.Set2 "PROJECT NAME", "" ' Set to blank
Debug.Print "PROJECT NAME was 'Ask Customer: ', set to blank." '!!!
Else '!!!
Debug.Print "PROJECT NAME verified." '!!!
End If
'Debug.Print "PROJECT NAME updated successfully." '!!! commented out
ElseIf lRetCode = swCustomInfoGetResult_e.swCustomInfoGetResult_NotPresent Then '!!!
Debug.Print " PROJECT NAME property not present. Skipping value check." '!!!
Else
Debug.Print "Error checking Custom Property 'PROJECT NAME'. Error Code: " & lRetCode
'swApp.SendMsgToUser2 "Error checking Custom Property 'PROJECT NAME'. Error Code: " & lRetCode, swMbStop, swMbOk
Exit Sub
End If
'----- Finalize Part Updates -----
'Force rebuild
bForceRebuild = swModelDocExt.EditRebuildAll
Debug.Print "Part rebuilt: " & bForceRebuild '!!!
'Isometric Zoom to Fit
swModel.ShowNamedView2 "*Isometric", -1
swModel.ViewZoomtofit2
Debug.Print "Part view set to Isometric and Zooom to Fit." '!!!
'Quiet Save the part
bQuietSaveResult = swModel.Save3(swSaveAsOptions_e.swSaveAsOptions_Silent, lErrors, lWarnings)
If bQuietSaveResult Then
Debug.Print "Part update saved successfully."
Else
Debug.Print "Part update not saved."
End If
'----- Call the Drawing Sub-Routine -----
Call OpenOrCreateDrawing
'Ensure the drawing is the active document before updating sheet formats !!!
Set swDrawingDoc = swApp.ActiveDoc '!!!
If Not swDrawingDoc Is Nothing And swDrawingDoc.GetType = swDocumentTypes_e.swDocDRAWING Then '!!!
Debug.Print "Activating drawing: " & swDrawingDoc.GetTitle '!!!
swApp.ActivateDoc3 swDrawingDoc.GetTitle, True, swRebuildActiveDoc, lErrors '!!!
Else '!!!
Debug.Print "No drawing document active. Cannot proceed with sheet format updates." '!!!
Exit Sub 'Exit sub if drawing is not active !!!
End If '!!!
'----- Call the Update Sheet Format Sub-Routines
Call UpdateSheetFormatPREC
Call UpdateSheetFormatCUST
'Final save
Dim swActiveDoc As SldWorks.ModelDoc2
Dim lFinalErrors As Long
Dim lFinalWarnings As Long
Dim bFinalSaveResult As Boolean
Set swActiveDoc = swApp.ActiveDoc
If Not swActiveDoc Is Nothing Then
If swActiveDoc.GetType = swDocumentTypes_e.swDocDRAWING Then
bFinalSaveResult = swActiveDoc.Save3(swSaveAsOptions_e.swSaveAsOptions_Silent, lFinalErrors, lFinalWarnings)
If Not bFinalSaveResult Then
Debug.Print "Final save of drawing failed. Errors: " & lFinalErrors & ", Warnings: " & lFinalWarnings
Else
Debug.Print "Drawing saved successfully after all operations."
End If
End If
End If
'Re-activate the part if it's not the active document and save it again !!!
If swApp.ActiveDoc.GetPathName <> swModel.GetPathName Then '!!!
swApp.ActivateDoc3 swModel.GetTitle, True, swRebuildActiveDoc, lErrors '!!!
End If '!!!
bQuietSaveResult = swModel.Save3(swSaveAsOptions_e.swSaveAsOptions_Silent, lErrors, lWarnings)
If Not bQuietSaveResult Then
Debug.Print "Final save of part failed. Errors: " & lErrors & ", Warnings: " & lWarnings
Else
Debug.Print "Part saved successfully after all operations."
End If
End Sub
'----- Helper Function to Ensure Custom Property Exists -----
'This function checks if a custom property exists. If it does not, it gets added.
'It does not modify an existing property's value.
Function EnsureCustomProperty(sPropName As String, lPropType As swCustomInfoType_e, swPropMgr As SldWorks.CustomPropertyManager, Optional sDefaultValue As String = "") As Boolean
Dim sVal As String
Dim sResolvedVal As String
Dim bWasResolved As Boolean
Dim bLinkToProp As Boolean
Dim lRetCode As Long
Dim lAddResult As Long
'Check if the property exists
lRetCode = swPropMgr.Get6(sPropName, False, sVal, sResolvedVal, bWasResolved, bLinkToProp)
If lRetCode = swCustomInfoGetResult_e.swCustomInfoGetResult_NotPresent Then
'Property does not exist, add it
lAddResult = swPropMgr.Add3(sPropName, lPropType, sDefaultValue, swCustomPropertyOnlyIfNew)
If lAddResult = swCustomInfoAddResult_e.swCustomInfoAddResult_AddedOrChanged Then
EnsureCustomProperty = True
Else
EnsureCustomProperty = False
End If
Debug.Print "Custom property: " & sPropName & " successfully added."
ElseIf lRetCode = swCustomInfoGetResult_e.swCustomInfoGetResult_ResolvedValue Then
'Property already exists, do nothing.
EnsureCustomProperty = True
Debug.Print "Custom property: " & sPropName & " already existed."
Else
'Some other error ocurred during Get6
Debug.Print "Error checking Custom Property: " & sPropName & "'. Return Code: " & lRetCode
'swApp.SendMsgToUser2 "Error checking Custom Property '" & sPropName & "'. Return Code: " & lRetCode, swMbStop, swMbOk
EnsureCustomProperty = False
End If
End Function
'----- Sub-Routine to Open or Create Drawing ----
Sub OpenOrCreateDrawing()
'Declare lcoal variables for this sub-routine
Dim swPart As SldWorks.PartDoc
Dim swDrawing As SldWorks.DrawingDoc
Dim sPartPath As String
Dim sDrawingPath As String
Dim lErrors As Long
Dim lWarnings As Long
Dim bInsertResult As Boolean
Dim bQuietSaveDrwResult As Boolean
'----- CONFIGURATION -----
'Set the path to drawing template & predefined views
Const DRAWING_TEMPLATE_PATH As String = "C:\Users\DrawingOffice\Desktop\SOLIDWORKS TEMPLATES\Drawing and Part Templates\A3 UPDATED CATALOGUE PART DRAWING.DRWDOT"
'----- Ensure swApp and Model are already set from the main sub -----
If swApp Is Nothing Then
'swApp.SendMsgToUser2 "Application object not initialised. Cannot open or create drawing.", swMbWarning, swMbOk
Debug.Print "Application object not initialised. Cannot open or create drawing."
Exit Sub
End If
If swModel Is Nothing Then
'swApp.SendMsgToUser2 "Model object not initialised. Cannot open or create drawing.", swMbStop, swMbOk
Debug.Print "Model object not initialised. Cannot open or create drawing."
Exit Sub
End If
'Cast to PartDoc for part-specific properties
Set swPart = swModel
'Get the Part Document's full path
sPartPath = swPart.GetPathName()
If sPartPath = "" Then
'swApp.SendMsgToUser2 "The active part has not been saved yet. Please save the part before creating a drawing.", swMbStop, swMbOk
Debug.Print "The active part has not been saved yet. The part needs to be saved before proceeding." '!!!
Exit Sub
End If
'Construct the potential drawing path
'Assumes the drawing will be in the same folder, and have the same name.
sDrawingPath = Left(sPartPath, InStrRev(sPartPath, ".")) & "SLDDRW"
Debug.Print "Attempting to open/create drawing at " & sDrawingPath
'Check if the drawing file exists
If Dir(sDrawingPath) <> "" Then
'Drawing exists, try to open it
Set swDrawing = swApp.OpenDoc6(sDrawingPath, swDocumentTypes_e.swDocDRAWING, swOpenDocOptions_e.swOpenDocOptions_LoadModel, "", lErrors, lWarnings)
Debug.Print "Drawing found attempting to open it."
If Not swDrawing Is Nothing Then
'Rebuild/update drawing views
swDrawing.ForceRebuild
Debug.Print "Drawing successfully opened."
Else
'swApp.SendMsgToUser2 "Failed to open drawing '" & Mid(sDrawingPath, InStrRev(sDrawingPath, "\") + 1) & "'. SolidWorks Errors: " & lErrors & "Warnings: " & lWarnings, swMbStop, swMbOk
Debug.Print "OpenDoc6 failed for drawing: " & sDrawingPath
Debug.Print "OpenDoc6 Errors: " & lErrors & ", Warnings: " & lWarnings
End If
Else
Dim nCreateDrawing As Integer
'Drawing does not exist, ask if a new one should be created
'nCreateDrawing = swApp.SendMsgToUser2("Drawing not found for '" & Mid(sPartPath, InStrRev(sPartPath, "\") + 1) & "'. Create a new drawing?", swMbInformation, swMbYesNo)
'Create new drawing from template
'If nCreateDrawing = swMessageBoxResult_e.swMbHitNo Then
'Exit Sub
'Else
Set swDrawing = swApp.NewDocument(DRAWING_TEMPLATE_PATH, 0, 0, 0)
Debug.Print "Drawing not found. New drawing successfully created."
If Not swDrawing Is Nothing Then
' Activate and rebuild the new drawing document
swApp.ActivateDoc3 swDrawing.GetTitle, True, swRebuildActiveDoc, lErrors
'Insert model in predefined views
bInsertResult = swDrawing.InsertModelInPredefinedView(sPartPath)
Debug.Print "Inserting model in predefined views. Result: " & bInsertResult
'Insert dimensions
swDrawing.InsertModelAnnotations3 swImportModelItemsFromEntireModel, swInsertDimensionsMarkedForDrawing, True, True, True, True
Debug.Print "Inserting model dimensions."
'Save the newly created drawing !!!
bQuietSaveDrwResult = swModel.Save3(swSaveAsOptions_Silent, lErrors, lWarnings)
If Not bQuietSaveDrwResult Then '!!!
Debug.Print "Failed to save new drawing '" & Mid(sDrawingPath, InStrRev(sDrawingPath, "\") + 1) & "'/Errors: " & lErrors; ". Warnings: " & lWarnings & "." '!!!
Else '!!!
Debug.Print "New drawing saved successfully to: " & sDrawingPath '!!!
End If '!!!
Else
Debug.Print "Failed to create new drawing from template: " & DRAWING_TEMPLATE_PATH
Exit Sub
End If
'End If
End If
Call ForceRebuildAllDrawings
'The 3 lines bellow were commented out as they were flagged up as problematic. The drawing is now saved when created !!!
'If Not swDrawing Is Nothing Then
' swModel.Extension.SaveAs sDrawingPath, swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, Empty, Empty
'End If
End Sub
Sub UpdateSheetFormatPREC()
Dim swDrawing As SldWorks.DrawingDoc
Dim swSheet As SldWorks.sheet
Dim vSheetName As Variant
Dim i As Long
Dim sSheetFormatPath As String
Dim sCurrentSheet As String
Dim bRet As Boolean
Dim lErrors As Long
Dim lWarnings As Long
Dim bQuietSaveDrwResult As Boolean
Dim swFeat As SldWorks.Feature
'----- Delete BOM -----
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
'Set swFeat = swModel.FirstFeature modved to later on!!!
swModel.ClearSelection2 True
'Only attempt to delete BOM if the active document is a drawing
If swModel.GetType() = swDocumentTypes_e.swDocDRAWING Then '!!!
Set swDrawing = swModel '!!!
Set swFeat = swDrawing.FirstFeature ' Iterate features of the drawing !!!
While Not swFeat Is Nothing
If "BomFeat" = swFeat.GetTypeName Then
Debug.Print "Attempting to delete BOM: " & swFeat.Name '!!!
swFeat.Select2 True, 0
swDrawing.Extension.DeleteSelection2 swDeleteSelectionOptions_e.swDelete_Absorbed '!!!
Debug.Print "BOM deleted successfully." '!!!
End If
Set swFeat = swFeat.GetNextFeature
Wend
Else '!!!
Debug.Print "Active document is not a drawing. Skipping BOM deletion." '!!!
End If '!!!
'swModel.Extension.DeleteSelection2 swDeleteSelectionOptions_e.swDelete_Absorbed
'-----
Set swDrawing = swApp.ActiveDoc
sSheetFormatPath = "C:\Users\DrawingOffice\Desktop\SOLIDWORKS TEMPLATES\Drawing and Part Templates\A3 CATALOGUE PART DRAWING UPDATED.slddrt" '
If Not swDrawing Is Nothing Then
If swDrawing.GetType = swDocumentTypes_e.swDocDRAWING Then
vSheetName = swDrawing.GetSheetNames
If Not IsEmpty(vSheetName) Then
For i = 0 To UBound(vSheetName)
Set swSheet = swDrawing.sheet(vSheetName(i))
If swSheet.GetName = "Sheet1" Then
sCurrentSheet = swDrawing.ActivateSheet("Sheet1")
Debug.Print "Activating Sheet1 and updating format." '!!!
bRet = swDrawing.SetupSheet6(swSheet.GetName, swDwgPaperSizes_e.swDwgPapersUserDefined, swDwgTemplates_e.swDwgTemplateCustom, 1, 1, True, sSheetFormatPath, 0.42, 0.297, "Default", True, 0, 0, 0, 0, 0, 0)
Debug.Print "SetupSheet6 for Sheet1 result: " & bRet '!!!
ElseIf swSheet.GetName = "PRECISION" Then
sCurrentSheet = swDrawing.ActivateSheet("PRECISION")
Debug.Print "Activating PRECISION sheet and updating format." '!!!
bRet = swDrawing.SetupSheet6(swSheet.GetName, swDwgPaperSizes_e.swDwgPapersUserDefined, swDwgTemplates_e.swDwgTemplateCustom, 1, 1, True, sSheetFormatPath, 0.42, 0.297, "Default", True, 0, 0, 0, 0, 0, 0)
Debug.Print "SetupSheet6 for PRECISION result: " & bRet '!!!
End If
Next i
Else '!!!
Debug.Print "No sheets found in the drawing for PRECISION update." '!!!
End If
Else '!!!
Debug.Print "Active document is not a drawing. Cannot update sheet format for PRECISION." '!!!
Exit Sub '!!!
End If
Else '!!!
Debug.Print "No active drawing document. Cannot update sheet format for PRECISION." '!!!
Exit Sub '!!!
End If
Call ForceRebuildAllDrawings
If Not swDrawing Is Nothing Then
bQuietSaveDrwResult = swDrawing.Save3(swSaveAsOptions_Silent, lErrors, lWarnings)
If Not bQuietSaveDrwResult Then
Debug.Print "Failed to save drawing after PRECISION sheet format update. Errors: " & lErrors & ", Warnings: " & lWarnings & "."
Else
Debug.Print "Drawing saved successfully after PRECISION sheet format update."
End If
Else
Debug.Print "swDrawing object is Nothing at save point for PRECISION."
End If
End Sub
Sub UpdateSheetFormatCUST()
Dim swDrawing As SldWorks.DrawingDoc
Dim swSheet As SldWorks.sheet
Dim vSheetName As Variant
Dim i As Long
Dim sSheetFormatPath As String
Dim sCurrentSheet As String
Dim bRet As Boolean
Dim lErrors As Long
Dim lWarnings As Long
Dim bQuietSaveDrwResult As Boolean
Dim swFeat As SldWorks.Feature
Dim sDrawingFileName As String
'----- Delete BOM -----
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
'Set swFeat = swModel.FirstFeature moved to later on
swModel.ClearSelection2 True
'Only attempt to delete BOM if the active document is a drawing
If swModel.GetType() = swDocumentTypes_e.swDocDRAWING Then '!!!
Set swDrawing = swModel '!!!
Set swFeat = swDrawing.FirstFeature ' Iterate features of the drawing !!!
While Not swFeat Is Nothing
If "BomFeat" = swFeat.GetTypeName Then
Debug.Print "Attempting to delete BOM: " & swFeat.Name '!!!
swFeat.Select2 True, 0
swDrawing.Extension.DeleteSelection2 swDeleteSelectionOptions_e.swDelete_Absorbed '!!!
Debug.Print "BOM deleted." '!!!!
End If
Set swFeat = swFeat.GetNextFeature
Wend
Else '!!!
Debug.Print "Active document is not a drawing. Skipping BOM deletion." '!!!
End If '!!!
'swModel.Extension.DeleteSelection2 swDeleteSelectionOptions_e.swDelete_Absorbed
'-----
Set swDrawing = swApp.ActiveDoc
sSheetFormatPath = "C:\Users\DrawingOffice\Desktop\SOLIDWORKS TEMPLATES\Drawing and Part Templates\A3 CATALOGUE PART DRAWING UPDATED - CUSTOMER.slddrt" '
If Not swDrawing Is Nothing Then
If swDrawing.GetType = swDocumentTypes_e.swDocDRAWING Then
vSheetName = swDrawing.GetSheetNames
If Not IsEmpty(vSheetName) Then
For i = 0 To UBound(vSheetName)
Set swSheet = swDrawing.sheet(vSheetName(i))
If swSheet.GetName = "Sheet2" Then
sCurrentSheet = swDrawing.ActivateSheet("Sheet2")
Debug.Print "Activating Sheet2 and updating format." '!!!
bRet = swDrawing.SetupSheet6(swSheet.GetName, swDwgPaperSizes_e.swDwgPapersUserDefined, swDwgTemplates_e.swDwgTemplateCustom, 1, 1, True, sSheetFormatPath, 0.42, 0.297, "Default", True, 0, 0, 0, 0, 0, 0)
Debug.Print "SetupSheet6 for Sheet2 result: " & bRet '!!!
ElseIf swSheet.GetName = "CUSTOMER" Then
sCurrentSheet = swDrawing.ActivateSheet("CUSTOMER")
Debug.Print "Activating CUSTOMER sheet and updating format." '!!!
bRet = swDrawing.SetupSheet6(swSheet.GetName, swDwgPaperSizes_e.swDwgPapersUserDefined, swDwgTemplates_e.swDwgTemplateCustom, 1, 1, True, sSheetFormatPath, 0.42, 0.297, "Default", True, 0, 0, 0, 0, 0, 0)
Debug.Print "SetupSheet6 for CUSTOMER result " & bRet '!!!
End If
Next i
Else
Debug.Print "No sheets found in the drawing for CUSTOMER update."
End If
Else
Debug.Print "Active document is not a drawing. Cannot update sheet format for CUSTOMER."
Exit Sub
End If
Else
Debug.Print "No active drawing document. Cannot update sheet format for CUSTOMER."
Exit Sub
End If
Call ForceRebuildAllDrawings
If Not swDrawing Is Nothing Then
bQuietSaveDrwResult = swDrawing.Save3(swSaveAsOptions_Silent, lErrors, lWarnings)
If Not bQuietSaveDrwResult Then
Debug.Print "Failed to save drawing after CUSTOMER sheet format update. Errors: " & lErrors & ", Warnings: " & lWarnings & "."
Else
Debug.Print "Drawing saved successfully after CUSTOMER sheet format update."
End If
Else
Debug.Print "swDrawing object is Nothing at save point for CUSTOMER."
End If
End Sub
Sub ForceRebuildAllDrawings()
Dim vModels As Variant
Dim swModel As SldWorks.ModelDoc2
Dim swDrawing As SldWorks.DrawingDoc
Dim i As Long
Dim bRebuildResult As Boolean
Set swApp = Application.SldWorks
vModels = swApp.GetDocuments
For i = LBound(vModels) To UBound(vModels)
Set swModel = vModels(i)
If Not swModel Is Nothing Then
If swModel.GetType = swDocumentTypes_e.swDocDRAWING Then
Set swDrawing = swModel
bRebuildResult = swModel.ForceRebuild3(True)
Debug.Print "Rebuild drawing: " & swModel.GetTitle & ". Result: " & bRebuildResult '!!!
End If
End If
Next i
End Sub
