transformer un bloc + text à un bloc avec attribut

[Teamscad]

Salut à tous

J'aimerai savoir si il était possible de créer un code vba où pour sélectionner un des blocs puis un texte le plus proche de lui afin qu'il le convertisse en bloc/attribut,

en effet j'ai un fichier avec plusieurs blocs + texte et je veux automatiser la manipulation (j'ai presque 1000 bloc avec texte)

Merci pour votre aide.

[Curlygoth]

Hello !

 

Alors oui c'est possible !

par contre j'ai pas trop le temps en se moment...

C'est urgent ou pas trop ?

[Teamscad]

Hello !

 

Alors oui c'est possible !

par contre j'ai pas trop le temps en se moment...

C'est urgent ou pas trop ?

Merci pour votre réponse,

Bah il me faut un rendu avant lundi.. j'ai essayé un lisp sur internet mais il prend n'importe quel texte qui est le plus proche.. donc je dois filtrer les textes après la sélection ( (par exemple les textes qui commence par ST* car tous les textes sont dans le même calque).

[Curlygoth]

J'ai un planning chargé... pour lundi... je ne serais "peut-être" pas ton homme...

 

et comment ça n'importe quel texte le plus proche ?

 

le plus proche si tu n'as qu'un point des textes le plus proche il doit te prendre celui la après je suis pas lispeur.. Malheureusement...

 

si deux textes sont a la même distance du centre de ton bloc ou de ta forme...

 

tu peux m'envoyer ton fichier ?

 

je te promets rien par rapport au délai... mais je vais regarder

[Teamscad]

J'ai un planning chargé... pour lundi... je ne serais "peut-être" pas ton homme...

 

et comment ça n'importe quel texte le plus proche ?

 

le plus proche si tu n'as qu'un point des textes le plus proche il doit te prendre celui la après je suis pas lispeur.. Malheureusement...

 

si deux textes sont a la même distance du centre de ton bloc ou de ta forme...

 

tu peux m'envoyer ton fichier ?

 

je te promets rien par rapport au délai... mais je vais regarder

Merci pour votre réponse,

Dans le cas ou un bloc qui n'ayant pas un texte, il va impérativement prendre un texte ! donc au moins je vais ajouter une condition si le texte se trouve au moins d'une distance x il le transforme en attribut sinon pas la peine. Cette consition je ne sais pas fais avec le code lisp :(.

Bonne journée

[Curlygoth]

oui tout est possible en programmation je le fait pour des point topo qui recherche une altimétrie de niveau fini s'il n'y a pas de point a moins de 10m sa appelle au autre fonction.. enfin bref..

 

envoie ton fichier sinon je peux te lancer des pistes :

 

tu aura certainnement des erreurs mais par manque de temps je donne des pistes :

 

1°)

boucle sur tous les objets de dessin

2°) verifier si c'est un block ou non / ou txt ou non

3°) verifier la plus courte distance entre bloc et texte e si ca te va tu insrer l'attribut dans le block

sinon tu le rentre manuellement ou tu met rien...

 

le mode manuel ressemblerait à ça :

 

(j'ai pas tester !!!!!)

on goto err_ceci_pas_TXT
Dim textObj As AcadText ' ou Mtext !
ThisDrawing.Utility.GetEntity text, basePnt, "Sélectionner le texte"
text = textObj.textString
on error goto 0

on goto err_ceci_pas_BLOCK
Dim blockRefObj As AcadBlockReference
ThisDrawing.Utility.GetEntity  blockRefObj, basePnt, "Sélectionner le block"
on error goto 0

'ajouter l'attribut
   Dim attributeObj As AcadAttribute
   Dim H_TXT As Double
   Dim mode As Long
   Dim ETIQUETTE As String
   Dim insertionPoint(0 To 2) As Double
   Dim TAG As String
   Dim VALEUR As String
   height = 1#
   mode = acAttributeModeVerify
   ETIQUETTE = "Attribute Prompt"
   insertionPoint(0) = 1#: insertionPoint(1) = 1#: insertionPoint(2) = 0 'je ne sais pas ou doivent etre ton attribut par rapport à ton bloc
   TAG = Attribut
   

'creation de l'attribut dans le block
Set attributeObj = blockObj.AddAttribute(H_TXT, mode, ETIQUETTE, insertionPoint, TAG, text)

 

je ne l'ai pas tester je l'ai écrit vite fait dans ton attribut suivant ton style de texte tu risques d'avoir des caracteres spéciaux !

[Teamscad]

oui tout est possible en programmation je le fait pour des point topo qui recherche une altimétrie de niveau fini s'il n'y a pas de point a moins de 10m sa appelle au autre fonction.. enfin bref..

 

envoie ton fichier sinon je peux te lancer des pistes :

 

tu aura certainnement des erreurs mais par manque de temps je donne des pistes :

 

1°)

