Outils de réparage polyligne + Mtext

g_barthe · le 24 juin 2008

Bonsoir,

Je cherche à créer un outils de repérage pour mes plans.

En gros je lance la macro :

- Dessin de la polyligne qui délimite la pièce,

- Choix du point d'insertion du Mtext,

- Boite de dialogue pour saisir le numéro de la pièce,

- Calcul de l'aire de la polyligne en licquant sur l'objet

- affichage du Mtext avec code de pièce + sruface.

En gros c'est ça :

Sub aire_code_piece()

   ' Déclaration des variables
   Dim returnObj As AcadObject
   Dim returnPnt As Variant
   Dim basePnt As Variant
   Dim aire As String
   Dim code As String
   Dim texte As String
   Dim largeur As Double
   Dim Htxt As Double
   Dim objMtext As AcadMText
   Dim a As String
   Dim Msg, Style, Title, Help, Ctxt, Response, MyString
   
   a = "Oui"
   While (a = "Oui")

   ' Dessin de la polyligne
   thisdrawing.SendCommand ("_pline" & vbCr)
   
   ' Selection de la polyligne et calcul de l'aire
   thisdrawing.Utility.GetEntity returnObj, "Sélectionner une polyligne."
   aire = Format(returnObj.Area * 1, "#0.00")

   ' Positionnement de texte multiligne
   returnPnt = thisdrawing.Utility.GetPoint(, "Sélectionner le point de base du texte.")

   ' Boite de dialogue de saisie du nom du local
   code = InputBox("Code du local : ", "Code du local")
   
   ' Style du texte multiligne
   largeur = 10
   Htxt = 5
   
   ' Création du texte multiligne
   texte = code & vbCrLf & aire
   Set objMtexte = thisdrawing.ModelSpace.AddMText(returnPnt, largeur, texte)
   objMtexte.Height = Htxt
   
   Msg = "Souhaitez-vous continuer ?"    ' Définit le message.
   Style = vbYesNo + vbCritical + vbDefaultButton2    ' Définit les boutons.
   Title = "Démonstration de MsgBox "    ' Définit le titre.
   Help = "DEMO.HLP"    ' Définit le fichier d'aide.
   Ctxt = 1000    ' Définit le contexte de la rubrique.
   Response = MsgBox(Msg, Style, Title, Help, Ctxt)
   If Response = vbYes Then    ' L'utilisateur a choisi Oui.
       a = "Oui"    ' Effectue une action.
   Else
       a = "Non"    ' Effectue une action.
   End If
   
   Wend
   
End Sub

Seulement le bout de lisp ne s'exécute pas il passe direct au choix de la polyligne.

Alors que le lisp tout seul sur du vba tourne.

Et je passe par lisp pck dessiner une polyligne après 2h de recherche pas trouvé pour que ce soit sur les points de l'utilisateur.

Un petit coup de main serait sympa .

Merci à tous.

Matt666 · le 24 juin 2008

Ah bah !!! L'avatar de Patrick_35 !!! Le pauvre... Si j'étais lui je gueulerais... :P :P :P

[Edité le 24/6/2008 par Matt666]

g_barthe · le 24 juin 2008

j'laime bien ma boule de poil à pattes...

Un jour faudra que je le personnalise qd mm oui.

Aucune idée sinon ?

bonuscad · le 25 juin 2008

Tu proposes un bout de code en VBA et tu parles de lisp???

Donc je vais te faire une proposition en lisp qui découle de ce sujet

Si tu le veux en VBA, ça pourra peut être t'aider pour faire une transcription.

NB: Le champ surface est lié à la polyligne, si tu la modifie et que tu fais une régénération ou une mise à jour de champ, la valeur de la surface va suivre.

Bien sur, ceci pour une version d'autocad où les champs peuvent être utilisés

