Macro to change drawing scale move dimensions

[andrmollo]

I have a couple of macros that change the drawing scale between a series of predefined steps. One macro enlarge the view, the other reduce it.

I can't figure out why these macro change the position of the dimensions, and just for the base view. I though it was the <ScaleAnnoPosition> of the <SetScale> method but even using <True> doesn't change the result.

I have another macro to change the sheet format that use the <SetupSheet5> method but same results. If I change the scale with the SolidWorks interfaces the dimensions stay where they are...

I have attached a brief video and a sample file.

Here is the code

Code: Select all

Dim swApp As SldWorks.SldWorks
Dim swDraw As SldWorks.IDrawingDoc
Dim swSheet As SldWorks.Sheet
Dim sheetProperties As Variant
Dim scalaNum As Double
Dim scalaDen As Double
Dim ScaleAnnoPosition As Boolean
Dim ScaleAnnoTextHeight As Boolean
Dim value As Boolean

Sub main()

    Set swApp = Application.SldWorks
    Dim swDraw                  As SldWorks.IDrawingDoc
    Dim swSheet                 As SldWorks.Sheet
    
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then
        MsgBox ("Open a drawing")
        GoTo finally_
    End If
    
    If swModel.GetPathName() = "" Then
        MsgBox ("Save the file")
        GoTo finally_
    End If
    
    If Not swModel.GetType() = swDocDRAWING Then
        MsgBox ("OPen a drawing")
        GoTo finally_
    End If
    
    Set swDraw = swApp.ActiveDoc
    Set swSheet = swDraw.GetCurrentSheet
    
    sheetProperties = swSheet.GetProperties2
    scalaNum = sheetProperties(2)
    scalaDen = sheetProperties(3)
    
    If scalaNum = 1 Then
        Select Case scalaDen
            Case Is = 1
                scalaDen = 1
                scalaNum = 2
            Case Is = 2
                scalaDen = 1
            Case Is = 2.5
                scalaDen = 2
            Case Is = 4
                scalaDen = 2.5
            Case Is = 5
                scalaDen = 4
            Case Is = 7.5
                scalaDen = 5
            Case Is = 10
                scalaDen = 7.5
            Case Is = 15
                scalaDen = 10
            Case Is = 20
                scalaDen = 15
            Case Is = 25
                scalaDen = 20
            Case Is = 30
                scalaDen = 25
            Case Is = 50
                scalaDen = 30
            Case Is = 75
                scalaDen = 50
            Case Is = 100
                scalaDen = 75
            Case Is = 150
                scalaDen = 100
            Case Is = 200
                scalaDen = 150
            Case Is = 250
                scalaDen = 200
            Case Else
                MsgBox "Scale not found", vbExclamation
                GoTo finally_
            End Select
    ElseIf scalaDen = 1 Then
        Select Case scalaNum
            Case Is = 2
             scalaNum = 2.5
            Case Is = 2.5
             scalaNum = 4
            Case Is = 4
             scalaNum = 5
        Case Else
                MsgBox "Scale not found", vbExclamation
                GoTo finally_
        End Select
    End If
    
    ScaleAnnoPosition = False
    ScaleAnnoTextHeight = False
    value = swSheet.SetScale(scalaNum, scalaDen, ScaleAnnoPosition, ScaleAnnoTextHeight)
    
finally_:
        
End Sub

and the other one:

Code: Select all

Dim swApp As SldWorks.SldWorks
Dim swDraw As SldWorks.IDrawingDoc
Dim swSheet As SldWorks.Sheet
Dim sheetProperties As Variant
Dim scalaNum As Double
Dim scalaDen As Double
Dim ScaleAnnoPosition As Boolean
Dim ScaleAnnoTextHeight As Boolean
Dim value As Boolean