boucle sur tous les objets de dessin

2°) verifier si c'est un block ou non / ou txt ou non

3°) verifier la plus courte distance entre bloc et texte e si ca te va tu insrer l'attribut dans le block

sinon tu le rentre manuellement ou tu met rien...

 

le mode manuel ressemblerait à ça :

 

(j'ai pas tester !!!!!)

on goto err_ceci_pas_TXT
Dim textObj As AcadText ' ou Mtext !
ThisDrawing.Utility.GetEntity text, basePnt, "Sélectionner le texte"
text = textObj.textString
on error goto 0

on goto err_ceci_pas_BLOCK
Dim blockRefObj As AcadBlockReference
ThisDrawing.Utility.GetEntity  blockRefObj, basePnt, "Sélectionner le block"
on error goto 0

'ajouter l'attribut
   Dim attributeObj As AcadAttribute
   Dim H_TXT As Double
   Dim mode As Long
   Dim ETIQUETTE As String
   Dim insertionPoint(0 To 2) As Double
   Dim TAG As String
   Dim VALEUR As String
   height = 1#
   mode = acAttributeModeVerify
   ETIQUETTE = "Attribute Prompt"
   insertionPoint(0) = 1#: insertionPoint(1) = 1#: insertionPoint(2) = 0 'je ne sais pas ou doivent etre ton attribut par rapport à ton bloc
   TAG = Attribut
   

'creation de l'attribut dans le block
Set attributeObj = blockObj.AddAttribute(H_TXT, mode, ETIQUETTE, insertionPoint, TAG, text)

 

je ne l'ai pas tester je l'ai écrit vite fait dans ton attribut suivant ton style de texte tu risques d'avoir des caracteres spéciaux !

 

Je vais partir de ça et rajouter les autres conditions :D

Pour l'emplacement de l'attr pas de problème parce que après je vais extraire les attributs c'est tout, le projet et d'extraire les informations des blocs et les copier sur un Excel. sachant que les projets contiennent seulement des blocs et des textes. Donc l'idée est de laisser à chaque fois le bloc avec le calque contenant le texte du premier attribut. Selectionner tout et transformation en bloc + attribut (je garde bien sur les textes pour vérification),après 2ème calque contenant les textes à convertir en attributs ect.. finalement je veux obtenir un bloc contenant plusieurs attributs pour l'exporter :) sauf que parfois le bloc ne contient pas l'information num °N dans ce cas je dois ajouter la condition s'il ne trouve pas un texte situé à une distance X prend la valeur "".

Voilà j'espère que j'ai tout expliquer :D

mon soucis dans mon code c'est la condition de prendre le plus proche texte en respectant aussi la distance maximale qui ne doit pas être dépasser ..

[Curlygoth]

pour la distance tu prends la plus petite à partir de ton point c'est tout XD...

 

Tu boucles sur tous tes objets :

 

tu retiens la distance et la valeur

Si la distance et inférieur à ta valeur arbitraire et la distance de ton précédent comparatif tu conserves

 

c'est tout

[Teamscad]

pour la distance tu prends la plus petite à partir de ton point c'est tout XD...

 

