comme réseau mais pas complètement

[nazemrap]

Bonjour.

 

J'ai eu besoin de cela:

copier un ou des objets plusieurs fois à une distance donnée, suivant l'axe des X (éventuellement orienté), sans gérer les colonnes, sur une ligne donc.

Si ça peut servir ....

Si j'ai fait des bétises,

je veux bien qu'on me le dise.

 

Dim cppt() As AcadEntity
Dim point(0 To 2) As Double
Dim distance As Double
Dim plus As Double
Dim nombre As Double
Dim pnt As Variant
Dim selection_objets As AcadSelectionSet
Dim obj As AcadEntity
Dim selec As AcadSelectionSet

Public Sub copie_fois_distance()
distance = 0

For Each selec In ThisDrawing.SelectionSets
If selec.Name = "selecobj" Then selec.Delete: Exit For
Next

Set selection_objets = ThisDrawing.SelectionSets.Add("selecobj")
selection_objets.SelectOnScreen

pnt = ThisDrawing.Utility.GetPoint(, "Quel est le point de base? ")
point(0) = pnt(0): point(1) = pnt(1): point(2) = pnt(2)

nombre = InputBox("combien d'objets ?")
plus = InputBox("Quelle distance ?")
nombre = nombre + 1
ReDim cppt(nombre)

For Each obj In selection_objets

For tour = 1 To nombre
point(0) = pnt(0): point(1) = pnt(1): point(2) = pnt(2)
Set cppt(tour) = obj.Copy
point(0) = point(0) + distance

' Transcrit les points en coordonnées générales
   Dim pointUCS1 As Variant
   Dim pointUCS2 As Variant
   pointUCS1 = ThisDrawing.Utility.TranslateCoordinates(pnt, acUCS, acWorld, False)
   pointUCS2 = ThisDrawing.Utility.TranslateCoordinates(point, acUCS, acWorld, False)

cppt(tour).Move pointUCS1, pointUCS2
distance = distance + plus
Next
distance = 0
Next

ThisDrawing.SelectionSets("selecobj").Delete
End Sub