rectangle spécial avec gestion @

[sechanbask]

bonjour,

je cherche à créer un rectangle avec les diagonnales dessinées en pointant 2 points. J'y suis arrivé mais je ne trouve pas comme faire pour que les coordonnées relatives soient fonctionnelles dans le cas où je veux faire ce rectangle en entrant pour le second point : @X,Y

 

voilà mon code qui sait faire le rectangle et les diagonales utilisant 2 points pointés :

 

 Option Explicit

Dim PTA As Variant
Dim PTB As Variant
Dim pt1(1) As Double
Dim pt2(1) As Double
Dim pt3(1) As Double
Dim pt4(1) As Double
Dim Obj_Decal As AcadLWPolyline
Dim points(0 To 15) As Double
Dim Decal_Obj As Variant

Sub rec()
PTA = ThisDrawing.Utility.GetPoint(, "Indiquer le premier coin :")
PTB = ThisDrawing.Utility.GetPoint(, "Indiquer le seconde coin")

pt1(0) = PTA(0): pt1(1) = PTA(1)
pt2(0) = PTB(0): pt2(1) = PTB(1)
pt3(0) = pt2(0): pt3(1) = pt1(1)
pt4(0) = pt1(0): pt4(1) = pt2(1)

points(0) = pt1(0): points(1) = pt1(1)
points(2) = pt3(0): points(3) = pt3(1)
points(4) = pt2(0): points(5) = pt2(1)
points(6) = pt4(0): points(7) = pt4(1)
points(8) = pt1(0): points(9) = pt1(1)
points(10) = pt2(0): points(11) = pt2(1)
points(12) = pt3(0): points(13) = pt3(1)
points(14) = pt4(0): points(15) = pt4(1)

Set Obj_Decal = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
With Obj_Decal
.Closed = True
.Update
End With

End Sub

 

