[iLogic / VBA ] Change drawingcurves color based of property (e.g. Description)

[Luisfmts]

Hi Folks,

I have something in mind, but idk where i'm missing the point on the way:

I'd like to change the color of the drawing curves based on a property of the part or assembly e.g.: if description = "blue" then drawing curves of the assy (or part).color = 0,0,255.

Is there a simple way for doing this?

For VBA and up to the part of differentiation of the disered description i get it...I'm almost sure my problem is how to get the drawing curves from the part (or assy) that is a match, and change its properties.

I'd appreciate any ideas

[Anonymous]

Hi. No idea. 

Sub PickToPaint()

    Dim oDocActive As Document
    Set oDocActive = ThisApplication.ActiveDocument
         
    If oDocActive.DocumentType = kDrawingDocumentObject Then
        
        Dim oDrgDoc As DrawingDocument
        Set oDrgDoc = oDocActive
                      
        Dim oSheet As sheet
        Set oSheet = oDrgDoc.ActiveSheet
        
        Dim drawView As DrawingView
        
        Set drawView = ThisApplication.CommandManager.Pick( _
                 kDrawingViewFilter, "Pick DrawingView to paint..")
       
        If drawView Is Nothing Then Exit Sub
        
        PaintDrawingView drawView ', ThisApplication.TransientObjects.CreateColor(0, 255, 0)
                
    Else
        MsgBox "This macro works in IDW"
    End If
End Sub

Sub PaintDrawingView(oDrawingView As DrawingView, Optional oColor As color = Nothing)
     
    Dim paintColor As color
    
    If oColor Is Nothing Then
        Dim oRefFileDesc As ReferencedFileDescriptor
        Set oRefFileDesc = oDrawingView.ReferencedFile
    
        Dim oDoc As Document
        Set oDoc = oRefFileDesc.DocumentDescriptor.ReferencedDocument
   
        Dim opropsets As PropertySets
        Set opropsets = oDoc.PropertySets
            
        Dim oPropDescription As Property
        Set oPropDescription = opropsets.item("{32853F0F-3444-11d1-9E93-0060B03C1CA6}").ItemByPropId(kDescriptionDesignTrackingProperties)
                     
        Select Case oPropDescription.Value
            Case "Blue", "blue", "BLUE"
                Set paintColor = ThisApplication.TransientObjects.CreateColor(0, 0, 255)
            Case "Red", "red", "RED"
                Set paintColor = ThisApplication.TransientObjects.CreateColor(255, 0, 0)
            Case Else
                Set paintColor = ThisApplication.TransientObjects.CreateColor(128, 128, 128)
        End Select
   Else
    Set paintColor = oColor
   End If
   
    Dim oDrawingCurve As DrawingCurve

    For Each oDrawingCurve In oDrawingView.DrawingCurves
        oDrawingCurve.color = paintColor
    Next oDrawingCurve
End Sub

For Each oDrawingCurve In oDrawingView.DrawingCurves
    Select Case oDrawingCurve.CurveType
        Case _
            CurveTypeEnum.kCircleCurve:
                oDrawingCurve.color = ThisApplication.TransientObjects.CreateColor(255, 255, 0)
        Case _
            CurveTypeEnum.kCircularArcCurve, _
            CurveTypeEnum.kEllipseFullCurve, _
            CurveTypeEnum.kEllipticalArcCurve:
            
            If oDrawingCurve.EdgeType = DrawingEdgeTypeEnum.kThreadEdge Then
            
            Else
            
            End If
        
        Case _
            CurveTypeEnum.kLineCurve, _
            CurveTypeEnum.kLineSegmentCurve:
        
            If oDrawingCurve.EdgeType = DrawingEdgeTypeEnum.kBendDownEdge Then
            
            ElseIf oDrawingCurve.EdgeType = DrawingEdgeTypeEnum.kBendUpEdge Then
            
            ElseIf oDrawingCurve.EdgeType = DrawingEdgeTypeEnum.kBendExtentEdge Then
            
            Else
            
            End If
                
        Case CurveTypeEnum.kPolylineCurve:
            'MsgBox ("Polyline") 'reserved for later
                
        Case CurveTypeEnum.kBSplineCurve:
             oDrawingCurve.color = ThisApplication.TransientObjects.CreateColor(255, 255, 255)
            
        Case CurveTypeEnum.kUnknownCurve:
            'MsgBox ("Unknown") 'reserved for later
        Case Else:
        
    End Select