Sub main()

    Set swApp = Application.SldWorks
    Dim swDraw                  As SldWorks.IDrawingDoc
    Dim swSheet                 As SldWorks.Sheet
    
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then
        MsgBox ("Open a drawing")
        GoTo finally_
    End If
    
    If swModel.GetPathName() = "" Then
        MsgBox ("Save the file")
        GoTo finally_
    End If
    
    If Not swModel.GetType() = swDocDRAWING Then
        MsgBox ("Open a drawing")
        GoTo finally_
    End If
    
    Set swDraw = swApp.ActiveDoc
	Set swSheet = swDraw.GetCurrentSheet
	
	sheetProperties = swSheet.GetProperties2
	scalaNum = sheetProperties(2)
	scalaDen = sheetProperties(3)
	
	If scalaNum = 1 Then
		Select Case ScalaDen
			Case Is = 1
				ScalaDen = 2
			Case Is = 2
				ScalaDen = 2.5
			Case Is = 2.5
				ScalaDen = 4
			Case Is = 4
				ScalaDen = 5
			Case Is = 5
				ScalaDen = 7.5
			Case Is = 7.5
				ScalaDen = 10
			Case Is = 10
				ScalaDen = 15
			Case Is = 15
				ScalaDen = 20
			Case Is = 20
				ScalaDen = 25
			Case Is = 25
				ScalaDen = 30
			Case Is = 30
				ScalaDen = 50
			Case Is = 50
				ScalaDen = 75
			Case Is = 75
				ScalaDen = 100
			Case Is = 100
				ScalaDen = 150
			Case Is = 150
				ScalaDen = 200
			Case Is = 200
				ScalaDen = 250				
			Case Else
				MsgBox "Scale not found" , vbExclamation
				Goto finally_
			End Select
	ElseIf ScalaDen = 1 Then
		Select Case ScalaNum
			Case Is = 1
				ScalaNum = 1
				ScalaDen = 2
			Case Is = 2
				ScalaNum = 1
			Case Is = 2.5
				ScalaNum = 2
			Case Is = 4
				ScalaNum = 2.5
			Case Is = 5
				ScalaNum = 4
		Case Else
				MsgBox "Scale not found" , vbExclamation
				Goto finally_
		End Select
	End If
	
	ScaleAnnoPosition = False
	ScaleAnnoTextHeight = False
	value = swSheet.SetScale(ScalaNum, ScalaDen, ScaleAnnoPosition, ScaleAnnoTextHeight)
    
finally_:
        
End Sub

[andrmollo]

I think I found a solution, or at least a workaround. The issue seems to be related with both Sheet::SetScale and Sheet::ReloadTemplate. Instead of SetScale I now use SetupSheet5 to set the scale and instead of ReloadTemplate I first load an empty template and then the actual one.

A couple od SPR that I found related to the topic: SPR 206559 and 409201

I hope this information can help others.

[Check Master]

Nice code, thanks for sharing.
Would you also like to share the workaround?
I'm curious about.

This can also be an option:

Code: Select all

' Select all Dimensions and Align/Arrange Dimensions
        Dim swModelDocExt As SldWorks.ModelDocExtension
        Dim swSelMgr As SldWorks.SelectionMgr
        Dim boolstatus As Boolean
        
        Set swModelDocExt = swModel.Extension
        Set swSelMgr = swModel.SelectionManager
    
        swModelDocExt.SelectAll
    
        ' Get and print the number of selections
        selCount = 0
        selCount = swSelMgr.GetSelectedObjectCount2(-1)
    
        Debug.Print "Number of entities selected in drawing    = " & selCount
    
      boolstatus = swModel.Extension.AlignDimensions(0, 0.06)
        
        swModel.ForceRebuild3 False 'Rebuild Ctrl-Q

[andrmollo]

Hi!

Thanks for sharing your code.

The updated macros, I'm sorry but comments are in italian:

Code: Select all

'IngrScala
'
'Ingrandisce la scala del foglio attivo

Const REMOVE_MODIFIED_NOTES As Boolean = True

Dim swApp As SldWorks.SldWorks
Dim swDraw As SldWorks.IDrawingDoc
Dim swSheet As SldWorks.Sheet
Dim sheetProperties As Variant
Dim scalaNum As Double
Dim scalaDen As Double
Dim ScaleAnnoPosition As Boolean
Dim ScaleAnnoTextHeight As Boolean
Dim value As Boolean

