Hello,
I am relatively new to Soidworks macros and currently have two macros that work for what i am trying to achieve but would like to combine them and don't know if it is possible.
What I am trying to achieve is fairly simple (I think):
- Duplicate the existing sheet "Sheet1".
- Rename "Sheet1" to "WORKSHOP" and "Sheet1(1)" to "CUSTOMER".
- Change the Title block in the sheet "CUSTOMER" to a different template without affecting the drawing or the annotations in size, scale or position.
I am currently achieving something similar by employing the following macros:
- To duplicate Sheet1 and rename:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim Part As DrawingDoc
Dim swModel As ModelDoc2
Dim boolstatus As Boolean
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox "Please open a drawing document."
Exit Sub
End If
Set Part = swModel
Dim sheet As sheet
Dim sheetName As String
Dim newSheetName As String
' Rename "Sheet1" to "WORKSHOP"
sheetName = "Sheet1"
newSheetName = "WORKSHOP"
boolstatus = Part.ActivateSheet(sheetName)
If boolstatus = False Then
MsgBox "Sheet '" & sheetName & "' not found."
Exit Sub
End If
Set sheet = Part.GetCurrentSheet
sheet.SetName newSheetName
' Copy "WORKSHOP" and paste it AFTER the original
boolstatus = Part.Extension.SelectByID2(newSheetName, "SHEET", 0, 0, 0, False, 0, Nothing, 0)
swModel.EditCopy
boolstatus = Part.PasteSheet(swInsertOption_AfterSelectedSheet, swRenameOption_No)
' Rename the newly pasted sheet to "CUSTOMER"
Dim sheetNames As Variant
sheetNames = Part.GetSheetNames
Dim i As Integer
Dim pastedSheetName As String
For i = LBound(sheetNames) To UBound(sheetNames)
If sheetNames(i) <> "WORKSHOP" And sheetNames(i) <> "CUSTOMER" Then
' Assume the most recently added sheet is the one with the highest index
pastedSheetName = sheetNames(i)
End If
Next i
boolstatus = Part.ActivateSheet(pastedSheetName)
Set sheet = Part.GetCurrentSheet
sheet.SetName "CUSTOMER"
MsgBox "CUSTOMER sheet created successfully."
End Sub
2. To change the title block in the "CUSTOMER" sheet:
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Part.EditTemplate
Part.EditSketch
Part.ClearSelection2 True
boolstatus = Part.SetupSheet5("CUSTOMER", 12, 12, 1, 20, True, "c:\users\drawingoffice\desktop\solidworks templates\drawing and part templates\a3 catalogue part drawing updated - customer.slddrt", 0.42, 0.297, "Default", True)
Part.EditTemplate
Part.EditSheet
Part.EditSketch
' Zoom To Fit
Part.ViewZoomtofit2
' Zoom To Fit
Part.ViewZoomtofit2
End Sub
However, the second macro changes the scale of the drawings sometimes.
Any help will be greatly appreciated 😊