Running a Macro on multiple drawings

SOLIDWORKS API/VBA Macros
1

Hello,

I have a working macro that I’ve managed to cobble together. It deletes a block from the title block of a drawing, then inserts a specific block, in a certain place, based on the sheet size.

However, I’m trying to tweak this so it can run on all drawings within a folder.
I have a version (massive thanks to Deepak Gupta for his help) which I believe is 90% correct but it’s still throwing up an error - ‘Variable not defined’ and I can’t figure out why.

I’ll post the original macro that works on single drawings manually, and then I’ll also post my version which tries to make this work for all drawings in a folder but isn’t working.

Please could anyone help me get this working, as I have a whole load of drawings to apply this to!

Thanks a lot!

Johno

Here’s the original working code:

Dim swApp As Object

Dim Part As Object
Dim boolstatus As Boolean

Sub main()

Set swApp = Application.SldWorks

Set Part = swApp.ActiveDoc
boolstatus = Part.Extension.SelectByID2(“Sheet1”, “SHEET”, 0.37573258774438, 0.213815049989652, 0, False, 0, Nothing, 0)
Part.EditTemplate
Part.EditSketch
Part.ClearSelection2 True
boolstatus = Part.Extension.SelectByID2(“TITLE BLOCK LOGO-1”, “SKETCHPOINT”, 0.376092469963706, 0.101224236733452, 0, False, 0, Nothing, 0)
Part.EditDelete
boolstatus = Part.Extension.SelectByID2(“TITLE BLOCK LOGO-2”, “SKETCHPOINT”, 0.284947555369359, 0.173177575046838, 0, False, 0, Nothing, 0)
Part.EditDelete
boolstatus = Part.Extension.SelectByID2(“TITLE BLOCK LOGO-3”, “SKETCHPOINT”, 0.29645168323629, 0.205863420406613, 0, False, 0, Nothing, 0)
Part.EditDelete
boolstatus = Part.Extension.SelectByID2(“TITLE BLOCK LOGO-4”, “SKETCHPOINT”, 0.29645168323629, 0.205863420406613, 0, False, 0, Nothing, 0)
Part.EditDelete
boolstatus = Part.Extension.SelectByID2(“TITLE BLOCK LOGO-4”, “SKETCHPOINT”, 0.29645168323629, 0.205863420406613, 0, False, 0, Nothing, 0)
Part.EditDelete
boolstatus = Part.Extension.SelectByID2(“TITLE BLOCK LOGO-5”, “SKETCHPOINT”, 0.29645168323629, 0.205863420406613, 0, False, 0, Nothing, 0)
Part.EditDelete
boolstatus = Part.Extension.SelectByID2(“TITLE BLOCK LOGO-6”, “SKETCHPOINT”, 0.29645168323629, 0.205863420406613, 0, False, 0, Nothing, 0)
Part.EditDelete
boolstatus = Part.Extension.SelectByID2(“TITLE BLOCK LOGO-6”, “SKETCHPOINT”, 0.29645168323629, 0.205863420406613, 0, False, 0, Nothing, 0)
Part.EditDelete
Part.EditSheet

Set Part = swApp.ActiveDoc

Set swDraw = swApp.ActiveDoc
Set swSheet = swDraw.GetCurrentSheet

' Get current sheet properties
vSheetProps = swSheet.GetProperties

' Current sheet properties
Debug.Print "  PaperSize                 = " & vSheetProps(0)

'0 = A Landscape (11x8.5"), 2 = B (17x11"), 4 = E (Not Set)

Part.EditTemplate
Part.EditSketch
Part.EditSheet
Part.EditSketch
Part.ClearSelection2 True

Dim swSktManager As SldWorks.SketchManager
Dim swModel As SldWorks.ModelDoc2
Dim swMathUtility As SldWorks.MathUtility
Dim swMathPoint As SldWorks.MathPoint
Dim PointCoords(2) As Double
Dim swSktBlkDef As SldWorks.SketchBlockDefinition