Sub main() 'Macro principale

    Set swApp = Application.SldWorks
    Dim swDraw                  As SldWorks.IDrawingDoc
    Dim swSheet                 As SldWorks.Sheet
    
    'Controllo se un file è aperto, se il file è salvato e se il file aperto è un disegno
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then
        MsgBox ("Aprire un file di disegno per eseguire la macro")
        GoTo finally_
    End If
    
    If swModel.GetPathName() = "" Then
        MsgBox ("Salvare il file per eseguire la macro")
        GoTo finally_
    End If
    
    If Not swModel.GetType() = swDocDRAWING Then
        MsgBox ("Aprire un file di disegno per eseguire la macro")
        GoTo finally_
    End If
    
    'Ottiene il foglio di disegno attivo
    Set swDraw = swApp.ActiveDoc
    Set swSheet = swDraw.GetCurrentSheet
    
    'Ottiene le proprietà del foglio attivo
    sheetProperties = swSheet.GetProperties2
    scalaNum = sheetProperties(2)
    scalaDen = sheetProperties(3)
    
    'Imposta le variabili per la scala
    If scalaNum = 1 Then 'Se il numeratore è uguale a 1 allora diminuisci il denominatore
        Select Case scalaDen
            Case Is = 1
                scalaDen = 1
                scalaNum = 2
            Case Is = 2
                scalaDen = 1
            Case Is = 2.5
                scalaDen = 2
            Case Is = 4
                scalaDen = 2.5
            Case Is = 5
                scalaDen = 4
            Case Is = 7.5
                scalaDen = 5
            Case Is = 10
                scalaDen = 7.5
            Case Is = 15
                scalaDen = 10
            Case Is = 20
                scalaDen = 15
            Case Is = 25
                scalaDen = 20
            Case Is = 30
                scalaDen = 25
            Case Is = 50
                scalaDen = 30
            Case Is = 75
                scalaDen = 50
            Case Is = 100
                scalaDen = 75
            Case Is = 150
                scalaDen = 100
            Case Is = 200
                scalaDen = 150
            Case Is = 250
                scalaDen = 200
            Case Else
                MsgBox "Scala non trovata nell'elenco, definirla manualmente", vbExclamation
                GoTo finally_
            End Select
    ElseIf scalaDen = 1 Then
        Select Case scalaNum
            Case Is = 2
             scalaNum = 2.5
            Case Is = 2.5
             scalaNum = 4
            Case Is = 4
             scalaNum = 5
        Case Else
                MsgBox "Scala non trovata nell'elenco, definirla manualmente", vbExclamation
                GoTo finally_
        End Select
    End If
    
	'Imposta la scala
	
	Dim curTemplateName As String
    curTemplateName = swSheet.GetTemplateName() 'Ottiene il nome del formato foglio corrente
	
	Dim vProps As Variant
    vProps = swSheet.GetProperties() 'Ottiene le proprietà del foglio
	
	Dim paperSize As Integer
    Dim templateType As Integer
    Dim scale1 As Double
    Dim scale2 As Double
    Dim firstAngle As Boolean
    Dim width As Double
    Dim height As Double
    Dim custPrpView As String
    
    paperSize = CInt(vProps(0))     'Salva le proprietà del foglio in nuove variabili
    templateType = CInt(vProps(1))
    scale1 = CDbl(vProps(2))
    scale2 = CDbl(vProps(3))
    firstAngle = CBool(vProps(4))
    width = CDbl(vProps(5))
    height = CDbl(vProps(6))
    custPrpView = swSheet.CustomPropertyView
	
	'Carica un formato vuoto
	Dim noneFormatTest As Boolean
	noneFormatTest = swDraw.SetupSheet5(swSheet.GetName(), paperSize, swDwgTemplateNone, scalaNum, scalaDen, firstAngle, "", width, height, custPrpView, REMOVE_MODIFIED_NOTES)
    
    'Imposta il foglio secondo le variabili precedenti e impone il nuovo formato    'http://help.solidworks.com/2021/english/api/sldworksapi/solidworks.interop.sldworks~solidworks.interop.sldworks.idrawingdoc~setupsheet5.html?verRedirect=1
    'Se il risultato è falso la draw.SetupSheet5 non ha dato buon esito
    If False = swDraw.SetupSheet5(swSheet.GetName(), paperSize, templateType, scalaNum, scalaDen, firstAngle, curTemplateName, width, height, custPrpView, REMOVE_MODIFIED_NOTES) Then
        Err.Raise vbError, "", "Impossibile impostare il formato del foglio" 'Messaggio di errore dell'impostazione del nuovo formato
    End If
	
    ' ' 'Imposta la scala
    ' ' ScaleAnnoPosition = False
    ' ' ScaleAnnoTextHeight = False
    ' ' value = swSheet.SetScale(scalaNum, scalaDen, ScaleAnnoPosition, ScaleAnnoTextHeight)
    
finally_:
        
End Sub

Code: Select all

'RimpScala
'
'Diminuisce la scala del foglio attivo

Const REMOVE_MODIFIED_NOTES As Boolean = True

Dim swApp As SldWorks.SldWorks
Dim swDraw As SldWorks.IDrawingDoc
Dim swSheet As SldWorks.Sheet
Dim sheetProperties As Variant
Dim scalaNum As Double
Dim scalaDen As Double
Dim ScaleAnnoPosition As Boolean
Dim ScaleAnnoTextHeight As Boolean
Dim value As Boolean

