Teamscad

existingblk as variant désolé..

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.

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]

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:

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

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:

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)

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

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 !

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

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

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

Bonjour, Est ce que vous pouvez modifier le code pour des textes simples et pas de Mtexte ? par avance Merci

Bonjour, Peux tu svp m'envoyer le lisp ? par avance merci

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.