Next oDrawingCurve

[Luisfmts]

Wow...that was cool, and ellegant piece of code... Worked very well for top referenced document.

I'm wondering if it could be adapted to get the result as image attached (one view with one assembly, multiple parts, each part different color)

I think i'm stucking on this part:

    For Each oDrawingCurve In oDrawingView.DrawingCurves
        oDrawingCurve.color = paintColor
    Next oDrawingCurve

I was thinking instead of getting all drawing curves on the view get only the ones of the occurrence:

    For Each oDrawingCurve In oDrawingView.oOccurrence.DrawingCurves
        oDrawingCurve.color = paintColor
    Next oDrawingCurve

What do you think?

[Anonymous · Accepted solution]

Hi Luis.

If there are sub assemblies you must find a better way.

This is for all levels of parts - only.

Sub PickDrawingViewToPaintParts()
    Dim oDocActive As Document
    Set oDocActive = ThisApplication.ActiveDocument
         
    If oDocActive.DocumentType = kDrawingDocumentObject Then
        
        Dim oDrgDoc As DrawingDocument
        Set oDrgDoc = oDocActive
                             
        Dim drawView As DrawingView
        
        Set drawView = ThisApplication.CommandManager.Pick( _
                 kDrawingViewFilter, "Pick DrawingView to paint..")
       
        If drawView Is Nothing Then Exit Sub
        
        PaintPartsInDrawingView drawView
                
    Else
        MsgBox "This macro works in IDW"
    End If
End Sub

Sub PaintPartsInDrawingView(oDrawingView As DrawingView)
     
    Dim paintColor          As color
    Dim oDrawingCurve       As DrawingCurve
    Dim descriptionString   As String
    Dim bDoNotPaint         As Boolean
    On Error Resume Next

    For Each oDrawingCurve In oDrawingView.DrawingCurves
        
        bDoNotPaint = False
        descriptionString = Get_DocDescription(oDrawingCurve.ModelGeometry.ContainingOccurrence.Definition.Document)
        If Err.Number = 0 Then
            Select Case descriptionString
                Case "Blue", "blue", "BLUE"
                    Set paintColor = ThisApplication.TransientObjects.CreateColor(0, 0, 255)
                Case "Red", "red", "RED"
                    Set paintColor = ThisApplication.TransientObjects.CreateColor(255, 0, 0)
                Case "Yellow", "yellow", "YELLOW"
                    Set paintColor = ThisApplication.TransientObjects.CreateColor(255, 255, 0)
                Case "Green", "green", "GREEN"
                    Set paintColor = ThisApplication.TransientObjects.CreateColor(0, 255, 0)
                Case Else
                    bDoNotPaint = True
                    ''Set paintColor = ThisApplication.TransientObjects.CreateColor(0, 0, 0)
            End Select
            If Not bDoNotPaint Then oDrawingCurve.color = paintColor
        Else
            ''oDrawingCurve.color = don't paint this curve
            Err.Clear
        End If
        
    Next oDrawingCurve
    
    MsgBox "Complete"
End Sub

Function Get_DocDescription(oDoc As Document) As String

    Dim oDocPropSets As PropertySets
    
    Dim oDocPropDescription As Property
    Dim oDocDescription As String
    
    Set oDocPropSets = oDoc.PropertySets
    
    Set oDocPropDescription = oDocPropSets.item("{32853F0F-3444-11d1-9E93-0060B03C1CA6}") _
        .ItemByPropId(kDescriptionDesignTrackingProperties)
    oDocDescription = oDocPropDescription.Value
    
    Get_DocDescription = oDocDescription
    
End Function

My poor codes.

[Luisfmts]

Hi hrnkilic. That worked just fine for parts only (just tested). Thanks 🍺🍺

[404: no poor codes found]