Tu boucles sur tous tes objets :

 

tu retiens la distance et la valeur

Si la distance et inférieur à ta valeur arbitraire et la distance de ton précédent comparatif tu conserves

 

c'est tout

xD ! ce que jecherche vraiment le point à comparer :D bah c'est bon c'est le point de l'insertion de texte (désolé ça fait longtemps que j'ai pas codé sur VBA donc j'ai oublié beaucoup de chose ), Donc j'ai tout donc je pense je peux le faire :D

Merci beaucoup beaucoup !

[Curlygoth]

de rien et content d'avoir aider quelqu'un sur du vba c'est rare ;-)

[Teamscad]

de rien et content d'avoir aider quelqu'un sur du vba c'est rare ;-)

 

Merci,

vraiment c'est un bon outil de point de vue efficacité et rapidité et surtout sa langage un peu facile par rapport les autres... Heureusement j'ai eu l'occasion maintenant de revenir à développer des macros comme avant !

Je t'encourage pour l'effort que tu as fait pour arriver à créer des macros complexes qui facilite le travail . (j'ai vu le site et quelques vidéos)

Bonne continuation ;)

[Teamscad]

oui tout est possible en programmation je le fait pour des point topo qui recherche une altimétrie de niveau fini s'il n'y a pas de point a moins de 10m sa appelle au autre fonction.. enfin bref..

 

envoie ton fichier sinon je peux te lancer des pistes :

 

tu aura certainnement des erreurs mais par manque de temps je donne des pistes :

 

1°)

boucle sur tous les objets de dessin

2°) verifier si c'est un block ou non / ou txt ou non

3°) verifier la plus courte distance entre bloc et texte e si ca te va tu insrer l'attribut dans le block

sinon tu le rentre manuellement ou tu met rien...

 

le mode manuel ressemblerait à ça :

 

(j'ai pas tester !!!!!)

on goto err_ceci_pas_TXT
Dim textObj As AcadText ' ou Mtext !
ThisDrawing.Utility.GetEntity text, basePnt, "Sélectionner le texte"
text = textObj.textString
on error goto 0

on goto err_ceci_pas_BLOCK
Dim blockRefObj As AcadBlockReference
ThisDrawing.Utility.GetEntity  blockRefObj, basePnt, "Sélectionner le block"
on error goto 0

'ajouter l'attribut
   Dim attributeObj As AcadAttribute
   Dim H_TXT As Double
   Dim mode As Long
   Dim ETIQUETTE As String
   Dim insertionPoint(0 To 2) As Double
   Dim TAG As String
   Dim VALEUR As String
   height = 1#
   mode = acAttributeModeVerify
   ETIQUETTE = "Attribute Prompt"
   insertionPoint(0) = 1#: insertionPoint(1) = 1#: insertionPoint(2) = 0 'je ne sais pas ou doivent etre ton attribut par rapport à ton bloc
   TAG = Attribut
   

'creation de l'attribut dans le block
Set attributeObj = blockObj.AddAttribute(H_TXT, mode, ETIQUETTE, insertionPoint, TAG, text)

 

je ne l'ai pas tester je l'ai écrit vite fait dans ton attribut suivant ton style de texte tu risques d'avoir des caracteres spéciaux !

 

Je pense que le code ne marche pas car il s'agit d'un blockreference quand ne peut pas l'ajouter directement un attribut ( c'est ce qu j'ai compris après mes recherches)

[Curlygoth]

Je t'encourage pour l'effort que tu as fait pour arriver à créer des macros complexes qui facilite le travail

Merci ;-) je les personnalise pour mes clients surtout c'est que des exemples !

 

confond pas

AcadBlockReference et Acadblock ! les types sont en anglais le acadblock c'est plus le groupe !

 

comme je te l'ai : dit j'ai pas testé

 

et c'est quoi l'erreur ?

[Teamscad]

Merci ;-) je les personnalise pour mes clients surtout c'est que des exemples !

 