Sub main() 'Macro principale

    Set swApp = Application.SldWorks
    Dim swDraw                  As SldWorks.IDrawingDoc
    Dim swSheet                 As SldWorks.Sheet
    
    'Controllo se un file è aperto, se il file è salvato e se il file aperto è un disegno
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then
        MsgBox ("Aprire un file di disegno per eseguire la macro")
        GoTo finally_
    End If
    
    If swModel.GetPathName() = "" Then
        MsgBox ("Salvare il file per eseguire la macro")
        GoTo finally_
    End If
    
    If Not swModel.GetType() = swDocDRAWING Then
        MsgBox ("Aprire un file di disegno per eseguire la macro")
        GoTo finally_
    End If
    
    'Ottiene il foglio di disegno attivo
    Set swDraw = swApp.ActiveDoc
	Set swSheet = swDraw.GetCurrentSheet
	
	'Ottiene le proprietà del foglio attivo
	sheetProperties = swSheet.GetProperties2
	scalaNum = sheetProperties(2)
	scalaDen = sheetProperties(3)
	
	'Imposta le variabili per la scala
	If scalaNum = 1 Then 'Se il numeratore è uguale a 1 allora diminuisci il denominatore
		Select Case ScalaDen
			Case Is = 1
				ScalaDen = 2
			Case Is = 2
				ScalaDen = 2.5
			Case Is = 2.5
				ScalaDen = 4
			Case Is = 4
				ScalaDen = 5
			Case Is = 5
				ScalaDen = 7.5
			Case Is = 7.5
				ScalaDen = 10
			Case Is = 10
				ScalaDen = 15
			Case Is = 15
				ScalaDen = 20
			Case Is = 20
				ScalaDen = 25
			Case Is = 25
				ScalaDen = 30
			Case Is = 30
				ScalaDen = 50
			Case Is = 50
				ScalaDen = 75
			Case Is = 75
				ScalaDen = 100
			Case Is = 100
				ScalaDen = 150
			Case Is = 150
				ScalaDen = 200
			Case Is = 200
				ScalaDen = 250				
			Case Else
				MsgBox "Scala non trovata nell'elenco, definirla manualmente" , vbExclamation
				Goto finally_
			End Select
	ElseIf ScalaDen = 1 Then
		Select Case ScalaNum
			Case Is = 1
				ScalaNum = 1
				ScalaDen = 2
			Case Is = 2
				ScalaNum = 1
			Case Is = 2.5
				ScalaNum = 2
			Case Is = 4
				ScalaNum = 2.5
			Case Is = 5
				ScalaNum = 4
		Case Else
				MsgBox "Scala non trovata nell'elenco, definirla manualmente" , vbExclamation
				Goto finally_
		End Select
	End If
	
	'Imposta la scala
	
	Dim curTemplateName As String
    curTemplateName = swSheet.GetTemplateName() 'Ottiene il nome del formato foglio corrente
	
	Dim vProps As Variant
    vProps = swSheet.GetProperties() 'Ottiene le proprietà del foglio
	
	Dim paperSize As Integer
    Dim templateType As Integer
    Dim scale1 As Double
    Dim scale2 As Double
    Dim firstAngle As Boolean
    Dim width As Double
    Dim height As Double
    Dim custPrpView As String
    
    paperSize = CInt(vProps(0))     'Salva le proprietà del foglio in nuove variabili
    templateType = CInt(vProps(1))
    scale1 = CDbl(vProps(2))
    scale2 = CDbl(vProps(3))
    firstAngle = CBool(vProps(4))
    width = CDbl(vProps(5))
    height = CDbl(vProps(6))
    custPrpView = swSheet.CustomPropertyView
	
	'Carica un formato vuoto
	Dim noneFormatTest As Boolean
	noneFormatTest = swDraw.SetupSheet5(swSheet.GetName(), paperSize, swDwgTemplateNone, scalaNum, scalaDen, firstAngle, "", width, height, custPrpView, REMOVE_MODIFIED_NOTES)
    
    'Imposta il foglio secondo le variabili precedenti e impone il nuovo formato
    'http://help.solidworks.com/2021/english/api/sldworksapi/solidworks.interop.sldworks~solidworks.interop.sldworks.idrawingdoc~setupsheet5.html?verRedirect=1
    'Se il risultato è falso la draw.SetupSheet5 non ha dato buon esito
    If False = swDraw.SetupSheet5(swSheet.GetName(), paperSize, templateType, scalaNum, scalaDen, firstAngle, curTemplateName, width, height, custPrpView, REMOVE_MODIFIED_NOTES) Then
        Err.Raise vbError, "", "Impossibile impostare il formato del foglio" 'Messaggio di errore dell'impostazione del nuovo formato
    End If
	
    ' ' 'Imposta la scala
    ' ' ScaleAnnoPosition = False
    ' ' ScaleAnnoTextHeight = False
    ' ' value = swSheet.SetScale(scalaNum, scalaDen, ScaleAnnoPosition, ScaleAnnoTextHeight)
    
finally_:
        
End Sub

Be aware that these macros will update your drawing formats.

Further investigation lead me to think that this behavior appears only if the original scale of the sheet is different from the ones presents in the file specified here:

So I modified the file adding all the drawing scales we needed, and placed it in a share folder for all our users to have it.

I hope it helps.