Attribute VB_Name = "CHANGE2DCOLOR"
'========================================================'  '========================================================'
'===========       SEB         COLLECTIONS    ==========='  '===========                     TO DO        ==========='
'========================================================'  '========================================================'
' Created By : BENAVIDES Sebastien                      ='  '                                                        '
' Update By  : BENAVIDES Sebastien                      ='  '- one shoot choice all view                             '
' Version    : V.1.0                                    ='  '-                                                       '
' Update     : 11 April 2016                            ='  '-                                                       '
'========================================================'  '-                                                       '
' Description:                                          ='  '-                                                       '
' Auto color for GUERIN SYSTEMS TETRA PAK               ='  '                                                        '
' Auto color for GUERIN SYSTEMS TETRA PAK               ='  '                                                        '
'========================================================'  '========================================================'

Public Sub Change2DLayer()

    Dim oDoc As DrawingDocument
    Set oDoc = ThisApplication.ActiveDocument
    ' choice the view to modify and apply a filter for the user not to click somewhere else
    Dim drawView As DrawingView
    Dim Choose As String
'    Dim QuestionTo As String
'    QuestionTo = "Do you want to apply the macros for all views "
'    Choose = MsgBox(QuestionTo, vbYesNo, "Multi views or not")
'    If Choose = vbNo Then
'        '******single drawing view
'        'jumptonextsection
'    Else
        '******every drawing view
        Dim tmpSheet As Sheet
        Set tmpSheet = oDoc.ActiveSheet
        Dim tmpView As DrawingView
'    End If
'    On Error Resume Next
    For Each tmpView In tmpSheet.DrawingViews
'        If Err.Number = 91 Then
'            Set drawView = ThisApplication.CommandManager.Pick(kDrawingViewFilter, "Select the view to apply color")
'            Err.Number = 0
'        Else
            Set drawView = tmpView
'        End If
        Dim docDes As DocumentDescriptor
        Set docDes = drawView.ReferencedDocumentDescriptor
        ' only assembly for now
        If docDes.ReferencedDocumentType <> kAssemblyDocumentObject Then
            MsgBox "This programme is made for assembly only"
        Exit Sub
        End If
        ' get the conponenet defin to get occ after
        Dim ascomDef As AssemblyComponentDefinition
        Set ascomDef = docDes.ReferencedDocument.ComponentDefinition
        ' make a new fonction
        Call fonctionChange2DLayer(drawView, ascomDef.Occurrences)
     Next
    MsgBox "Done"