Dim scl As Double
Dim angle As Double


' Change scale and angle here
scl = 1
angle = 0

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Part.EditTemplate

Part.EditSketch
Part.ClearSelection2 True
Set swSktManager = swModel.SketchManager
Set swMathUtility = swApp.GetMathUtility

Select Case vSheetProps(0)

Case “0”
’ A Size (Change Position of Logo Here)

PointCoords(0) = 0.1875 ’ X

PointCoords(1) = 0.015 ’ Y

PointCoords(2) = 0 ’ Z

Case “1”
'Not Specified

PointCoords(0) = 0.25 ’ X

PointCoords(1) = -0.05 ’ Y

PointCoords(2) = 0 ’ Z

Case “2”
’ B size (Change Position of Logo Here)

PointCoords(0) = 0.34    ' X
PointCoords(1) = 0.01425 ' Y
PointCoords(2) = 0 ' Z

'Add extra sizes here if needed, using Case "3" etc.


End Select

Set swMathPoint = swMathUtility.CreatePoint(PointCoords)
'Set Block file location here ->
    Set swSktBlkDef = swSktManager.MakeSketchBlockFromFile(swMathPoint, "D:\Documents\LOGO.SLDBLK", False, scl, angle)

Part.EditSheet
Part.EditSketch
End Sub

and here’s the version with the folder select, that doesn’t quite work:

'Batch Delete Block, then Insert Based on Paper Size.swp ------------- 06/16/21

'Description: Macro to Delete Block, then Insert Based on Paper Size.

’ Macro would process all drawing files in the specified folder and it’s sub folders.

'Folder Browse Codes: http://www.cpearson.com/excel/browsefolder.aspx

'Please back up your data before use and USE AT OWN RISK