(defun c:pline&field ( / obj AcDoc Space nw_style pt)
(command "_.pline"
	(while (not (zerop (getvar "cmdactive")))
		(command pause)
	)
)
(setq
	obj (entlast)
	AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
	Space
	(if (= 1 (getvar "CVPORT"))
		(vla-get-PaperSpace AcDoc)
		(vla-get-ModelSpace AcDoc)
	)
)
(cond
	((null (tblsearch "LAYER" "Id-Surfaces"))
		(vlax-put (vla-add (vla-get-layers AcDoc) "Id-Surfaces") 'color 96)
	)
)
(cond
	((null (tblsearch "STYLE" "Romand20"))
		(setq nw_style (vla-add (vla-get-textstyles AcDoc) "Romand20"))
		(vlax-put nw_style 'fontfile "romand.shx")
		(vlax-put nw_style 'height 0.0)
		(vlax-put nw_style 'obliqueangle (/ (* 15.0 pi) 180))
		(vlax-put nw_style 'width 1.0)
		(vlax-put nw_style 'textgenerationflag 0.0)
	)
)
(initget 9)
(setq pt (getpoint "\nPoint d'insertion du champ: "))
(initget 1)
(setq nw_obj
	(vla-addMtext Space
		(vlax-3d-point (trans pt 1 0))
		0.0
		(strcat
			"%[b]<[/b]\\AcObjProp.16.2 Object(%[b]<[/b]\\_ObjId "
			(itoa (vla-get-ObjectID (vlax-ename-[b]>[/b]vla-object obj)))
			"[b]>[/b]%).Area \\f \"%lu2%pr2%ps[Code pièce n°"
			(itoa (getint "\nNuméro de la pièce: "))
			" S=,cm²]\"[b]>[/b]%"
		)
	)
)
(vlax-put nw_obj 'AttachmentPoint 5)
(vlax-put nw_obj 'Height 2.0)
(vlax-put nw_obj 'DrawingDirection 5)
(vlax-put nw_obj 'InsertionPoint (trans pt 1 0))
(vlax-put nw_obj 'StyleName "Romand20")
(vlax-put nw_obj 'Layer "Id-Surfaces")
(prin1)
)

g_barthe · le 25 juin 2008

Merci. Je vais regarder ta proposition car l'ensemble parait intéressant.

J'avais réussi à me sortir de ma polyligne avec cela :

 Sub aire_code_piece()

   ' Déclaration des variables
   Dim returnObj As AcadObject
   Dim returnPnt As Variant
   Dim basePnt As Variant
   Dim aire As String
   Dim code As String
   Dim texte As String
   Dim largeur As Double
   Dim Htxt As Double
   Dim objMtext As AcadMText
   Dim a As String
   Dim Msg, Style, Title, Help, Ctxt, Response, MyString
   Dim saisie
   Dim vertices(0 To 500) As Double
   Dim pnt As Variant
   Dim i, j
   Dim polyObj As AcadPolyline
   
   ' Paramétrage de la fenetre
   Msg = "Souhaitez-vous continuer ?"    ' Définit le message.
   Style = vbYesNo + vbCritical + vbDefaultButton2    ' Définit les boutons.
   Title = "Démonstration de MsgBox "    ' Définit le titre.
   Help = "DEMO.HLP"    ' Définit le fichier d'aide.
   Ctxt = 1000    ' Définit le contexte de la rubrique.

   ' Initialisation des variables
   i = 0
   j = 0
   k = 0
   a = "Oui"
   
   While (a = "Oui")
       pnt = ThisDrawing.Utility.GetPoint(, "Sélectionner un point ? ")
       j = i + 1
       k = j + 1
       vertices(i) = pnt(0): vertices(j) = pnt(1): vertices(k) = pnt(2)
       Response = MsgBox(Msg, Style, Title, Help, Ctxt) ' Boite de dialogue pour continuer
       If Response = vbYes Then    ' L'utilisateur a choisi Oui.
           a = "Oui"    ' Effectue une action.
       Else
           a = "Non"    ' Effectue une action.
       End If
       j = i + 1
       k = j + 1
       i = k + 1
   Wend
       
   ' Dessin de la polyligne
   Set polyObj = ThisDrawing.ModelSpace.AddPolyline(vertices)
   'polyObj.Closed = True
   
   ' Selection de la polyligne et calcul de l'aire
   aire = Format(polyObj.Area * 1, "#0.00")

   ' Positionnement de texte multiligne
   returnPnt = ThisDrawing.Utility.GetPoint(, "Sélectionner le point de base du texte.")

   ' Boite de dialogue de saisie du nom du local
   code = InputBox("Code du local : ", "Code du local")
   
   ' Style du texte multiligne
   largeur = 10
   Htxt = 5
   
   ' Création du texte multiligne
   texte = code & vbCrLf & aire
   Set objMtexte = ThisDrawing.ModelSpace.AddMText(returnPnt, largeur, texte)
   objMtexte.Height = Htxt
End Sub

Par contre encore un petit soucis, il passe toujours la polyligne par le point 0.0.0. Mais sinon c'est presque ça.

Par contre ta solution m'intéresse pour la maj auto des champs. Le couplage du lisp est du vba à qq avantages par moment.

PS : petite erreur lorsque j'execute ton code : ; erreur: no function definition: VLAX-GET-ACAD-OBJECT normal ?

[Edité le 25/6/2008 par g_barthe]

lili2006 · le 25 juin 2008

Bonsoir à toutes et tous,

Rajoute en début de lisp (ou sur ton fichier "acad.lsp", ce qui évitera de le réécrire sur chaques lissp,...) =>

(vl-load-com)

g_barthe · le 26 juin 2008

merci à tous.

L'exemple lisp est exactement ce que je recherchais.

Mais je voulais plutôt le faire en VBA parce que le lisp je connais pas du tout et ça me rebute un peu.

Donc l'exemple est là et j'espère arriver à la meme chose en vba. Ce serait le pied.

Un grand merci en chapeau.

PS : si des gens on déjà créés des chamsp en vba ils peuvent me dire quelle est la propriété pck je trouve rien la dessus.

g_barthe · le 26 juin 2008

J'ai trouvé un bout de réponse :

    ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select an object"
   toto = returnObj.ObjectID
   text = "%<\AcObjProp Object(%<\_ObjId " & toto & ">%).Area>%"
   insertionPoint(0) = 2: insertionPoint(1) = 2: insertionPoint(2) = 0
   height = 0.5
   
   ' Create the text object in model space
   Set textObj = ThisDrawing.ModelSpace.AddText(text, insertionPoint, height)

En fait vous sélectionner l'objet et il vous insère un champs avec la surface qui sera mise à jour sur régén du dessin si mise à jour de la polyligne.

Encore quelques améliorations et je vais être au top.

Je test plusieurs choses mais je suis déjà très content d'en être arrivé là.

Merci encore @ tous @ bientôt pour la suite du prog.

g_barthe · le 27 juin 2008

Bonjour à tous,

Alors voilà la bête.

En résumé ça fait :

- Création calque "réparage" couleur magenta

- Demande de choisir un élément de texte du dessin pour en reprendre la hauteur du texte

- Permet de dessiner la polyligne en choisissant au fur et à mesure si on veut continuer la polyligne (O ou N) et fermeture de la polyligne (La fonction sera revue à terme je pense)

- Choix du point de base du texte

- Saisie du texte (code ou repère de la pièce)

- Insertion du texte sur 2 ligne avec le code ou repère et en dessous le champs surface de la polyligne pour mise à jour automatique si modif.

 Sub plan_reperage()
   ' Déclaration des variables
   Dim returnObj As AcadObject
   Dim returnPnt As Variant
   Dim basePnt As Variant
   Dim code As String
   Dim texte As String
   Dim largeur As Double
   Dim Htxt As Double
   Dim objMtext As AcadMText
   Dim a As String
   Dim Reponse As String
   Dim vertices() As Double
   Dim pnt As Variant
   Dim i, j As Integer
   Dim polyObj As AcadPolyline
   Dim toto, titi As String
   Dim layerObj As AcadLayer
   Dim texteref As AcadObject

   ' Creation du calque repérage de couleur magenta
   Set layerObj = ThisDrawing.Layers.Add("Repérage")
   layerObj.color = acMagenta
   ThisDrawing.ActiveLayer = layerObj
   
   ' Selection d'un texte du dessin pour récupérer les hauteurs de texte du dessin
   ThisDrawing.Utility.GetEntity texteref, basePnt, "Sélectionner un texte pour définir la hauteur : "
   Htxt = texteref.height
   largeur = 5
   
   ' Initialisation des variables
   i = 0
   j = 0
   k = 0
   a = "Oui"
   ReDim vertices(0 To 1000) ' Redimensionnement du tableau de points
   
   ' Boucle pour saisir plusieurs points pour la plyligne
   While (a = "Oui")
       pnt = ThisDrawing.Utility.GetPoint(, "Sélectionner un point ? ")
       j = i + 1
       k = j + 1
       vertices(i) = pnt(0): vertices(j) = pnt(1): vertices(k) = pnt(2)

       Reponse = ThisDrawing.Utility.GetString(False, "Autre point Oui ou Non (Taper  pour valider): ")
       Select Case Reponse
           Case "o", "O"
               a = "Oui"    ' Effectue une action.
           Case "n", "N"
               a = "Non"    ' Effectue une action.
       End Select
       j = i + 1
       k = j + 1
       i = k + 1
   Wend
   ReDim Preserve vertices(0 To k) ' Redimensionnement du tableau de points en fonction de nombre de points réels

   ' Dessin de la polyligne
   Set polyObj = ThisDrawing.ModelSpace.AddPolyline(vertices)
   polyObj.Closed = True ' cloture de la polyligne
   
   ' Choix du point de base du texte
   returnPnt = ThisDrawing.Utility.GetPoint(, "Sélectionner le point de base du texte.")

   ' Saisie au prompt du code du local
   code = ThisDrawing.Utility.GetString(True, "Code du local (Taper  pour valider): ")
   
   ' Création du texte avec le code du local et sur la ligne en dessous la surface arrondi 0.00
   toto = polyObj.ObjectID ' recup de l'ID de la polyligne
   titi = "" & "\f " & Chr(34) & Chr(37) & "lu2" & Chr(37) & "pr2" & Chr(34) & "" ' mise en forme de l'arrondi
   texte = code & vbCrLf & "%<\AcObjProp Object(%<\_ObjId " & toto & ">%).Area " & titi & ">%" ' concatenation champs + code local
   Set objMtexte = ThisDrawing.ModelSpace.AddMText(returnPnt, largeur, texte)
   objMtexte.height = Htxt
End Sub

lili2006 · le 27 juin 2008

Bonjour à toutes et tous,

superbe cette routine !

Merci du partage g_barthe !

g_barthe · le 26 septembre 2008

Bonjour,

Je reviens sur cet outils car il a des lacunes.

En même temps je l'ai pondu sur un bout de table en peu de temps.

Donc je le reprend et j'ai intégré l'unité de la surface "m²".

J'ai rajouté la gestion de l'unité du dessin car si le plan est en cm la surface inséré par le champ est en cm² et je vous laisse imaginer si c'est du mm alors la valeur monstrueuse et peu parlante de la surface.

Pour cela je place lors de la première utilisation du code une propriété personnalisé dans les infos du fichier (comme la où est rentré auteur...) et je récupère la valeur lors de la seconde utilisation. Et après je fais un rapport sur la surface calculée dans le champs. Tout cela est prévu en fait dans les options du champs aire.

Reste à gérer la hauteur de texte lorsqu'on choisit un attribut et non un text ou mtext pour reproduire la même hauteur.

C'est également un bon exercice d'école pour gérer des trucs pas super documenter.

Je vous mets ca dans les prochaines semaines.

g_barthe · le 1 octobre 2008

Bonjour à tous,

Alors voici une mise à jour du programme.

Je gère maintenant l'unité dans laquelle le dessin a été fait et je la rajoute dans les propriétés du fichier.

Plus besoin de choisir la polyligne que l'on vient de dessiner pour en sortir la surface.

Ajout je l'unité au bout du champs surface.

Voilà des améliorations qui permettent un meilleur confort d'utilisation.

Il me reste à trouver pour hachurer la région en excluant la texte des hachures et à permettre à l'utilisateur de saisir ses points pour la polyligne sans avoir à dire oui je veux un nouveau point.

Mais là déjà c'est plus agréable je trouve.

Sub plan_reperage()
   ' Déclaration des variables
   Dim returnObj As AcadObject
   Dim returnPnt(0 To 2) As Double
   Dim basePnt As Variant
   Dim code As String
   Dim texte As String
   Dim largeur_mini, largeur_texte, largeur As Double
   Dim Htxt As Double
   Dim objMtext As AcadMText
   Dim a As String
   Dim rapport As Double
   Dim Reponse, echelle_du_plan As String
   Dim vertices() As Double
   Dim pnt As Variant
   Dim i, j As Integer
   Dim polyObj As AcadPolyline
   Dim toto, titi As String
   Dim layerObj As AcadLayer
   Dim texteref As AcadObject
   Dim Centroid, region As Variant
   Dim region_element(0) As AcadEntity
   Dim boxObj As AcadRegion
   Dim hatchObj As AcadHatch
   Dim patternName As String
   Dim PatternType As Long
   Dim bAssociativity As Boolean
   Dim EchelleHachure As Double
   Dim echelle, unite As String
   Dim Value1 As String
   Dim type_entite As String

   ' Creation du calque repérage de couleur magenta
   Set layerObj = ThisDrawing.Layers.Add("Repérage")
   layerObj.color = acMagenta
   ThisDrawing.ActiveLayer = layerObj
   
   ' Verification si l'unite du dessin a deja été définie
   If (ThisDrawing.SummaryInfo.NumCustomInfo >= 1) Then
       ThisDrawing.SummaryInfo.GetCustomByKey "unite", Value1
       Select Case Value1
           Case "m"
               rapport = 1
           Case "cm"
               rapport = 0.0001
           Case "mm"
               rapport = 0.000001
       End Select
   Else
       echelle_du_plan = ThisDrawing.Utility.GetString(False, "Echelle du plan C, M, MM (Taper  pour valider): ")
       Select Case echelle_du_plan
           Case "m", "M"
               unite = "m"
           Case "c", "C"
               unite = "cm"
           Case "mm", "MM"
               unite = "mm"
       End Select
       ThisDrawing.SummaryInfo.AddCustomInfo "unite", unite
   End If
   
   ' Selection d'un texte du dessin pour récupérer les hauteurs de texte du dessin
   ThisDrawing.Utility.GetEntity texteref, basePnt, "Sélectionner un texte pour définir la hauteur : "
   type_entite = texteref.EntityName
   Select Case type_entite ' Cas d'un texte normal
       Case "AcDbText"
           Htxt = texteref.height
       Case "AcDbMText" ' Cas d'un texte multiligne
           Htxt = texteref.height
       Case "AcDbBlockReference" ' Cas d'un texte dans un attribut de bloc
           Dim varAttributes As Variant
           varAttributes = texteref.GetAttributes
           Htxt = varAttributes(0).height
   End Select
   
   largeur_mini = 7 * Htxt
   
   ' Initialisation des variables
   i = 0
   j = 0
   k = 0
   a = "Oui"
   ReDim vertices(0 To 1000) ' Redimensionnement du tableau de points
   
   ' Boucle pour saisir plusieurs points pour la plyligne
   While (a = "Oui")
       pnt = ThisDrawing.Utility.GetPoint(, "Sélectionner un point ? ")
       j = i + 1
       k = j + 1
       vertices(i) = pnt(0): vertices(j) = pnt(1): vertices(k) = pnt(2)

       Reponse = ThisDrawing.Utility.GetString(False, "Autre point Oui ou Non (Taper  pour valider): ")
       Select Case Reponse
           Case "o", "O"
               a = "Oui"
           Case "n", "N"
               a = "Non"
       End Select
       j = i + 1
       k = j + 1
       i = k + 1
   Wend
   ReDim Preserve vertices(0 To k) ' Redimensionnement du tableau de points en fonction de nombre de points réels

   ' Dessin de la polyligne
   Set polyObj = ThisDrawing.ModelSpace.AddPolyline(vertices)
   polyObj.Closed = True
   
   'création de la région
   Set region_element(0) = polyObj
   region = ThisDrawing.ModelSpace.AddRegion(region_element)
   
   ' Transformation de la region Variant en objet region pour après trouver le centre
   Set boxObj = region(0)
   
   ' Le point de base du texte est le centre de la region
   Centroid = boxObj.Centroid
   returnPnt(0) = Centroid(0): returnPnt(1) = Centroid(1): returnPnt(2) = 0
   
   ' Saisie au prompt du code du local
   code = ThisDrawing.Utility.GetString(True, "Code du local (Taper  pour valider): ")
   
   ' Operations pour définir une largeur de texte cohérente avec la longueur du texte
   largeur_texte = Len(code) * Htxt
   If largeur_texte > largeur_mini Then
       largeur = largeur_texte
   Else
       largeur = largeur_mini
   End If
   
   ' Création du texte avec le code du local et sur la ligne en dessous la surface arrondi 0.00
   toto = polyObj.ObjectID ' recup de l'ID de la polyligne
   echelle = "ct8[" & rapport & "]"
   titi = "" & "\f " & Chr(34) & Chr(37) & "lu2" & Chr(37) & "pr2" & Chr(37) & echelle & Chr(34) & ""
   texte = code & vbCrLf & "%<\AcObjProp Object(%<\_ObjId " & toto & ">%).Area " & titi & ">%" & " m²" ' concatenation champs + code local
   Set objMtexte = ThisDrawing.ModelSpace.AddMText(returnPnt, largeur, texte)
   objMtexte.height = Htxt

End Sub

lili2006 · le 1 octobre 2008

Bonjour à toutes et tous,

g_barthe, j'ai testé ton dernier BB et j'ai une erreur sur cette ligne (AutoCAD 2008 full) =>

pnt = ThisDrawing.Utility.GetPoint(, "Sélectionner un point ? ")

http://images1.hiboox.com/images/4008/e3da331548e4a393ea3d884cc0d0c248.jpg

Mais je pense que c'est moi qui utilise mal ton code, ;)

Merci d'avance,

g_barthe · le 1 octobre 2008

je suis en train de finaliser avec le coup des hachures la version devrait venir dans la journée.

Je dois aussi tester la version sur le poste qui fait tourner le prog vu que j'utilise les champs et que les versions plus anciennes n'ont pas forcément cette fonctionnalité je testerais au cas où.

Ton pb est bizarre car tu pourrais avoir une erreur si tu ne sélectionne pas de texte au début pour choisir la hauteur en cas de clic dans le vide par exemple.

Mais la c'est quand tu choisis tes poins c'est ça ?

lili2006 · le 1 octobre 2008

Re,

En fait, je ne sais pas ce que je dois faire lors du choix des points ???!!!

Un extrait de ma ligne de commande =>

Commande:
Commande: _VBARUN Sélectionner un texte pour définir la hauteur :
Commande: Sélectionner un point ?
Commande: Autre point Oui ou Non (Taper pour valider): o
Commande: Sélectionner un point ?
Commande: Autre point Oui ou Non (Taper pour valider):
Commande: Sélectionner un point ?
Commande: Autre point Oui ou Non (Taper pour valider):
Commande: Sélectionner un point ?
Commande:

Peux-tu expliquer en quelques mots la démarche d'utilisation STP ?

Je suis presque sur que j'utilise mal le code,..... ;)

Merci d'avance,

g_barthe · le 1 octobre 2008

je finalise un truc sur la gestion des version d'autocad et je fais un mode d'emploi c'est prévu et c'est en cours

@tte

lili2006 · le 1 octobre 2008

Rere,

Ok g_barthe,

g_barthe · le 1 octobre 2008

Re bonjour,

Alors voici la version finalisée du programme.

Sub plan_reperage()
   ' Déclaration des variables
   Dim returnObj As AcadObject
   Dim returnPnt(0 To 2) As Double
   Dim basePnt As Variant
   Dim code As String
   Dim texte As String
   Dim largeur_mini, largeur_texte, largeur As Double
   Dim Htxt As Double
   Dim objMtext As AcadMText
   Dim a As String
   Dim rapport As Double
   Dim Reponse, echelle_du_plan As String
   Dim vertices() As Double
   Dim pnt As Variant
   Dim i, j As Integer
   Dim polyObj As AcadPolyline
   Dim toto, titi As String
   Dim layerObj As AcadLayer
   Dim texteref As AcadObject
   Dim Centroid, region As Variant
   Dim region2 As Variant
   Dim region_element(0) As AcadEntity
   Dim region_element2(0) As AcadEntity
   Dim boxObj As AcadRegion
   Dim boxObj2 As AcadRegion
   Dim hatchObj As AcadHatch
   Dim patternName As String
   Dim PatternType As Long
   Dim bAssociativity As Boolean
   Dim EchelleHachure As Double
   Dim echelle, unite As String
   Dim Value1 As String
   Dim type_entite As String
   Dim espacement_entre_lignes As Double
   Dim currInsertionPoint As Variant
   Dim vertices1(0 To 11) As Double
   Dim version As String
   Dim Msg, Style, Title, Response
   
   ' Récupération de la version pour éviter les erreurs sur les anciennes versions
   version = ThisDrawing.Application.version
   version = Left(version, 4)
   If version >= "16.2" Then ' si la version est antérieure à Autocad 2006 on n'exécute pas le programme
       ' Creation du calque repérage de couleur magenta
       Set layerObj = ThisDrawing.Layers.Add("Repérage")
       layerObj.color = acMagenta
       ThisDrawing.ActiveLayer = layerObj
       
       ' Verification si l'unite du dessin a deja été définie
       If (ThisDrawing.SummaryInfo.NumCustomInfo >= 1) Then
           ThisDrawing.SummaryInfo.GetCustomByKey "unite", Value1
           Select Case Value1
               Case "m"
                   rapport = 1
               Case "cm"
                   rapport = 0.0001
               Case "mm"
                   rapport = 0.000001
           End Select
       Else
           echelle_du_plan = ThisDrawing.Utility.GetString(False, "Echelle du plan C, M, MM (Taper  pour valider): ")
           Select Case echelle_du_plan
               Case "m", "M"
                   unite = "m"
                   rapport = 1
               Case "c", "C"
                   unite = "cm"
                   rapport = 0.0001
               Case "mm", "MM"
                   unite = "mm"
                   rapport = 0.000001
           End Select
           ThisDrawing.SummaryInfo.AddCustomInfo "unite", unite
       End If
       
       ' Selection d'un texte du dessin pour récupérer les hauteurs de texte du dessin
       ThisDrawing.Utility.GetEntity texteref, basePnt, "Sélectionner un texte pour définir la hauteur : "
       type_entite = texteref.EntityName
       Select Case type_entite ' Cas d'un texte normal
           Case "AcDbText"
               Htxt = texteref.height
           Case "AcDbMText" ' Cas d'un texte multiligne
               Htxt = texteref.height
           Case "AcDbBlockReference" ' Cas d'un texte dans un attribut de bloc
               Dim varAttributes As Variant
               varAttributes = texteref.GetAttributes
               Htxt = varAttributes(0).height
       End Select
       
       largeur_mini = 7 * Htxt
       
       ' Initialisation des variables
       i = 0
       j = 0
       k = 0
       a = "Oui"
       ReDim vertices(0 To 1000) ' Redimensionnement du tableau de points
       
       ' Boucle pour saisir plusieurs points pour la polyligne
       While (a = "Oui")
           pnt = ThisDrawing.Utility.GetPoint(, "Sélectionner un point ? ")
           j = i + 1
           k = j + 1
           vertices(i) = pnt(0): vertices(j) = pnt(1): vertices(k) = pnt(2)
   
           Reponse = ThisDrawing.Utility.GetString(False, "Autre point Oui ou Non (Taper  pour valider): ")
           Select Case Reponse
               Case "o", "O"
                   a = "Oui"
               Case "n", "N"
                   a = "Non"
           End Select
           j = i + 1
           k = j + 1
           i = k + 1
       Wend
       ReDim Preserve vertices(0 To k) ' Redimensionnement du tableau de points en fonction de nombre de points réels
   
       ' Dessin de la polyligne
       Set polyObj = ThisDrawing.ModelSpace.AddPolyline(vertices)
       polyObj.Closed = True
       
       ' Création de la région
       Set region_element(0) = polyObj
       region = ThisDrawing.ModelSpace.AddRegion(region_element)
       
       ' Transformation de la region Variant en objet region pour après trouver le centre
       Set boxObj = region(0)
       
       ' Le point de base du texte est le centre de la region
       Centroid = boxObj.Centroid
       returnPnt(0) = Centroid(0): returnPnt(1) = Centroid(1): returnPnt(2) = 0
       
       ' Saisie au prompt du code du local
       code = ThisDrawing.Utility.GetString(True, "Code du local (Taper  pour valider): ")
       
       ' Operations pour définir une largeur de texte cohérente avec la longueur du texte
       largeur_texte = Len(code) * Htxt
       If largeur_texte > largeur_mini Then
           largeur = largeur_texte
       Else
           largeur = largeur_mini
       End If
       
       ' Création du texte avec le code du local et sur la ligne en dessous la surface arrondi 0.00
       toto = boxObj.ObjectID ' recup de l'ID de la region
       echelle = "ct8[" & rapport & "]"
       titi = "" & "\f " & Chr(34) & Chr(37) & "lu2" & Chr(37) & "pr2" & Chr(37) & echelle & Chr(34) & ""
       texte = code & vbCrLf & "%<\AcObjProp Object(%<\_ObjId " & toto & ">%).Area " & titi & ">%" & " m\U+00B2" ' concatenation champs + code local
       Set objMtexte = ThisDrawing.ModelSpace.AddMText(returnPnt, largeur, texte)
       espacement_entre_lignes = 1.5 * Htxt
       objMtexte.height = Htxt
       currInsertionPoint = objMtexte.InsertionPoint
       objMtexte.AttachmentPoint = acAttachmentPointMiddleCenter
   
       ' Coordonnées de la polyligne liée au texte
       vertices1(0) = currInsertionPoint(0): vertices1(1) = currInsertionPoint(1): vertices1(2) = currInsertionPoint(2)
       vertices1(3) = currInsertionPoint(0) + largeur: vertices1(4) = currInsertionPoint(1): vertices1(5) = currInsertionPoint(2)
       vertices1(6) = currInsertionPoint(0) + largeur: vertices1(7) = currInsertionPoint(1) - espacement_entre_lignes - 2 * Htxt: vertices1(8) = currInsertionPoint(2)
       vertices1(9) = currInsertionPoint(0): vertices1(10) = currInsertionPoint(1) - espacement_entre_lignes - 2 * Htxt: vertices1(11) = currInsertionPoint(2)
       
       ' Dessin de la polyligne liée au texte
       Set polyObj2 = ThisDrawing.ModelSpace.AddPolyline(vertices1)
       polyObj2.Closed = True
       
       ' Création de la région liée au texte
       Set region_element2(0) = polyObj2
       region2 = ThisDrawing.ModelSpace.AddRegion(region_element2)
   
       ' Creation des hachures dans la region
       patternName = "ANSI31"
       PatternType = acPreDefinedGradient
       bAssociativity = True
       EchelleHachure = Htxt / 2
       Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
       hatchObj.AppendOuterLoop (region)
       hatchObj.PatternScale = EchelleHachure
       
       ' Suppression des hachures dans la region liée au texte
       hatchObj.AppendInnerLoop (region2)
   
       ' Actualisation du dessin et des hachures
       hatchObj.Evaluate
       ThisDrawing.Regen True
       
       ' Suppression de la polyligne sinon doublon avec la region créée
       polyObj.Delete
       polyObj2.Delete
   Else
       Msg = "Votre version d'Autocad n'est pas compatible avec ce programme. Une version plus récente est nécessaire"
       Style = vbOK + vbCritical
       Title = "Incompatibilité de version"
       Response = MsgBox(Msg, Style, Title)
   End If
End Sub

J'ai mis en téléchargement le fichier dvb ainsi qu'une documentation en format doc ici : http://pausebroderie.fr/taz_genie_climatique/plans_reperages.zip

N'hésitez pas à me rapporter des bugs, idées d'améliorations...

lili2006 · le 1 octobre 2008

Re,

Trés jolie programme et didacticiel,...

Merci encore pour ce partage g_barthe,...

Maintenant j'ai ce message =>

region = ThisDrawing.ModelSpace.AddRegion(region_element)

Suite à =>

Commande:
Commande: _VBARUN Echelle du plan C, M, MM (Taper pour valider): c
Commande: Sélectionner un texte pour définir la hauteur :
Commande: Sélectionner un point ?
Commande: Autre point Oui ou Non (Taper pour valider): o
Commande: Sélectionner un point ?
Commande: Autre point Oui ou Non (Taper pour valider): n
Commande:

Bug ou toujours moi qui m'y prend mal ?

Merci encore,

g_barthe · le 1 octobre 2008

Salut

Merci du compliment

Je pense que ton pb est lié à la forme de ta polyligne.

Il faut que les points que tu as saisis soit dans un ordre qui permette de faire des formes sans croisement de segments. En fait un truc qui va delimiter une region. euh pas facile a expliquer.

Le mieux est que tu essaie en faisant un rectangle coté par coté en tournant dans un sens.

Dis moi si tu as pigé ce que je dis pck pas clair peut être. Je pense que ton pb vient de la forme que tu cherche à dessiner.

PS : j'ai testé sous 2006 et MEP 2008 donc normalement ça doit le faire mais pas à l'abri d'une c.... ;)

lili2006 · le 1 octobre 2008

Rere,

C'est bien ce que je pensais !

C'est moi qui utilisai mal le code !

Valider par o pour chaque nouveau point !!!!

Par contre, je n'ai pas de hachures ?

De plus, à quoi sert la région puisque lorsque l'on souhaite modifier la polyligne ainsi créée on est obligé de la supprimer ?

Là aussi, je n'ai peut-être pas compris toutes les subtilités,... ;)

En tout cas, belle démonstration de vba pour moi. (gile) a fait un outil de ce type mais en lisp. Me voilà alors avec deux langages bien différents pour un résultat identique !

Merci encore,

D'autres ont testés ? :P

g_barthe · le 2 octobre 2008

Pour le coup de la région j'en étais arrivé à la même conclusion.

Et l'utilité est juste pour trouver le centroid afin de positionner le texte.

Donc je vais peut être récupérer le centroid et virer la région pour utiliser la polyligne. A voir.

Oui pour le moment le seul point noir c'est la confirmation après chaque point pour savoir si on en veut un autre ou non. Dommage.

Tu n'as pas de hachures ???? peut être un pb d'échelle des hachures non ?

Je suis déjà rassuré que ça marche pour toi.

lili2006 · le 2 octobre 2008

Bonjour à toutes et tous,

Ok g_barthe ,

Toujours pas de hachures, !!!!

Mais bien déjà !

C'était plus pour tester ton code et renvoyé un retour,...

Connexion

Outils de réparage polyligne + Mtext

Messages recommandés

g_barthe

Matt666

g_barthe

bonuscad

g_barthe

lili2006

g_barthe

g_barthe

g_barthe

lili2006

g_barthe

g_barthe

lili2006

g_barthe

lili2006

g_barthe

lili2006

g_barthe

lili2006

g_barthe

lili2006

g_barthe

lili2006

Créer un compte ou se connecter pour commenter

Créer un compte

Se connecter

Forums

Naviguer

Activité

Information importante