End Sub
Private Sub fonctionChange2DLayer(drawView As DrawingView, Occurrences As ComponentOccurrences)
    ' Iterate through the current collection of occurrences.
    Dim occ As ComponentOccurrence
    Dim mystring As String
    mystring = drawView.ReferencedDocumentDescriptor.DisplayName
    If mystring Like "*E100.iam" Then
        '******* here E100
        Dim occsub As ComponentOccurrence
        Dim endnb As Long
        For i = 1 To Occurrences.Count
            For Each occsub In Occurrences.Item(i).SubOccurrences
                ' Get the appearance color asset first
                Dim color As Asset
                Set color = occsub.Appearance
                ' TransientsObjects
                Dim transObjs As TransientObjects
                Set transObjs = ThisApplication.TransientObjects
                ' Verify that a layer exists for this color.
                Dim layers As LayersEnumerator
                Set layers = drawView.Parent.Parent.StylesManager.layers
                Dim oDoc As DrawingDocument
                Set oDoc = drawView.Parent.Parent
                On Error Resume Next
                Dim mystringcolor As String
                mystringcolor = color.DisplayName
                Dim goodname As String
                If color.DisplayName Like "*_*" Then
                    goodname = Right$(mystringcolor, Len(mystringcolor) - InStrRev(mystringcolor, "_"))
                    goodname = goodname
                    mystringcolor = Left$(goodname, InStrRev(goodname, "(") - 2)
                End If
                If color.DisplayName = "default" Then
                    mystringcolor = 0
                End If
                Dim colorLayer As Layer
                Set colorLayer = layers.Item(mystringcolor)
                If Err.Number = 5 Then
                    MsgBox "the layer " & mystringcolor & " doesn't exist in layers collection  for " & occsub.Name
                    Dim YesOrNo As String
                    Dim QuestionTo As String
                    QuestionTo = "Do you really want to add " & mystringcolor & " in your dwg"
                    YesOrNo = MsgBox(QuestionTo, vbYesNo, "Create Layer on dwg")
                'this should only be use in singapore
                    If YesOrNo = vbNo Then
                        MsgBox "Ok then i don't change the color of those lines"
                    Else
                        ' create color from scratch
                        Dim red As Byte
                        Dim green As Byte
                        Dim blue As Byte
                        ' get the color from the appearance
                        Dim colorappear As RenderStyle
                        Dim appeartype As AppearanceSourceTypeEnum
                        Set colorappear = occsub.GetRenderStyle(appeartype)
                        Call colorappear.GetDiffuseColor(red, green, blue)
                        Dim newColor As color
                        Set newColor = transObjs.CreateColor(red, green, blue)
                        ' copy the 1st layer in database with is 0
                        Set colorLayer = layers.Item(1).Copy(mystringcolor)
                        ' Set the same atribute as the 0 for weight and type
                        colorLayer.color = newColor
                        colorLayer.LineType = layers.Item(1).LineType
                        colorLayer.LineWeight = layers.Item(1).LineWeight
                        Err.Number = 0
                    End If
                End If
                ' Get all of the curves associated with this occurrence
                If Err.Number = 0 And mystringcolor <> 0 Then
                    Dim drawcurves As DrawingCurvesEnumerator
                    Set drawcurves = drawView.DrawingCurves(occsub)
                    ' Create an empty collection.
                    Dim objColl As ObjectCollection
                    Set objColl = transObjs.CreateObjectCollection()
                    ' Add the curve segments to the collection.
                    Dim drawCurve As DrawingCurve
                    For Each drawCurve In drawcurves
                        Dim segment As DrawingCurveSegment
                        For Each segment In drawCurve.Segments
                            objColl.Add segment
                        Next
                    Next
                    ' Change the layer of all of the segments.
                    Call drawView.Parent.ChangeLayer(objColl, colorLayer)
                End If
                Err.Number = 0
            Next
        Next
    Else
        For Each occ In Occurrences
            'Get the appearance color asset first
            Dim colorExx As Asset
            Set colorExx = occ.Appearance
            'TransientsObjects
            Dim transObjsExx As TransientObjects
            Set transObjsExx = ThisApplication.TransientObjects
            ' Verify that a layer exists for this color.
            Dim layersExx As LayersEnumerator
            Set layersExx = drawView.Parent.Parent.StylesManager.layers
            Dim oDocExx As DrawingDocument
            Set oDocExx = drawView.Parent.Parent
            On Error Resume Next
            Dim mystringcolorExx As String
            mystringcolorExx = colorExx.DisplayName
            Dim goodnameExx As String
            If colorExx.DisplayName Like "*_*" Then
                goodnameExx = Right$(mystringcolorExx, Len(mystringcolorExx) - InStrRev(mystringcolorExx, "_"))
                goodnameExx = goodnameExx
                mystringcolorExx = Left$(goodnameExx, InStrRev(goodnameExx, "(") - 2)
            End If
            If colorExx.DisplayName = "Default" Then
                mystringcolorExx = 0
            End If
            
            Dim colorLayerExx As Layer
            Set colorLayerExx = layersExx.Item(mystringcolorExx)
            If Err.Number = 5 Then
                MsgBox "the layer " & mystringcolorExx & " doesn't exist in layers collection  for " & occ.Name
                    Dim YesOrNoExx As String
                    Dim QuestionToExx As String
                    QuestionToExx = "Do you really want to add " & mystringcolorExx & " in your dwg"
                    YesOrNoExx = MsgBox(QuestionToExx, vbYesNo, "Create Layer on dwg")
                    If YesOrNoExx = vbNo Then
                        MsgBox "Ok then i don't change the color of those lines"
                    Else
                     'this should only be use in singapore
                        ' create color from scratch
                        Dim redExx As Byte
                        Dim greenExx As Byte
                        Dim blueExx As Byte
                        ' get the color from the appearance
                        Dim colorappearExx As RenderStyle
                        Dim appeartypeExx As AppearanceSourceTypeEnum
                        Set colorappearExx = occ.GetRenderStyle(appeartypeExx)
                        Call colorappearExx.GetDiffuseColor(redExx, greenExx, blueExx)
                        Dim newColorExx As color
                        Set newColorExx = transObjsExx.CreateColor(redExx, greenExx, blueExx)
                        ' copy the 1st layer in database with is 0
                        Set colorLayerExx = layersExx.Item(1).Copy(mystringcolorExx)
                        ' Set the same atribute as the 0 for weight and type
                        colorLayerExx.color = newColorExx
                        colorLayerExx.LineType = layersExx.Item(1).LineType
                        colorLayerExx.LineWeight = layersExx.Item(1).LineWeight
                        Err.Number = 0
                    End If
            End If
            ' Get all of the curves associated with this occurrence.
            If Err.Number = 0 And mystringcolorExx <> 0 Then
                Dim drawcurvesExx As DrawingCurvesEnumerator
                Set drawcurvesExx = drawView.DrawingCurves(occ)
                ' Create an empty collection.
                Dim objCollExx As ObjectCollection
                Set objCollExx = transObjsExx.CreateObjectCollection()
                ' Add the curve segments to the collection.
                Dim drawCurveExx As DrawingCurve
                For Each drawCurveExx In drawcurvesExx
                    Dim segmentExx As DrawingCurveSegment
                    For Each segmentExx In drawCurveExx.Segments
                        objCollExx.Add segmentExx
                    Next
                Next
                ' change layer ofcollectionsegment
                Call drawView.Parent.ChangeLayer(objCollExx, colorLayerExx)
            End If
            Err.Number = 0
        Next
    End If
End Sub