’ This macro is provided as is. No claims, support, refund, safety net, or
’ warranties are expressed or implied. By using this macro and/or its code in
’ any way whatsoever, the user and any entities which the user represents,
’ agree to hold the authors free of any and all liability. Free distribution
’ and use of this code in other free works is welcome. If any portion of
’ this code is used in other works, credit to the authors must be placed in
’ that work within a user viewable location (e.g., macro header). All other
’ forms of distribution (i.e., not free, fee for delivery, etc.) are prohibited
’ without the expressed written consent by the authors. Use at your own risk!
’ ------------------------------------------------------------------------------
’ Written by: Deepak Gupta (http://gupta9665.com/)
’ -------------------------------------------------------------------------------
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swSheet As SldWorks.Sheet
Dim vSheetProps As Variant
Dim nErrors As Long
Dim nWarnings As Long
Dim sFileName As String
Dim Path As String
Dim vSheetName As Variant
Dim i As Long
Dim nTemplatePath As String
Dim swPaperWidth As String
Dim mFolder As Variant
Dim sFolder As Variant
Dim fso As Object

Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260

Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String

Dim SH As Shell32.Shell
Dim F As Shell32.Folder

Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
If F = “Desktop” Then
BrowseFolder = Environ(“USERPROFILE”) & “\Desktop”
Else
BrowseFolder = F.Items.Item.Path
End If
End If

End Function
Sub main()

Path = BrowseFolder()
If Path = "" Then
MsgBox "Please select the path and try again"
End
Else
Path = Path & "\"
End If

ProcessDrawings Path

End Sub

Sub ProcessDrawings(sPath As String)

Set swApp = Application.SldWorks

sFileName = Dir(Path & “*.slddrw”)
Do Until sFileName = “”
Set swModel = swApp.OpenDoc6(Path + sFileName, swDocDRAWING, swOpenDocOptions_Silent, “”, nErrors, nWarnings)
vSheetName = swModel.GetSheetNames
For i = 0 To UBound(vSheetName)
swModel.ActivateSheet vSheetName(i)
Set swSheet = swModel.GetCurrentSheet
vSheetProps = swSheet.GetProperties

    'edit sheet format and delete blocks
    
        swModel.EditTemplate
        swModel.EditSketch
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-1", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-2", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-3", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-4", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-4", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-5", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-6", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-6", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        swModel.ClearSelection2 True
        
        
        
        Set swSktManager = swModel.SketchManager
        Set swMathUtility = swApp.GetMathUtility
        
        
        
        swModel.EditSheet
        swModel.ClearSelection2 True
                  
        'Set Position of Logo based on sheet size
        Select Case vSheetProps(0) ' Get paper size
                      
        Case "0"
        ' A Size (Change Position of Logo Here)
        PointCoords(0) = 0.1875 ' X
        PointCoords(1) = 0.015 ' Y
        PointCoords(2) = 0 ' Z
        
        Case "1"
        'Not Specified
        PointCoords(0) = 0.25 ' X
        PointCoords(1) = -0.05 ' Y
        PointCoords(2) = 0 ' Z
        
        Case "2"
        ' B size (Change Position of Logo Here)
        PointCoords(0) = 0.34    ' X
        PointCoords(1) = 0.01425 ' Y
        PointCoords(2) = 0 ' Z
            
        'Add extra sizes here if needed, using Case "3" etc.
            
        End Select

        Set swMathPoint = swMathUtility.CreatePoint(PointCoords)

        'Set Block file location here ->
        Set swSktBlkDef = swSktManager.MakeSketchBlockFromFile(swMathPoint, "D:\Documents\LOGO.SLDBLK", False, scl, angle)
        swModel.ViewZoomtofit2
Next i

        swModel.ActivateSheet vSheetName(0)
        swModel.Save3 swSaveAsOptions_Silent, nErrors, nWarnings
        swApp.CloseDoc swModel.GetTitle
        Set swDraw = Nothing

sFileName = Dir
Loop

'Process files in sub folders
Set fso = CreateObject(“Scripting.FileSystemObject”)
Set mFolder = fso.GetFolder(sPath)
For Each sFolder In mFolder.subFolders
ProcessDrawings sFolder.Path & ""
Next

End Sub

2

Try Batch+

3

This is absolutely excellent! It’s exactly what I needed. Thanks so much.

(If anyone has any info about the other way too, I’d be happy to hear it, just for my own knowledge)

4

In case anyone is looking for this - the excellent Deepak Gupta got it working.

This macro opens all drawings in a folder, then deletes any blocks in the Sheet Format/Title Block, then it inserts a new block (specify the location of this within the code) in the corner, depending on the sheet size.

Here’s the code:

'Batch Delete Block, then Insert Based on Paper Size.swp ------------- 06/16/21

'Description: Macro to Delete Block, then Insert Based on Paper Size.

’ Macro would process all drawing files in the specified folder and it’s sub folders.

'Folder Browse Codes: [link removed]

'Please back up your data before use and USE AT OWN RISK

’ This macro is provided as is. No claims, support, refund, safety net, or
’ warranties are expressed or implied. By using this macro and/or its code in
’ any way whatsoever, the user and any entities which the user represents,
’ agree to hold the authors free of any and all liability. Free distribution
’ and use of this code in other free works is welcome. If any portion of
’ this code is used in other works, credit to the authors must be placed in
’ that work within a user viewable location (e.g., macro header). All other
’ forms of distribution (i.e., not free, fee for delivery, etc.) are prohibited
’ without the expressed written consent by the authors. Use at your own risk!
’ ------------------------------------------------------------------------------
’ Written by: Deepak Gupta (http://gupta9665.com/)
’ -------------------------------------------------------------------------------
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swSheet As SldWorks.Sheet
Dim vSheetProps As Variant
Dim nErrors As Long
Dim nWarnings As Long
Dim sFileName As String
Dim Path As String
Dim vSheetName As Variant
Dim i As Long
Dim nTemplatePath As String
Dim swPaperWidth As String
Dim mFolder As Variant
Dim sFolder As Variant
Dim fso As Object

Dim boolstatus As Boolean
Dim swSktManager As SldWorks.SketchManager
Dim swMathUtility As SldWorks.MathUtility
Dim PointCoords(2) As Double
Dim swMathPoint As SldWorks.MathPoint
Dim swSktBlkDef As SldWorks.SketchBlockDefinition
Dim scl As Double
Dim Angle As Double

Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260

Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String

Dim SH As Shell32.Shell
Dim F As Shell32.Folder

Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
If F = “Desktop” Then
BrowseFolder = Environ(“USERPROFILE”) & “\Desktop”
Else
BrowseFolder = F.Items.Item.Path
End If
End If

End Function
Sub main()

Path = BrowseFolder()
If Path = "" Then
MsgBox "Please select the path and try again"
End
Else
Path = Path & "\"
End If

ProcessDrawings Path

End Sub

Sub ProcessDrawings(sPath As String)

Set swApp = Application.SldWorks

sFileName = Dir(Path & “*.slddrw”)
Do Until sFileName = “”
Set swModel = swApp.OpenDoc6(Path + sFileName, swDocDRAWING, swOpenDocOptions_Silent, “”, nErrors, nWarnings)
vSheetName = swModel.GetSheetNames
For i = 0 To UBound(vSheetName)
swModel.ActivateSheet vSheetName(i)
Set swSheet = swModel.GetCurrentSheet
vSheetProps = swSheet.GetProperties

        'edit sheet format and delete blocks
    
        swModel.EditTemplate
        swModel.EditSketch
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-1", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-2", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-3", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-4", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-4", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-5", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-6", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        boolstatus = swModel.Extension.SelectByID2("TITLE BLOCK LOGO-6", "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0)
        swModel.EditDelete
        swModel.ClearSelection2 True
                                
                             
        'Set Position of Logo based on sheet size
        Select Case vSheetProps(0) ' Get paper size
                      
        Case "0"
        ' A Size (Change Position of Logo Here)
        PointCoords(0) = 0.1875 ' X
        PointCoords(1) = 0.015 ' Y
        PointCoords(2) = 0 ' Z
        
        Case "1"
        'Not Specified
        PointCoords(0) = 0.25 ' X
        PointCoords(1) = -0.05 ' Y
        PointCoords(2) = 0 ' Z
        
        Case "2"
        ' B size (Change Position of Logo Here)
        PointCoords(0) = 0.34    ' X
        PointCoords(1) = 0.01425 ' Y
        PointCoords(2) = 0 ' Z
            
        'Add extra sizes here if needed, using Case "3" etc.
            
        End Select
        
        Set swSktManager = swModel.SketchManager
        Set swMathUtility = swApp.GetMathUtility
        Set swMathPoint = swMathUtility.CreatePoint(PointCoords)
        
         ' Change scale and angle here
        scl = 1
        Angle = 0

        'Set Block file location here ->
        Set swSktBlkDef = swSktManager.MakeSketchBlockFromFile(swMathPoint, "D:\Documents\LOGO.SLDBLK", False, scl, Angle)
        
        swModel.EditSheet
        swModel.ClearSelection2 True
        swModel.ViewZoomtofit2
        
Next i

        swModel.ActivateSheet vSheetName(0)
        swModel.Save3 swSaveAsOptions_Silent, nErrors, nWarnings
        swApp.CloseDoc swModel.GetTitle
        Set swDraw = Nothing

sFileName = Dir
Loop

'Process files in sub folders
Set fso = CreateObject(“Scripting.FileSystemObject”)
Set mFolder = fso.GetFolder(sPath)
For Each sFolder In mFolder.subFolders
ProcessDrawings sFolder.Path & ""
Next

End Sub

2 Likes