It is currently Wed May 22, 2013 1:37 pm

All times are UTC





Post new topic Reply to topic  [ 7 posts ] 
Author Message
PostPosted: Tue Sep 23, 2008 9:19 am 
Offline
MCAD Contributer

Joined: 19 Feb 2007
Posts: 35
Hi!

I try to write simple macro for coloring drawing view lines from part faces. I use DrawingCurves method. But my macro is very slow. How to increase speed? May i use wrong method?

Code:
Public Sub ColorAllViewAsFaces()
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument

    Dim oActiveSheet As Sheet
    Set oActiveSheet = oDrawDoc.ActiveSheet

    Dim oView As DrawingView
   
    For Each oView In oActiveSheet.DrawingViews
   
        Dim oCurve As DrawingCurve
        Dim oSegment As DrawingCurveSegment
   
        Dim oOcc As ComponentOccurrence
   
        For Each oOcc In oView.ReferencedDocumentDescriptor.ReferencedDocument.ComponentDefinition.Occurrences

            Dim opartdoc As PartDocument
           
            If oOcc.ReferencedDocumentDescriptor.ReferencedDocumentType = kPartDocumentObject Then
           
                Set opartdoc = oOcc.ReferencedDocumentDescriptor.ReferencedDocument
               
                Dim feaenum As PartFeatures
               
                Set feaenum = opartdoc.ComponentDefinition.Features
               
                Dim opf As PartFeature
               
                For Each opf In feaenum
               
                    Dim oface As Face
                   
                    For Each oface In opf.Faces
                   
                        Dim oNewLayer As Layer
                        Dim dcenum As DrawingCurvesEnumerator
                       
                        Set dcenum = oView.DrawingCurves(oface)
                       
                        If Not dcenum Is Nothing Then
                       
                            Dim oRenderStyle As RenderStyle
                       
                            Dim s As String
                       
                            Dim oColor As Inventor.Color
                           
                            Dim red As Byte
                            Dim green As Byte
                            Dim blue As Byte
                           
                            Dim styletype As StyleSourceTypeEnum
                           
                            Set oRenderStyle = oface.GetRenderStyle(styletype)
                           
                            If styletype = kOverrideRenderStyle Then
                           
                                Call oRenderStyle.GetAmbientColor(red, green, blue)
                                       
                                Set oColor = ThisApplication.TransientObjects.CreateColor(red, green, blue)
                               
                                s = "Layer (" + CStr(red) + " " + CStr(green) + " " + CStr(blue) + ")"
                               
                                'check same name
                                Dim l As Layer
                               
                                Dim b As Boolean
                               
                                b = False
                           
                                For Each l In oDrawDoc.StylesManager.Layers
                                    If l.name = s Then
                                        b = True
                                        Exit For
                                    End If
                                Next
                           
                                'if style exist
                                If b Then
                                    Set oNewLayer = oDrawDoc.StylesManager.Layers.Item(s)
                                Else
                                    Set oNewLayer = oDrawDoc.StylesManager.Layers.Item(oView.DrawingCurves(oOcc).Item(1).Segments.Item(1).Layer.name).Copy(s)
                                    oNewLayer.Color = oColor
                                End If
                           
                                'changing layer of line
                                For Each oCurve In dcenum
                                    For Each oSegment In oCurve.Segments
                                        oSegment.Layer = oNewLayer
                                    Next oSegment
                                Next oCurve
                           
                            End If
                        End If
                    Next
                Next
            End If
        Next
    Next
   
End Sub


Tested this code on Inventor 11.


Last edited by AndrewBerezin on Wed Sep 24, 2008 4:03 am, edited 1 time in total.

Share on FacebookShare on TwitterShare on DiggShare on DeliciousShare on TumblrShare on Google+
Top
 Profile  
 
 Post subject:
PostPosted: Tue Sep 23, 2008 2:59 pm 
Offline
MCAD Addict
User avatar

Joined: 22 Mar 2004
Posts: 530
Country: United States
State: Pennsylvania
CAD System: Inventor
<Edit 9/23 11:13PM> Sorry. The image did not load when I first viewed your post. This original code will not do what you want. .... </edit>

_________________
Robert A. Williams
http://www.leacar.com
"Gentlemen...you can't fight here. This is the War Room!"


Top
 Profile  
 
 Post subject:
PostPosted: Wed Sep 24, 2008 4:05 am 
Offline
MCAD Contributer

Joined: 19 Feb 2007
Posts: 35
Reload images.
May be you comment my code what's wrong?


Top
 Profile  
 
 Post subject:
PostPosted: Wed Sep 24, 2008 5:28 pm 
Offline
MCAD Addict
User avatar

Joined: 22 Mar 2004
Posts: 530
Country: United States
State: Pennsylvania
CAD System: Inventor
<EDIT> See post below....

Andrew: This code worked for me. It could use some tweaking but executed very fast for me.

Code:
Private Sub ChangeViewEdgeColorToFaceColor()