confond pas

AcadBlockReference et Acadblock ! les types sont en anglais le acadblock c'est plus le groupe !

 

comme je te l'ai : dit j'ai pas testé

 

et c'est quoi l'erreur ?

 

Bonjour,

Voici le code maintenant après modifications :

Sub add_Attributes_to_one_block()

 

Dim obj As AcadBlockReference

Dim block As AcadBlock

Dim inspt As Variant

Dim objname As String

Dim blocks As AcadBlocks

Dim Blk As AcadBlock

Dim textObj As AcadText

ThisDrawing.Utility.GetEntity textObj, basePnt, "Sélectionner le texte"

text = textObj.TextString

 

Set blocks = ThisDrawing.blocks

ThisDrawing.Utility.GetEntity obj, inspt, "Select object:"

objname = obj.EffectiveName

 

Set Blk = ThisDrawing.Application.ActiveDocument.blocks(objname)

 

Dim newatt As AcadAttribute

Dim height1 As Double

Dim mode1 As Long

Dim prompt1 As String

Dim insertionPoint1(0 To 2) As Double

Dim tag1 As String

Dim value1 As String

 

height1 = 0.1

value1 = "poteau n1"

mode1 = acAttributeModeVerify

prompt1 = "new_attribute"

insertionPoint1(0) = 0

insertionPoint1(1) = 0

insertionPoint1(2) = 0

 

 

If Err.Number <> 0 Then

MsgBox "the block does not exist"

Else

'Create new attribute

On Error Resume Next

Set newatt = Blk.AddAttribute(height1, mode1, _

prompt1, insertionPoint1, "Adresse_poteau", text)

If Err.Number <> 0 Then

 

MsgBox Err.Description

 

End If

 

ThisDrawing.SendCommand ("attsync n " & objname & vbCr)

End If

 

End Sub

 

c'est le code pour un seul bloc avec un texte, maintenant il faut modifier pour que chaque bloc dans la sélection (bien sur je vais isoler les blocs el les textes à ajouter comme attributs) prend le texte le plus proche comme premier attribut. donc il faut faire une boucle pour tout les blocs sélectionnés et à chaque bloc il faut faire une boucle pour prendre le texte dans lequel son point d'insertion est le plus proche du point de l'insertion du bloc et satisfaisant aussi une distance max "Dmax" sinon il prend la valeur "". j'essaye de développer cette idée mais comme je l'ai dèjà dit il me faut un coude de main pour arriver :unsure:

[Curlygoth]

pour la distance c'est facile c'est mon copain Pythagore qui a fait un théorème ! (je suis sur tu le connais):-) :

 

tu as 2 points :

 

 

Dim PTB (0 to 2) as double 'point du block (on cherchera à partir de celui la donc )
Dim PTT (0 to 2) as double 'Point du texte qui changera à chaque fois !

for u = 0 to 2 'tu n'as pas besoin de boucle tu peux aussi faire : PTB = obj.InsertionPoint (mais quand tu debogs et tu tu connais pas les espions c'est ce que je faisais avant et c'est resté XD)
PTB(u) = obj.InsertionPoint(u)
PTT(u) = textObj.Insertionpoint(u)
next u

D = sqr((PTB(0) - PTT(0))^2 + PTB(1) - PTT(1))^2)

fais en une fonction et conserve la valeur la plus petite

 

a la fin tu regarde si ta valeur est plus petite que ta tolérance

[Teamscad]

pour la distance c'est facile c'est mon copain Pythagore qui a fait un théorème ! (je suis sur tu le connais):-) :

 

tu as 2 points :

 

 

Dim PTB (0 to 2) as double 'point du block (on cherchera à partir de celui la donc )
Dim PTT (0 to 2) as double 'Point du texte qui changera à chaque fois !

for u = 0 to 2 'tu n'as pas besoin de boucle tu peux aussi faire : PTB = obj.InsertionPoint (mais quand tu debogs et tu tu connais pas les espions c'est ce que je faisais avant et c'est resté XD)
PTB(u) = obj.InsertionPoint(u)
PTT(u) = textObj.Insertionpoint(u)
next u

