Ordre de tracé en VBA

[Invité Patrick]

Est-il possible de modifier l'ordre de tracé (l'ordre d'affichage en fait), en VBA?

[phil_vsd]

Ho oui moi aussi j'aimerai savoir !

[winfield]

tiré de l'aide et légèrement modifié pour le test

Sub TestOrdreTrace()
   Dim ACADPref As AcadDatabasePreferences
   Set ACADPref = ThisDrawing.Preferences
   ACADPref.LineWeightDisplay = True
   
   Dim ObjChoisi1 As AcadEntity
   Dim ObjChoisi2 As AcadEntity
   Dim pt As Variant
   
   ThisDrawing.Utility.GetEntity ObjChoisi1, pt, vbCr & "Selection du 1er objet."
   ThisDrawing.Utility.GetEntity ObjChoisi2, pt, vbCr & "Selection du second objet."
    'Gxet an extension dictionary and, if necessary, add a SortentsTable object
    
   Dim eDictionary As Object
   Set eDictionary = ThisDrawing.ModelSpace.GetExtensionDictionary
   ' Prevent failed GetObject calls from throwing an exception
   On Error Resume Next
   Dim sentityObj As Object
   Set sentityObj = eDictionary.GetObject("ACAD_SORTENTS")
   On Error GoTo 0
   If sentityObj Is Nothing Then
   
        ' No SortentsTable object, so add one
        If Err Then MsgBox Err.Description
        
       Set sentityObj = eDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
   End If
   
   Dim ObjIds(1) As Long
   ObjIds(0) = ObjChoisi1.ObjectID
   ObjIds(1) = ObjChoisi2.ObjectID
   
   Dim varObject As AcadObject
   Set varObject = ThisDrawing.ObjectIdToObject(ObjIds(1))
   Dim arr(0) As AcadObject
   Set arr(0) = varObject
   
   'Move the circle object to the bottom
   sentityObj.MoveToBottom arr
   AcadApplication.Update
End Sub

[phil_vsd]

Allez, on va l'autopsier !

 

Thanks a lot !

[dezhopper]

Bonjour, excuser moi mais d'ou sort le MoveToBottom.

Je ne le trouve pas dans l'aide de autocad.

 

Merci

 

DezHopper

 

[dezhopper]

Pardon de poster une deuxième fois mais je n'ai pas compris le code plus haut, notament le "MoveToBottom", je ne le voie apparaitre nulle part dans l'aide Autocad et ni dans l'aide VBA. C'est une biblio particulière ou alors je rêve???

 

Merci a vous

 

DezHopper

 

 

[winfield]

Slt, je passais dans le coin

 

fait une recherche sur "SortentsTable"

 

 

tj tiré de l'aide :

 

Signature

 

object.MoveToBottom (Objects)

 

object

 

SortentsTable

The object this method applies to.

 

Objects

 

Variant; the objects to move.

 

 

Le code de l'exemple

 

 Sub Example_SortentsTable()
   ' This example creates a SortentsTable object and
   ' changes the draw order.

   ' Set drawing to display lineweights and create a True Color object
   Dim ACADPref As AcadDatabasePreferences
   Set ACADPref = ThisDrawing.Preferences
   ACADPref.LineWeightDisplay = True
   Dim MyColorObjOne As AcadAcCmColor
   Set MyColorObjOne = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.18")
   Call MyColorObjOne.SetRGB(80, 100, 244)
  
   ' Draw a polyline
   Dim plineObj As AcadPolyline
   Dim points(0 To 8) As Double
   points(0) = 4: points(1) = 4: points(2) = 0
   points(3) = 3: points(4) = 5: points(5) = 0
   points(6) = 6: points(7) = 20: points(8) = 0
   Set plineObj = ThisDrawing.ModelSpace.AddPolyline(points)
   plineObj.Lineweight = acLnWt211
   Call MyColorObjOne.SetRGB(90, 110, 150)
   plineObj.TrueColor = MyColorObjOne

   ' Draw a line
   Dim lineObj As AcadLine
   Dim startPoint(0 To 2) As Double
   Dim endPoint(0 To 2) As Double
   startPoint(0) = 5: startPoint(1) = 13: startPoint(2) = 0
   endPoint(0) = 5: endPoint(1) = 27: endPoint(2) = 0
   Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
   lineObj.Lineweight = acLnWt211
   Call MyColorObjOne.SetRGB(50, 80, 230)
   lineObj.TrueColor = MyColorObjOne
    
   ' Draw a circle
   Dim circleObj As AcadCircle
   Dim centerPoint(0 To 2) As Double
   Dim radius As Double
   centerPoint(0) = 10: centerPoint(1) = 15: centerPoint(2) = 0#
   radius = 5#
   Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)
   circleObj.Lineweight = acLnWt211
   Call MyColorObjOne.SetRGB(60, 200, 220)
   circleObj.TrueColor = MyColorObjOne
   ZoomAll
   AcadApplication.Update
     
   'Gxet an extension dictionary and, if necessary, add a SortentsTable object
   Dim eDictionary As Object
   Set eDictionary = ThisDrawing.ModelSpace.GetExtensionDictionary
   ' Prevent failed GetObject calls from throwing an exception
   On Error Resume Next
   Dim sentityObj As Object
   Set sentityObj = eDictionary.GetObject("ACAD_SORTENTS")
   On Error GoTo 0
   If sentityObj Is Nothing Then
        ' No SortentsTable object, so add one
        Set sentityObj = eDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
   End If
   
   Dim ObjIds(2) As Long
   ObjIds(0) = plineObj.ObjectID
   ObjIds(1) = lineObj.ObjectID
   ObjIds(2) = circleObj.ObjectID
   
   Dim varObject As AcadObject
   Set varObject = ThisDrawing.ObjectIdToObject(ObjIds(2))
   Dim arr(0) As AcadObject
   Set arr(0) = varObject
   
   'Move the circle object to the bottom
   sentityObj.MoveToBottom arr
   AcadApplication.Update
        
End Sub
 

 

j'ai testé le code posté mais il ne fonctionne pas, du moins plus ou pas chez moi, maintenant.

J'avais balancé ce code rapidement sans chercher plus loin (à l'époque il fonctionnait, du moins sur mon pc).

 

Désolé du peu d'aide, mais l'informatique n'est plus mon centre du monde