[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]

Curlygoth, le 21 janvier 2021 - 16:19 , dit :

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]

Curlygoth, le 22 janvier 2021 - 09:31 , dit :

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]

Curlygoth, le 22 janvier 2021 - 10:21 , dit :

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
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
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]

Curlygoth, le 22 janvier 2021 - 12:13 , dit :

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 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
Merci beaucoup beaucoup !

[Curlygoth]

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

[Teamscad]

Curlygoth, le 22 janvier 2021 - 14:56 , dit :

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]

Curlygoth, le 22 janvier 2021 - 10:21 , dit :

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]

Citation

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]

Curlygoth, le 25 janvier 2021 - 09:32 , dit :

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

[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]

Curlygoth, le 25 janvier 2021 - 11:56 , dit :

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
Bonne journée et bon travail

[Teamscad]

Teamscad, le 25 janvier 2021 - 12:33 , dit :

Mercii, Je commence tout de suite à coder
Bonne journée et bon travail

Bonjour
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 ??

[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]

Curlygoth, le 26 janvier 2021 - 10:31 , dit :

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)..

[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