D = sqr((PTB(0) - PTT(0))^2 + PTB(1) - PTT(1))^2)

fais en une fonction et conserve la valeur la plus petite

 

a la fin tu regarde si ta valeur est plus petite que ta tolérance

 

 

Mercii, Je commence tout de suite à coder :D

Bonne journée et bon travail :)

[Teamscad]

Mercii, Je commence tout de suite à coder :D

Bonne journée et bon travail :)

 

Bonjour :D

j'ai un problème: j'ai créé le bloc avec attribut dans un fichier et je l'ai appelé pour remplacé le bloc existant, mais le moment ou je teste avec has.attributes il renvoie false, sachant que le bloc que j'ai créé contient 2 attribut.Peut être ma définition du bloc avec attribut est fausse ?? :blink:

[Curlygoth]

non, je pense que ta référence est rester sur l'ancien bloc qui lui n'a pas d'attribut ;-)

ou alors ton blocs n s'est pas mis à jour dans ton dessin... il peut y avoir un multiple d'erreur de code ^^

 

 

quand tu remplaces il te faut deux types acadblockreference ou 1 seul mais dans ce dernier cas faut "vider" la classe

[Teamscad]

non, je pense que ta référence est rester sur l'ancien bloc qui lui n'a pas d'attribut ;-)

ou alors ton blocs n s'est pas mis à jour dans ton dessin... il peut y avoir un multiple d'erreur de code ^^

 

 

quand tu remplaces il te faut deux types acadblockreference ou 1 seul mais dans ce dernier cas faut "vider" la classe

 

J'ai utilisé deux types de références; sur bloc de référence existant, j'ajoute le nouveau bloc avec les points d'insertions de ce dernier puis je l'écrase. jusqu'à le remplacement de tous les blocs.. autre problème que j'ai constaté.. lorsque je calcule la distance entre le texte et le point d'insertion je trouve pas les points d'insertions dans l'espace d'objets mais celui du bloc (X=0, Y=0).. :angry: :angry:

 

[Public Sub UpdateBlockWithAttribute(existingblks As AcadBlockReference)

 

Dim newBlks() As Variant

 

Dim extBlk As AcadBlockReference

 

Dim newBlk As AcadBlockReference

 

Dim i As Integer

 

Dim newBlkFile As String

 

newBlkFile = "C:\Users\Administrateur\bloc.dwg"

 

 

If UBound(existingblks) > 0 Then

 

For i = 0 To UBound(existingblks)

 

Set extBlk = existingblks(i)

 

'' Create new block reference

 

Set newBlk = ThisDrawing.ModelSpace.InsertBlock( _

extBlk.InsertionPoint, newBlkFile, _

extBlk.XScaleFactor, extBlk.YScaleFactor, extBlk.ZScaleFactor, extBlk.Rotation)

 

ReDim Preserve newBlks(i)

 

Set newBlks(i) = newBlk

 

 

'' Erase existing block

 

extBlk.Delete

 

Next

 

End If

 

End Sub]

[Curlygoth]

il ya deux ligne que je compprends pas moi