s'il y a moyen d'alléger le code, je suis preneur... Ainsi que pour lancer la commande cotation rapide (pour coter un des coté du rectangle puisque que c'est pour faire de réservations de traversée de voile béton).

MERCI par anticipation

 

[Edité le 18/12/2006 par sechanbask]

[nazemrap]

Bonjour,

 

Peut-être une piste..

 

    
Option Explicit

Dim PTA As Variant
'Dim PTB As Variant
Dim PTB(0 To 1) As Double
Dim Obj_Decal As AcadLWPolyline
Dim points(0 To 15) As Double
Dim Decal_Obj As Variant

Sub rec()
PTA = ThisDrawing.Utility.GetPoint(, "Indiquer le premier coin :")
'PTB = ThisDrawing.Utility.GetPoint(, "Indiquer le second coin")
'possible de répondre sur la ligne de commande en 2 fois : x puis y
   Dim deltax As Double
   Dim deltay As Double
   deltax = ThisDrawing.Utility.GetReal("Entrer delta x: ")
   deltay = ThisDrawing.Utility.GetReal("Entrer delta y: ")
   PTB(0) = PTA(0) + deltax
   PTB(1) = PTA(1) + deltay

points(0) = PTA(0): points(1) = PTA(1)
points(2) = PTB(0): points(3) = PTA(1)
points(4) = PTB(0): points(5) = PTB(1)
points(6) = PTA(0): points(7) = PTB(1)
points(8) = PTA(0): points(9) = PTA(1)
points(10) = PTB(0): points(11) = PTB(1)
points(12) = PTB(0): points(13) = PTA(1)
points(14) = PTA(0): points(15) = PTB(1)

Set Obj_Decal = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
With Obj_Decal
.Closed = True
.Update
End With

'enchaine la commande
ThisDrawing.SendCommand "_qdim" & vbCr

End Sub 

[winfield]

Salut, j'avais écris cette routine il y a quelque temps, si ça peut t'aider.

 

Sub RectangleResa()
'Winfield
'Rectangle hachuré pour resa
   Dim Coin1 As Variant
   Dim Coin2 As Variant
   Dim Pt(0 To 7) As Double
   Dim ObjRect(0 To 0) As AcadEntity
   
   Dim ObjHach As AcadHatch
   Dim BlnAssoc As Boolean
   Dim LongType As Long
   Dim StrNomHach As String
   
   StrNomHach = "Solid"
   LongType = 0
   BlnAssoc = True
   
   On Error Resume Next
   
   With ThisDrawing.Utility
       Set ObjHach = ThisDrawing.ModelSpace.AddHatch(LongType, StrNomHach, BlnAssoc)
       Coin1 = .GetPoint(, "Indiquez le premier coin.")
       Coin2 = [surligneur] .GetCorner[/surligneur] (Coin1, vbLf & "Indiquez le second coin.")
       If Err <> 0 Then
           Exit Sub
       End If
       Pt(0) = Coin1(0): Pt(1) = Coin1(1)
       Pt(2) = Coin2(0): Pt(3) = Coin2(1)
       Pt(4) = Coin1(0): Pt(5) = Coin2(1)
       Pt(6) = Coin2(0): Pt(7) = Coin1(1)
       Set ObjRect(0) = ThisDrawing.ModelSpace.AddLightWeightPolyline(Pt)
       ObjRect(0).Closed = True
       ObjHach.AppendOuterLoop (ObjRect)
       Pt(0) = Coin1(0): Pt(1) = Coin1(1)
       Pt(2) = Coin1(0): Pt(3) = Coin2(1)
       Pt(4) = Coin2(0): Pt(5) = Coin2(1)
       Pt(6) = Coin2(0): Pt(7) = Coin1(1)
       Set ObjRect(0) = ThisDrawing.ModelSpace.AddLightWeightPolyline(Pt)
       ObjHach.Evaluate
       ThisDrawing.Application.Update
   End With
End Sub

Bien sûr tu peux virer la partie hachurage

PS : fonctionne pas en SCU

 

Bonne continuation

[sechanbask]

Merci bien grâce à windfield, je fais du relatif et grâce à nazemrap je lance la cotation rapide et me donne une autre façon de faire des rectangle !!

 

Seul bémol le problème du SCU mais bon pour l'instant j'ai des plans d'hopitaux bien rectangle alors...(tiens je viens de voir le sujet : Textes horizontaux pour tout SCU... je vais me pencher dessus)

 

Bon il me reste plus qu'à chercher comment faire trangle dans les rectangles pour les traversées de planchers... là ça semble plus compliqué car je ne peux pas faire de décalage et encore moins des diagonales.. enfin bon, je verrai, la nuit aide bien les choses...

 

ENCORE merci je vais gagner pas mal de temps car faire des truc longs et répétitif, c'est pas le plus passionnant.

 

 

windfield, je pense qu'avec:

ObjHach.Evaluate
ObjHach.Update 

 

tu gagnerais rien mais tu perdrais moins de temps si tu avais 15 plans d'ouverts... C'est du conditionnel...

Merci et bonne fin de soirée.[Edité le 18/12/2006 par sechanbask]

 

[Edité le 18/12/2006 par sechanbask]

[winfield]

Salut

Seul bémol le problème du SCU mais bon pour l'instant j'ai des plans d'hopitaux bien rectangle alors...(tiens je viens de voir le sujet : Textes horizontaux pour tout SCU... je vais me pencher dessus)

regarde du côté de "TranslateCoordinates"

 

tu gagnerais rien mais tu perdrais moins de temps si tu avais 15 plans d'ouverts... C'est du conditionnel...

Oui tu as parfaitement raison, je ne sais pas ce qui m'a fait écrire comme ça :P

 

Bon il me reste plus qu'à chercher comment faire trangle dans les rectangles pour les traversées de planchers...

Tu veux parler des trémies ?

[sechanbask]

oui je parle de trémie pour montrer où je passe mes réseaux alimentation plomberie, évacutaion, eau chaude, et eau glacée: je travaille dans un BE fluides.

 

Je vais me pencher ce midi sur TranslateCoordinates.

 

Merci et bonne journée

[sechanbask]

J'ai tenté une modification de ta macro et aussi de la mienne et j'arrive au même problème :

 

Sub rectplein()
'Winfield
'Rectangle hachuré pour resa
Dim Coin1 As Variant
Dim Coin2 As Variant
Dim Pt(0 To 7) As Double
Dim ObjRect(0 To 0) As AcadEntity

Dim ObjHach As AcadHatch
Dim BlnAssoc As Boolean
Dim LongType As Long
Dim StrNomHach As String
Dim newlayer1 As AcadLayer
Dim newlayer2 As AcadLayer

Dim StrCalqueCourantH As String

StrCalqueCourantH = ThisDrawing.ActiveLayer.Name

Set newlayer1 = ThisDrawing.Layers.Add("16--")
ThisDrawing.ActiveLayer = ThisDrawing.Layers("16--")



StrNomHach = "Solid"
LongType = 0
BlnAssoc = True

On Error Resume Next

With ThisDrawing.Utility
Set ObjHach = ThisDrawing.ModelSpace.AddHatch(LongType, StrNomHach, BlnAssoc)
Coin1 = .GetPoint(, "Indiquez le premier coin.")
Coin2 = .GetCorner(Coin1, vbLf & "Indiquez le second coin.")
If Err <> 0 Then
Exit Sub
End If
Pt(0) = Coin1(0): Pt(1) = Coin1(1)
Pt(2) = Coin2(0): Pt(3) = Coin2(1)
Pt(4) = Coin1(0): Pt(5) = Coin2(1)
Pt(6) = Coin2(0): Pt(7) = Coin1(1)
Set ObjRect(0) = ThisDrawing.ModelSpace.AddLightWeightPolyline(Pt)
ObjRect(0).Closed = True
ObjHach.AppendOuterLoop (ObjRect)
Pt(0) = Coin1(0): Pt(1) = Coin1(1)
Pt(2) = Coin1(0): Pt(3) = Coin2(1)
Pt(4) = Coin2(0): Pt(5) = Coin2(1)
Pt(6) = Coin2(0): Pt(7) = Coin1(1)
Set ObjRect(0) = ThisDrawing.ModelSpace.AddLightWeightPolyline(Pt)
ObjHach.Evaluate
ObjHach.Update
End With

Set newlayer2 = ThisDrawing.Layers.Add("16--COT")
ThisDrawing.ActiveLayer = ThisDrawing.Layers("16--COT")
'MsgBox ThisDrawing.ActiveLayer.Name
[surligneur] 
ThisDrawing.SendCommand "_qdim" & vbCr
[/surligneur] 
ThisDrawing.ActiveLayer = ThisDrawing.Layers(StrCalqueCourantH)
End Sub

 

Sur la ligne surlignée, la commande _qdim n'est pas affectée par mon changement de calque ... Je me demande bien pourquoi.

[winfield]

 ThisDrawing.SendCommand "_qdim" & vbCr
ThisDrawing.Application.Update
ThisDrawing.ActiveLayer = ThisDrawing.Layers(StrCalqueCourantH)

Mais bon, avec les SendCommand, on maitrise encore moins par rapport au peu qu'on maitrise. C'est juste mon avis.

[sechanbask]

J'avoue ne pas avoir compris ton message... et ton code chez moi ne fonctionne pas, la cote est dans le calque 0 et non dans "16--COT".

 

Si tu as une autre idée pour créer cette cotation pour qu'elle soit dans le bon calque, je suis preneur.

[winfield]

Je pensais qu'un Update suffirait...

Via les SendCommand, activer le calque via ce principe, sinon je vois pas, à part coder.