Déplacer l\'ensemble d\'un dessin en VBA

[eagle4]

Salut

 

Je souhaite en VBA déplacer l'ensemble d'un dessin d'un point à un autre afin que l'EXTMIN soit en 0,0

 

 

Merci de votre aide

 

eagle4

[didier]

Salut à Toi, ô EagleFour

il y a quelques temps j'ai fait ça pour déplacer et appliquer une rotation rotation

à un jeu de sélection, à toi de l'arranger pour coller à ton problème :

 

Sub DeplacerEntites()

'Déplacement d'une sélection d'entités Autocad

Dim ObjAcad As AcadApplication

Dim P1(0 To 2) As Double

Dim P2(0 To 2) As Double

Dim AngRotGr As Variant

Dim AngRotRa As Variant

Dim JeuSel As AcadSelectionSet

Dim N As Integer

 

Set ObjAcad = GetObject(, "Autocad.Application")

ObjAcad.Visible = True

 

'Coordonnées du premier point

P1(0) = 0 'x

P1(1) = 0 'y

P1(2) = 0 'z

 

'Coordonnées du deuxième point

P2(0) = 10 'x

P2(1) = 10 'y

P2(2) = 0 'z

 

'angle de rotation en grades

AngRotGr = 100

'on passe en radians

'on ajoute pi pour sens horaire (empirique !)

AngRotRa = AngRotGr / 200 * 3.14159 + 3.14159

 

'Création d'un jeu de sélection

Set JeuSel = ObjAcad.ActiveDocument.SelectionSets.Add("TEST")

 

'Sélection d'entités à l'écran

Call JeuSel.SelectOnScreen

 

'Déplacement des entités sélectionnées

For N = 1 To JeuSel.Count

Call JeuSel.Item(N - 1).Move(P1, P2)

Next N

 

'Rotation des entités sélectionnées de angrot depuis P1

For N = 1 To JeuSel.Count

Call JeuSel.Item(N - 1).Rotate(P1, AngRotRa)

Next N

 

'suppression du jeu de selection

' il est important de le supprimer

'sinon ça plante à la prochaine utilisation

JeuSel.Delete

 

'Mise à jour des entités

ObjAcad.Update

 

 

End Sub

 

 

@micalement

[eagle4]

Salut Didier

 

Merci pour ton prog, c'est plus sympa que la commande "Sendcommand" que j'utilisais.

 

 

@+

 

Eagle4 :yltype:

[didier]

hello l'AigleQuatre

mais de rien, ça existait sur mon disque,

j'ai fait çà, justement pour voir comment éviter le SendCommand

qui, franchement, me déplaît en VBA.

@micalement

 

[eagle4]

Re salut Didier

 

Voici le programme que j'ai modifié :

 

ThisDrawing.Application.ZoomExtents

'ptmin et ptmax sont les points de capture

ptmin = ThisDrawing.GetVariable("EXTMIN")

corner(0) = CInt(ptmin(0))

corner(1) = CInt(ptmin(1))

ptmax = ThisDrawing.GetVariable("EXTMAX")

corner1(0) = CInt(ptmax(0))

corner1(1) = CInt(ptmax(1))

corner2(0) = 0

corner2(1) = 0

 

Set ObjAcad = GetObject(, "Autocad.Application")

ObjAcad.Visible = True

'Création d'un jeu de sélection

Set JeuSel = ObjAcad.ActiveDocument.SelectionSets.Add("TEST")

 

'Sélection d'entités par capture

mode = acSelectionSetCrossing

JeuSel.Select mode, corner, corner1

 

 

'Déplacement des entités sélectionnées

For N = 1 To JeuSel.Count

Call JeuSel.Item(N - 1).Move(corner, corner2)

Next N

'suppression du jeu de selection

' il est important de le supprimer

'sinon ça plante à la prochaine utilisation

JeuSel.Delete

 

'Mise à jour des entités

ObjAcad.Update

ThisDrawing.Application.ZoomExtents

 

Il remplace la commande Sendcommand qui suit :

 

ThisDrawing.SendCommand ("DEPLACER ")

ThisDrawing.SendCommand ("TOUT ")

ThisDrawing.SendCommand (" ")

ThisDrawing.SendCommand (corner(0) & "," & corner(1))

ThisDrawing.SendCommand (" 0,0 ")

ThisDrawing.Application.ZoomExtents

 

Encore merci et @+

 

Eagle4

 

 

;)

[didier]

coucou,

ben c'est ce que disais,

le SendCommand

ne fait pas très "propre".

il est avantageusement remplacé dans ce cas.

ça fait plaisir d'échanger.

ciao