[Public Sub UpdateBlockWithAttribute(existingblks As AcadBlockReference)

 

existingblks c'est ton bloc existant pou moi 1 block et donc c'est pas une collection si ?

 

For i = 0 To UBound(existingblks) ' tu boucle sur ton block ?

 

Set extBlk = existingblks(i)

 

mais je vois pas la recherche de ton texte et sa position

[Teamscad]

Voici ma première fonction qui cherche le bloc à remplacer :

Private Function SearchBlockReferences(blkName As String) As Variant

Dim blks() As AcadBlockReference

Dim ent As AcadEntity

Dim blk As AcadBlockReference

Dim i As Integer

For Each ent in ThisDrawing.ModelSpace

If TypeOf ent Is AcadBlockReference Then

Set blk=ent

If UCase(blk.EffectiveName)=Ucase(blkName) Then

ReDim Preserve Blks(i)

Set blks(i)=blk

i=i+1

End If

End If

Next

SearchBlockReferences = blks

End Function

**********

Private Sub UpdateBlockAttribute(blks As Variant)

Dim blk As AcadBlockReference

Dim txt As string

Dim i As Integer

For i = 0 To UBound(blks)

Set blk = blks(i)

txt = FindClosestText(blk.InsertionPoint, 100.0) '' Only texts that is not far from 100.0 is considered

If Len(txt)>0 Then

txt = "No closest text found"

End If

SetAttribute blk, txt

Next

End Sub

****

Private Function FindClosestText(point As Variant, maxDistance As Double) As Text

Dim minDist As Double

Dim txtValue As String

Dim d As Double

Dim ent As AcadEntity

Dim text As AcadText

minDist = maxDistance

For Each ent InThisDrawing.ModelSpace

If TypeOf ent Is AcaddText Then

Set text=ent

d = GetDistanceToBlock(point, text.TextAlignmentPoint)

if d<minDist then

minDist = d

txtValue=text.TextString

End If

End If

Next

FindClosestText = txtValue

End Functon

*********

Private Function GetDistanceToBlock(point As Variant, txtPoint As Variant) As Double

Dim x As Double

Dim y As Double

Dim z As Double

x = txtPoint(0) - point(0)

y = txtPoint(1) - point(1)

z = txtPoint(2) - point(2)

GetDistanceToBlock=Sqr(x*x + y*y + z*z)

End Function

*******

Private Sub SetAttribute (blk As AcadBlockReference, txt As String)

Dim atts As Variant

Dim i As Integer

Dim att As AttributeReference

atts=blk.GetAttributes

For i = 0 To UBound(atts)

Set att = atts(i)

If UCase(att.TagString)="Nom_bloc" Then

att.TextString=txt

End If

Next

End Sub

****

Voilàa: j'espère que j'ai rien oublié, j'ai tapé maintenant parceque mon code est sur l'ordinateur du bureau.

[Teamscad]

existingblk as variant désolé..

[Curlygoth]

alors les points mets les en type double (c'est peut etre pour a que tu as 0)

 

variant c'est un joker je suis d'accord mais quand tu veux fixer un type et calculer avec fixe le !

 

pour la boucle sur tes éléments

 

je te conseil ça :

Dim ent As AcadEntity

For i = 0 To ThisDrawing.ModelSpace.Count - 1

Set ent = ThisDrawing.ModelSpace.Item(i)

 

ca va te permettre d'aller de 0 à la fin pas par ordre hasardeuse (en tout cas le temps du deboguage ça aide pas mal)

[Seysou]

alors les points mets les en type double (c'est peut etre pour a que tu as 0)

 

variant c'est un joker je suis d'accord mais quand tu veux fixer un type et calculer avec fixe le !

 

pour la boucle sur tes éléments

 

je te conseil ça :

Dim ent As AcadEntity

For i = 0 To ThisDrawing.ModelSpace.Count - 1

Set ent = ThisDrawing.ModelSpace.Item(i)

 

ca va te permettre d'aller de 0 à la fin pas par ordre hasardeuse (en tout cas le temps du deboguage ça aide pas mal)

Je vais voir, sinon pour l'attribut j'ai décomposé le bloc pour avoir un bloc attribut (j'ai vérifié sur le dessin qu'il contient l'attribut) mais toujours dans l'expression :For i = 0 To UBound(atts) la valeur Ubound(atts)=-1 ! j'ai pas compris pourquoi!

[Curlygoth]

For Each att In blockrefobj.GetAttributes 'j'utilise ça

If UCase(att.TagString)="Nom_bloc" Then 'tu as une erreur aussi ici Ucase mais tout en majuscule donc ta condition ne pas pas etre verifié vu que ton texte est en capital...

att.TextString=txt

else

End If

Next att