Dim invAllSheets As Sheets
Dim invSHEET As Sheet
Dim invAllViews As DrawingViews
Dim invCurrView As DrawingView
Dim invDrawDOC As DrawingDocument
Dim invAllCurves As DrawingCurvesEnumerator
Dim invCURVE As DrawingCurve
Dim invAllSegs As DrawingCurveSegments
Dim invSEG As DrawingCurveSegment
Dim objGEN As Object
Dim invRenderST As RenderStyle
Dim invFace As Face
Dim bytRED As Byte
Dim bytGREEN As Byte
Dim bytBLUE As Byte
Dim invCOLOR As Color
Dim invTO As TransientObjects
Dim invEdgePRX As EdgeProxy
Dim invAllFACES As Faces


    Set invDrawDOC = ThisApplication.ActiveDocument
    Set invTO = ThisApplication.TransientObjects
    Set invCOLOR = invTO.CreateColor(255, 0, 0)
   
    Set invAllSheets = invDrawDOC.Sheets
    For Each invSHEET In invAllSheets
        Set invAllViews = invSHEET.DrawingViews
        For Each invCurrView In invAllViews
            Set invAllCurves = invCurrView.DrawingCurves
            For Each invCURVE In invAllCurves
                Set invAllSegs = invCURVE.Segments
                For Each invSEG In invAllSegs
                    Set objGEN = invSEG.Parent.ModelGeometry
                    If TypeOf objGEN Is EdgeProxy Then
                        Set invEdgePRX = objGEN
                        Set invAllFACES = invEdgePRX.Faces
                        For Each invFace In invAllFACES
                            Set invRenderST = invFace.GetRenderStyle(kOverrideRenderStyle)
                            If Not invRenderST Is Nothing Then
                                invRenderST.GetAmbientColor bytRED, bytGREEN, bytBLUE
                                invCOLOR.SetColor bytRED, bytGREEN, bytBLUE
                                invCURVE.OverrideColor = invCOLOR
                            End If
                        Next invFace
                    End If
                Next invSEG
            Next invCURVE
        Next invCurrView
    Next invSHEET

End Sub

_________________
Robert A. Williams
http://www.leacar.com
"Gentlemen...you can't fight here. This is the War Room!"


Last edited by RobertWilliams on Thu Sep 25, 2008 1:18 am, edited 1 time in total.

Top
 Profile  
 
 Post subject:
PostPosted: Thu Sep 25, 2008 1:17 am 
Offline
MCAD Addict
User avatar

Joined: 22 Mar 2004
Posts: 530
Country: United States
State: Pennsylvania
CAD System: Inventor
After looking at the code I posted above, I realized that it would handle views created from an Assembly (EdgeProxy) but not views created from a single part file (Edge). I reworked the code slightly to handle both situations. This was an interesting exercise :)

This executed fast on an assembly I tried it on with several hundred edges. I used the OverrideColor Property rather than changing the Layer but you could easily incorporate the layer code into the macro.

This macro does not take into consideration the fact that an Edge can border on several Faces that have different colors. It simply gets the color of the last Face processed for that edge.

Code:
Private Sub ChangeViewEdgeColorToFaceColor()

Dim invAllSheets As Sheets
Dim invSHEET As Sheet
Dim invAllViews As DrawingViews
Dim invCurrView As DrawingView
Dim invDrawDOC As DrawingDocument
Dim invAllCurves As DrawingCurvesEnumerator
Dim invCURVE As DrawingCurve
Dim invAllSegs As DrawingCurveSegments
Dim invSEG As DrawingCurveSegment
Dim objGEN As Object
Dim invCOLOR As Color
Dim invTO As TransientObjects
Dim invEdgePRX As EdgeProxy
Dim invEDGE As Edge
Dim invAllFACES As Faces


    Set invDrawDOC = ThisApplication.ActiveDocument
    Set invTO = ThisApplication.TransientObjects
    Set invCOLOR = invTO.CreateColor(255, 0, 0)
   
    Set invAllSheets = invDrawDOC.Sheets
    For Each invSHEET In invAllSheets
        Set invAllViews = invSHEET.DrawingViews
        For Each invCurrView In invAllViews
            Set invAllCurves = invCurrView.DrawingCurves
            For Each invCURVE In invAllCurves
                Set invAllSegs = invCURVE.Segments
                For Each invSEG In invAllSegs
                    Set objGEN = invSEG.Parent.ModelGeometry
                    If TypeOf objGEN Is EdgeProxy Then
                        Set invEdgePRX = objGEN
                        Set invAllFACES = invEdgePRX.Faces
                        ChangeColor invAllFACES, invCOLOR, invCURVE
                    ElseIf TypeOf objGEN Is Edge Then
                        Set invEDGE = objGEN
                        Set invAllFACES = invEDGE.Faces
                        ChangeColor invAllFACES, invCOLOR, invCURVE
                    End If
                Next invSEG
            Next invCURVE
        Next invCurrView
    Next invSHEET

End Sub


Private Sub ChangeColor(ByRef invFACES As Faces, _
                        ByRef invCOLOR As Color, _
                        ByRef invCURVE As DrawingCurve)

