Sub ViewColor()
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    
    Dim oView As DrawingView
    
    For Each oView In oDrawDoc.ActiveSheet.DrawingViews
        Call ObjectLineManage(oView)
    Next
    
    MsgBox "Finished"
End Sub

Function ObjectLineManage(oView As DrawingView)
    Dim oDrawingCurve As DrawingCurve
    Dim oModelGeo As Object
    Dim oDoc As ComponentOccurrence

    Dim oDrawingDoc As DrawingDocument
    Set oDrawingDoc = oView.Parent.Parent
    
    Dim oCompName As String
    oCompName = ""
    
    Dim oNewLayer As Layer
                
    For Each oDrawingCurve In oView.DrawingCurves
        Set oModelGeo = oDrawingCurve.ModelGeometry
        Set oDoc = oModelGeo.Parent.Parent

        On Error Resume Next
        
        Dim oLayerExist As Boolean
        oLayerExist = False
        
        If oCompName = "" Then
            oCompName = oDoc.Name
            
            For i = 1 To oDrawingDoc.StylesManager.Layers.Count
                If oDrawingDoc.StylesManager.Layers(i).Name = oDoc.Name Then
                    oLayerExist = True
                    Set oNewLayer = oDrawingDoc.StylesManager.Layers(i)
                    Exit For
                End If
            Next
            
            If oLayerExist = False Then
                Set oNewLayer = oDrawingDoc.StylesManager.Layers.Item("Visible (ANSI)").Copy(oDoc.Name)
            End If
        ElseIf InStr(oCompName, oDoc.Name) = 0 Then
            oCompName = oDoc.Name & ";" & oCompName
            
            For j = 1 To oDrawingDoc.StylesManager.Layers.Count
                If oDrawingDoc.StylesManager.Layers(j).Name = oDoc.Name Then
                    oLayerExist = True
                    Set oNewLayer = oDrawingDoc.StylesManager.Layers(j)
                    Exit For
                End If
            Next
            
            If oLayerExist = False Then
                Set oNewLayer = oDrawingDoc.StylesManager.Layers.Item("Visible (ANSI)").Copy(oDoc.Name)
            End If
        End If
        
        If InStr(oDoc.Name, oNewLayer.Name) > 0 Then
            For k = 1 To oDrawingCurve.Segments.Count
               oDrawingCurve.Segments(k).Layer = oNewLayer
            Next
        End If
    Next
End Function