AnsweredAssumed Answered

Drawing update macro: sheet format - ok, colors (dimensions, centerlines, center marks, datum tags) - ok, drawing template - missing, colors (balloons, cut list properties note, tolerance boxes) - missing. Could anyone help?

Question asked by Wojciech Pogorzelski on Jul 15, 2017
Latest reply on Jul 15, 2017 by Deepak Gupta

Hello everybody,

I spend hours searching forums and API help for a solution and here is where I got so far.

I have a macro, combined from a few different ones, that updates drawings sheets on an open drawing. So far the macro does:

- checks if SW file is open with message box if not

- checks if SW drawing is open with message box if not

- updates a sheet format on all sheets by removing an old one and loading a new one (a3 - iso.slddrt)

- updates colors for: dimensions, centerlines, center marks, datum tags

- saves the file

*macro works only on an active drawing.

 

Next thing I would like to add is an drawing template change/update based on whether the drawing was created from a part model nor assembly.

Generally I use one sheet format for all the drawings except I have two different templates: one for assemblies and one for parts.

I wasn't able to get even close to what I need with this problem.

Could anyone help me with that?

 

I'm also having trouble with a color change of some other features on a drawing like:

- balloons (Balloon - not working)

- annotations=>cut list properties note only (Note - works for all the notes)

- tolerance boxes (Gtol - not working).

 

=======================================================================================

'Colors in RGB:

'------------------------------

'Black (0, 0, 0)

'Blue (0, 0, 255)

'Green (0, 255, 0)

'Cyan (0, 255, 255)

'Red (255, 0, 0)

'Magenta (255, 0, 255)

'Yellow (255, 255, 0)

'------------------------------

Option Explicit

 

Dim swApp                       As SldWorks.SldWorks

Dim swModel                     As SldWorks.ModelDoc2

Dim swDraw                      As SldWorks.DrawingDoc

'Sheet format update:

Dim swSheet                     As SldWorks.Sheet

Dim vSheetProps                 As Variant

Dim vSheetName                  As Variant

Dim vTemplateName               As Variant

Dim longstatus                  As Long

Dim longwarnings                As Long

Dim nErrors                     As Long

Dim nWarnings                   As Long

Dim i                           As Long

'Colors update:

Dim swView                      As SldWorks.View

Dim swCenterLine                As SldWorks.Centerline

Dim swCenterMark                As SldWorks.CenterMark

Dim swDispDim                   As SldWorks.DisplayDimension

Dim swDispGtol                  As SldWorks.Gtol

Dim swDatumTag                  As SldWorks.DatumTag

Dim swNote                      As SldWorks.Note

Dim swBalloon                   As SldWorks.BalloonStack

Dim swAnn                       As SldWorks.Annotation

 

Sub main()

 

On Error Resume Next

 

Set swApp = Application.SldWorks

Set swModel = swApp.ActiveDoc

 

'-----------------------------------------------------------------

'Is SW file open?

If swModel Is Nothing Then

    swApp.SendMsgToUser2 "                     SheetFormat Update" & vbNewLine & "" & vbNewLine & "                            Otwórz plik!", swMbWarning, swMbOk

    Exit Sub

End If

 

'-----------------------------------------------------------------

'Is SW drawing open?

If swModel.GetType <> swDocDRAWING Then

    swApp.SendMsgToUser2 "                     SheetFormat Update" & vbNewLine & "" & vbNewLine & "                         Otwórz rysunek!", swMbWarning, swMbOk

    Exit Sub

End If

 

Set swDraw = swModel

 

'-----------------------------------------------------------------

'Sheet format update (a3 - iso.slddrt)

   

    vSheetName = swDraw.GetSheetNames

 

    For i = 0 To UBound(vSheetName)

 

        swDraw.ActivateSheet vSheetName(i)

        Set swSheet = swDraw.GetCurrentSheet

       

        'Get the current drawing sheet format from this sheet

        vTemplateName = swSheet.GetTemplateName

       

        vSheetProps = swSheet.GetProperties

   

    'Sheet format delete:

    swModel.SetupSheet5 swSheet.GetName, swDwgPapersUserDefined, swDwgTemplateNone, vSheetProps(2), vSheetProps(3), True, "", vSheetProps(5), vSheetProps(6), "Default", True

   

    'Sheet format load:

    swModel.SetupSheet5 swSheet.GetName, swDwgPapersUserDefined, swDwgTemplateCustom, vSheetProps(2), vSheetProps(3), True, "a3 - iso.slddrt", vSheetProps(5), vSheetProps(6), "Default", True

 

    swDraw.ViewZoomtofit2

   

'-----------------------------------------------------------------

'Colors update

   

Set swView = swDraw.GetFirstView

           

    Do While Not swView Is Nothing

               

        '(DisplayDimension) - color replacement

        Set swDispDim = swView.GetFirstDisplayDimension

        Do While Not swDispDim Is Nothing

            Set swAnn = swDispDim.GetAnnotation

            swAnn.Color = RGB(0, 0, 255) 'color in RGB or...

            'swAnn.Color = 16711680 'color in decimal

            Set swDispDim = swDispDim.GetNext

        Loop

       

        '(CenterLine) - color replacement

        Set swCenterLine = swView.GetFirstCenterLine

        Do While Not swCenterLine Is Nothing

            Set swAnn = swCenterLine.GetAnnotation

            swAnn.Color = RGB(128, 0, 0) 'color in RGB or...

            Set swCenterLine = swCenterLine.GetNext

        Loop

       

        '(CenterMark) - color replacement

        Set swCenterMark = swView.GetFirstCenterMark

        Do While Not swCenterMark Is Nothing

            Set swAnn = swCenterMark.GetAnnotation

            swAnn.Color = RGB(128, 0, 0) 'color in RGB or...

            Set swCenterMark = swCenterMark.GetNext

        Loop

                       

        '(DatumTag) - color replacement

        Set swDatumTag = swView.GetFirstDatumTag

        Do While Not swDatumTag Is Nothing

            Set swAnn = swDatumTag.GetAnnotation

            swAnn.Color = RGB(128, 0, 0) 'color in RGB or...

            Set swDatumTag = swDatumTag.GetNext

        Loop

                           

        '(Balloon) - color replacement - NOT WORKING

        'Set swBalloon = swView.GetFirstBalloonStack

        'Do While Not swBalloon Is Nothing

            'Set swAnn = swBalloon.GetAnnotation

            'swAnn.Color = RGB(0, 0, 255) 'color in RGB or...

            'Set swBalloon = swBalloon.GetNext

        'Loop

       

        '(Note) - color replacement - NOT WORKING (works for all the notes, need only for annotations=>cut list properties note)

        'Set swNote = swView.GetFirstNote

        'Do While Not swNote Is Nothing

            'Set swAnn = swNote.GetAnnotation

            'swAnn.Color = RGB(128, 0, 0) 'color in RGB or...

            'Set swNote = swNote.GetNext

        'Loop

                           

        '(Gtol) - color replacement - NOT WORKING

        'Set swDispGtol = swView.GetFirstGTOL

        'Do While Not swDispGtol Is Nothing

            'Set swAnn = swDispGtol.GetAnnotation

            'swAnn.Color = RGB(128, 0, 0) 'color in RGB or...

            'Set swDispGtol = swDispGtol.GetNext

        'Loop

       

        Set swView = swView.GetNextView

    Loop

'-----------------------------------------------------------------

Next i

 

    swDraw.ActivateSheet vSheetName(0)

    swDraw.ForceRebuild3 False

       

Set swDraw = Nothing

 

End Sub

 

=======================================================================================

Outcomes