Dim invFace As Face
Dim bytRED As Byte
Dim bytGREEN As Byte
Dim bytBLUE As Byte
Dim invRenderST As RenderStyle

    For Each invFace In invFACES
        Set invRenderST = invFace.GetRenderStyle(kOverrideRenderStyle)
        If Not invRenderST Is Nothing Then
            invRenderST.GetAmbientColor bytRED, bytGREEN, bytBLUE
            invCOLOR.SetColor bytRED, bytGREEN, bytBLUE
            invCURVE.OverrideColor = invCOLOR
        End If
    Next invFace
   
End Sub

_________________
Robert A. Williams
http://www.leacar.com
"Gentlemen...you can't fight here. This is the War Room!"


Top
 Profile  
 
 Post subject:
PostPosted: Thu Sep 25, 2008 4:23 am 
Offline
MCAD Contributer

Joined: 19 Feb 2007
Posts: 35
Thanks, Robert. But property OverrideColor of DrawingCurve is only in 2009. In my 11 i shall use layer code.


Top
 Profile  
 
 Post subject:
PostPosted: Tue Sep 30, 2008 7:17 am 
Offline
MCAD Contributer

Joined: 19 Feb 2007
Posts: 35
Layer code for 11:

Code:
Public Sub ChangeViewEdgeColorToFaceColor11()

Dim invAllSheets As Sheets
Dim invSHEET As Sheet
Dim invAllViews As DrawingViews
Dim invCurrView As DrawingView
Dim invDrawDOC As DrawingDocument
Dim invAllCurves As DrawingCurvesEnumerator
Dim invCURVE As DrawingCurve
Dim invAllSegs As DrawingCurveSegments
Dim invSEG As DrawingCurveSegment
Dim objGEN As Object
Dim invCOLOR As Color
Dim invTO As TransientObjects
Dim invEdgePRX As EdgeProxy
Dim invEDGE As Edge
Dim invAllFACES As Faces


    Set invDrawDOC = ThisApplication.ActiveDocument
    Set invTO = ThisApplication.TransientObjects
    Set invCOLOR = invTO.CreateColor(255, 0, 0)
   
    Set invAllSheets = invDrawDOC.Sheets
    For Each invSHEET In invAllSheets
        Set invAllViews = invSHEET.DrawingViews
        For Each invCurrView In invAllViews
            Set invAllCurves = invCurrView.DrawingCurves
            For Each invCURVE In invAllCurves
                Set invAllSegs = invCURVE.Segments
                For Each invSEG In invAllSegs
                    Set objGEN = invSEG.Parent.ModelGeometry
                    If Not objGEN Is Nothing Then
                        If TypeOf objGEN Is EdgeProxy Then
                            Set invEdgePRX = objGEN
                            Set invAllFACES = invEdgePRX.Faces
                            ChangeColor11 invAllFACES, invCOLOR, invSEG
                        ElseIf TypeOf objGEN Is Edge Then
                            Set invEDGE = objGEN
                            Set invAllFACES = invEDGE.Faces
                            ChangeColor11 invAllFACES, invCOLOR, invSEG
                        End If
                    End If
                Next invSEG
            Next invCURVE
        Next invCurrView
    Next invSHEET

End Sub


Private Sub ChangeColor11(ByRef invFACES As Faces, _
                        ByRef invCOLOR As Color, _
                        ByRef invSEG As DrawingCurveSegment)

Dim invFace As Face
Dim bytRED As Byte
Dim bytGREEN As Byte
Dim bytBLUE As Byte
Dim invRenderST As RenderStyle
Dim oDrawDoc As DrawingDocument

Set oDrawDoc = ThisApplication.ActiveDocument

    For Each invFace In invFACES
        Set invRenderST = invFace.GetRenderStyle(kOverrideRenderStyle)
        If Not invRenderST Is Nothing Then
            invRenderST.GetAmbientColor bytRED, bytGREEN, bytBLUE
            invCOLOR.SetColor bytRED, bytGREEN, bytBLUE
           
            Dim oNewLayer As Layer
            Dim s As String
            s = "Layer (" + CStr(bytRED) + " " + CStr(bytGREEN) + " " + CStr(bytBLUE) + ")"
                       
            Dim l As Layer
            Dim b As Boolean
            Dim idx As Integer
            idx = 0
            b = False
            For Each l In oDrawDoc.StylesManager.Layers
                idx = idx + 1
                If l.name = s Then
                    b = True
                    Exit For
                End If
            Next
           
            If b Then
                Set oNewLayer = oDrawDoc.StylesManager.Layers.Item(s)
            Else
                Set oNewLayer = invSEG.Layer.Copy(s)
                oNewLayer.Color = invCOLOR
            End If
           
            invSEG.Layer = oNewLayer
        End If
    Next invFace
   
End Sub


Top
 Profile  
 
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 7 posts ] 

All times are UTC


Who is online

Users browsing this forum: No registered users and 0 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot post attachments in this forum

Search for:
Jump to:  
POWERED_BY