sechanbask

pour ton problème sous InStr(0, ThisDrawing.Blocks(i).Name, "C2005"), je pense avoir la solution: ne me demande pas pourquoi pour toutes les fonctions usuelles de VBA, je suis obligé de déclarer que ça appartient bien à VBA en faisant : VBA.InStr(0, ThisDrawing.Blocks(i).Name, "C2005") Si ça ne marche pas donne le type d'erreur que ça te donne... on l'a peut-être déjà rencontrée... pour le reste j'y regarde ce soir bon courage pour la suite [Edité le 3/3/2008 par sechanbask]

Pas trop déçu de fumer en dehors des resto, des discothèques et etc.?

Heureusement que je peux me rendre à mon boulot à pied ou en vélo. Je ne rends compte de la chance que j'ai et j'aimerais que tout le monde aie cette chance... en plus le stress de la voiture dans les bouchons que j'avais quand je faisais de la route me rendait fou...

enlève le 2 à la fin c'est peut-être une différence entre autocad 2006 et les version suppérieure. essaie et tiens moi au courant... [Edité le 27/2/2008 par sechanbask]

Si tu n'as pas trouvé la réponse regarde ici : http://www.cadxp.com/sujetXForum-18505.htm tu trouveras ton bonheur dans la Function formater_les_blocs() bon courage

pas de problème si tout le monde l'utilise mais il ne faut pas tenter de la modifier. Seul le premier qui à démarrer autocad aura le droit de lecture écriture... c'est pas souvent pratique pour moi qui n'arrive pas toujours le premier mais qui est le seul à modifier les programmes... Je me demande s'il est possible de géré les droits : lecture pour tous les postes sur ce fichier et lecture écrire sur le mien... Le problème c'est que je ne connait pas grand chose en réseaux sous WIN 2003 server.

ça permet de mettre n'importe quel plan même avec des couleurs forcées dans une couleur donnée (ici la couleur 8) pour s'en servir comme support afin de placer les réseaux dessus.Pour moi ce sont des réseaux de CVC et de plomberie mais pour d'autre ce sont des réseaux electriques etc... ça dépend du corps d'état mais on a souvent besoin de nettoyer les plans. Ainsi tu as une bonne différence entre la couleur des réseaux et du fond de plan.

solution envisageable mais ne répondant pas à la demande de formula1... Si j'arrive à me dégager un peu de temps dans la semaine je ferais un bout de macro pour créer de style de cote comme on avait fait pour la création des calques... @++ j'espère P.S. il faudrait que tu m'envoies une fichier autocad avec toutes les cotes que tu souahites insérer automatiquement, que tu me dises si c'est cotes de base ou des modifiées et dans quelle unités tu travailles... Voilà à partir de là je pourrais commencer... P.S. ça va moi aussi m'aider car je souhaite monter une charte graphique pour mon BE... [Edité le 27/2/2008 par sechanbask]

Bon comme vous le savez, c'est chiant de nettoyer des plans. Les archis et les betonneux aiment la couleur surtout si elle est forcée. Malheureusement pour ceux qui passent derrière, c'est pas évident de travailler sur des plans bariolés et c'est bien souvent difficile de les nettoyer car les couleurs ne dépendent plus des calques. C'est une chose terminée pour ceux qui utiliseront cet outil codé par mes soins... Je vous livre le code avec quelques explications pour ceux qui ne sont pas allergique au VBA... http://88.189.92.44/partage/ Faites moi par de vos commentaires, rapport de bugs, critiques constructives et évolutions possible de cet outil qui fait fureur dans mon BE. Bonne utilisation ![Edité le 8/10/2008 par sechanbask] [Edité le 13/2/2011 par sechanbask]

j'ai la solution je la poste très très bientôt, ce n'est plus qu'une question d'heure : je suis actuellement en train de commenter le code pour que les débutants puissent comprendre et pomper en comprenant ce qui les intéressent. Pour ce qui ont du mal à créer la fenêtre qui va avec, le projet entier sera déposé dans qqjours dans la section téléchargement... Bonne utilisation ! '[Licence du projet et des procédures qui en dépendent est à placer en tête de chaque module et procédure du programme: 'Le mot " programme " fait appel ici à au projet VBA " Projet.dvb " ' '- le programme est libre d'utilisation et restera, '- le programme est libre de modification sauf la "licence" (texte entre crochés) et restera, '- le code restera opensource quelque soit son évolution et devra toujours être clairement renseigné, '- le code est compatible avec d'autres bibliothèques opensources ou non et le restera, '- Les initiales de l'initiateur du projet ainsi que le texte ici présent entre crochés sont et resteront dans l'entête de chaque procédure du programme. ' '* J'ai conscience que cette licence n'est juridiquement pas valable mais veuillez, je vous prie, la respecter. ' 'Copyright (C) - C.B. allias Sechanbask] Option Explicit Public booblocs As Boolean Public bootextesupp As Boolean Public oLSM As AcadLayerStateManager 'pour le nettoyage Dim ent As AcadEntity 'pour les cotes Dim strCote As String 'pour les hachures Dim layCalque As AcadLayer 'pour les textes Dim objTexte As IAcadText2 Dim objMTexte As IAcadMText2 Dim strTexte As String Dim intZ As Integer 'pour les blocs Dim objBlock As AcadBlock Dim entint As AcadEntity 'pour les lignes et polylignes de longueur nulle Dim objLine As acadline Dim objPLine As AcadLWPolyline '[Licence du projet et des procédures qui en dépendent est à placer en tête de chaque module et procédure du programme: 'Le mot " programme " fait appel ici à au projet VBA " Projet.dvb " ' '- le programme est libre d'utilisation et restera, '- le programme est libre de modification sauf la "licence" (texte entre crochés) et restera, '- le code restera opensource quelque soit son évolution et devra toujours être clairement renseigné, '- le code est compatible avec d'autres bibliothèques opensources ou non et le restera, '- Les initiales de l'initiateur du projet ainsi que le texte ici présent entre crochés sont et resteront dans l'entête de chaque procédure du programme. ' '* J'ai conscience que cette licence n'est juridiquement pas valable mais veuillez, je vous prie, la respecter. ' 'Copyright (C) - C.B. allias Sechanbask] '--------------------------------------------------------------------------------------- 'Procedure : Lancer_choix ' Initiateur : C.B. ' Purpose : v.8.01.06 '--------------------------------------------------------------------------------------- Sub Lancer_choix() 'charger la userform Load Nparametres 'affiche la userform Nparametres.Show End Sub '[Licence du projet et des procédures qui en dépendent est à placer en tête de chaque module et procédure du programme: 'Le mot " programme " fait appel ici à au projet VBA " Projet.dvb " ' '- le programme est libre d'utilisation et restera, '- le programme est libre de modification sauf la "licence" (texte entre crochés) et restera, '- le code restera opensource quelque soit son évolution et devra toujours être clairement renseigné, '- le code est compatible avec d'autres bibliothèques opensources ou non et le restera, '- Les initiales de l'initiateur du projet ainsi que le texte ici présent entre crochés sont et resteront dans l'entête de chaque procédure du programme. ' '* J'ai conscience que cette licence n'est juridiquement pas valable mais veuillez, je vous prie, la respecter. ' 'Copyright (C) - C.B. allias Sechanbask] '--------------------------------------------------------------------------------------- 'Procedure : donner_acces_aux_calques ' Initiateur : C.B. ' Purpose : v.8.01.06 '--------------------------------------------------------------------------------------- 'déverrouille et dégèle les calque pour modifier l'ensemble du fichier Function donner_acces_aux_calques() Dim layer As AcadLayer 'si erreur passer à la ligne suivante On Error Resume Next 'pour tous les calques de ce dessin... For Each layer In ThisDrawing.layers 'degeler le calque layer.Freeze = False 'devérouiller le calque layer.Lock = False Next layer End Function '[Licence du projet et des procédures qui en dépendent est à placer en tête de chaque module et procédure du programme: 'Le mot " programme " fait appel ici à au projet VBA " Projet.dvb " ' '- le programme est libre d'utilisation et restera, '- le programme est libre de modification sauf la "licence" (texte entre crochés) et restera, '- le code restera opensource quelque soit son évolution et devra toujours être clairement renseigné, '- le code est compatible avec d'autres bibliothèques opensources ou non et le restera, '- Les initiales de l'initiateur du projet ainsi que le texte ici présent entre crochés sont et resteront dans l'entête de chaque procédure du programme. ' '* J'ai conscience que cette licence n'est juridiquement pas valable mais veuillez, je vous prie, la respecter. ' 'Copyright (C) - C.B. allias Sechanbask] '--------------------------------------------------------------------------------------- 'Procedure : formater_les_calques_8 ' Initiateur : C.B. ' Purpose : v.8.01.05 '--------------------------------------------------------------------------------------- Function formater_les_calques_8() On Error GoTo 0 Dim layer As AcadLayer 'pour chaque calque dans la collection des calques For Each layer In ThisDrawing.layers 'mettre la couleur 8 au calque actuellement pointé layer.color = "8" Next layer End Function '[Licence du projet et des procédures qui en dépendent est à placer en tête de chaque module et procédure du programme: 'Le mot " programme " fait appel ici à au projet VBA " Projet.dvb " ' '- le programme est libre d'utilisation et restera, '- le programme est libre de modification sauf la "licence" (texte entre crochés) et restera, '- le code restera opensource quelque soit son évolution et devra toujours être clairement renseigné, '- le code est compatible avec d'autres bibliothèques opensources ou non et le restera, '- Les initiales de l'initiateur du projet ainsi que le texte ici présent entre crochés sont et resteront dans l'entête de chaque procédure du programme. ' '* J'ai conscience que cette licence n'est juridiquement pas valable mais veuillez, je vous prie, la respecter. ' 'Copyright (C) - C.B. allias Sechanbask] '--------------------------------------------------------------------------------------- 'Procedure : supprimer_presentation ' Initiateur : C.B. ' Purpose : v.8.01.05 '--------------------------------------------------------------------------------------- Function supprimer_presentation() Dim presentation As AcadLayout 'si erreur passer à la ligne suivante On Error Resume Next 'pour chaque présentation dans la collection des présentations For Each presentation In ThisDrawing.Layouts 'supprimer la présentation actuellement pointée presentation.Delete Next presentation End Function '[Licence du projet et des procédures qui en dépendent est à placer en tête de chaque module et procédure du programme: 'Le mot " programme " fait appel ici à au projet VBA " Projet.dvb " ' '- le programme est libre d'utilisation et restera, '- le programme est libre de modification sauf la "licence" (texte entre crochés) et restera, '- le code restera opensource quelque soit son évolution et devra toujours être clairement renseigné, '- le code est compatible avec d'autres bibliothèques opensources ou non et le restera, '- Les initiales de l'initiateur du projet ainsi que le texte ici présent entre crochés sont et resteront dans l'entête de chaque procédure du programme. ' '* J'ai conscience que cette licence n'est juridiquement pas valable mais veuillez, je vous prie, la respecter. ' 'Copyright (C) - C.B. allias Sechanbask] '--------------------------------------------------------------------------------------- ' Procedure : enregistrer_etat_calque ' Initiateur : C.B. ' Purpose : v.8.01.06 '--------------------------------------------------------------------------------------- Function enregistrer_etat_calque() On Error Resume Next 'accéder au gestionnaire d'état des calques Set oLSM = ThisDrawing.Application. _ GetInterfaceObject("AutoCAD.AcadLayerStateManager.16") 'Rendre courant l'état de calque actuel oLSM.SetDatabase ThisDrawing.Database 'supprimer l'enregistrement "calque avant modif" oLSM.Delete "calque avant modif" 'enregistrer l'état gelé et vérouillé de tous les calques oLSM.Save "calque avant modif", acLsFrozen + acLsOn End Function '[Licence du projet et des procédures qui en dépendent est à placer en tête de chaque module et procédure du programme: 'Le mot " programme " fait appel ici à au projet VBA " Projet.dvb " ' '- le programme est libre d'utilisation et restera, '- le programme est libre de modification sauf la "licence" (texte entre crochés) et restera, '- le code restera opensource quelque soit son évolution et devra toujours être clairement renseigné, '- le code est compatible avec d'autres bibliothèques opensources ou non et le restera, '- Les initiales de l'initiateur du projet ainsi que le texte ici présent entre crochés sont et resteront dans l'entête de chaque procédure du programme. ' '* J'ai conscience que cette licence n'est juridiquement pas valable mais veuillez, je vous prie, la respecter. ' 'Copyright (C) - C.B. allias Sechanbask] '--------------------------------------------------------------------------------------- ' Procedure : enregistrer_etat_calque_insertion_bloc ' Initiateur : C.B. ' Purpose : v.8.01.06 '--------------------------------------------------------------------------------------- Function enregistrer_etat_calque_insertion_bloc() On Error Resume Next 'accéder au gestionnaire d'état des calques Set oLSM = ThisDrawing.Application. _ GetInterfaceObject("AutoCAD.AcadLayerStateManager.16") 'Rendre courant l'état de calque actuel oLSM.SetDatabase ThisDrawing.Database 'supprimer l'enregistrement "calque avant modif" oLSM.Delete "calque avant modif" 'enregistrer l'état gelé, activé et vérouillé de tous les calques oLSM.Save "calque avant modif", acLsFrozen + acLsOn + acLsLocked End Function '[Licence du projet et des procédures qui en dépendent est à placer en tête de chaque module et procédure du programme: 'Le mot " programme " fait appel ici à au projet VBA " Projet.dvb " ' '- le programme est libre d'utilisation et restera, '- le programme est libre de modification sauf la "licence" (texte entre crochés) et restera, '- le code restera opensource quelque soit son évolution et devra toujours être clairement renseigné, '- le code est compatible avec d'autres bibliothèques opensources ou non et le restera, '- Les initiales de l'initiateur du projet ainsi que le texte ici présent entre crochés sont et resteront dans l'entête de chaque procédure du programme. ' '* J'ai conscience que cette licence n'est juridiquement pas valable mais veuillez, je vous prie, la respecter. ' 'Copyright (C) - C.B. allias Sechanbask] '--------------------------------------------------------------------------------------- ' Procedure : ouverture_etat_calque ' Initiateur : C.B. ' Purpose : v.8.01.06 '--------------------------------------------------------------------------------------- Function ouverture_etat_calque() On Error Resume Next 'accéder au gestionnaire d'état des calques Set oLSM = ThisDrawing.Application. _ GetInterfaceObject("AutoCAD.AcadLayerStateManager.16") 'Rendre courant l'état de calque actuel oLSM.SetDatabase ThisDrawing.Database 'Restaurer l'enregistrement de l'état de tous les calques oLSM.Restore "calque avant modif" End Function '[Licence du projet et des procédures qui en dépendent est à placer en tête de chaque module et procédure du programme: 'Le mot " programme " fait appel ici à au projet VBA " Projet.dvb " ' '- le programme est libre d'utilisation et restera, '- le programme est libre de modification sauf la "licence" (texte entre crochés) et restera, '- le code restera opensource quelque soit son évolution et devra toujours être clairement renseigné, '- le code est compatible avec d'autres bibliothèques opensources ou non et le restera, '- Les initiales de l'initiateur du projet ainsi que le texte ici présent entre crochés sont et resteront dans l'entête de chaque procédure du programme. ' '* J'ai conscience que cette licence n'est juridiquement pas valable mais veuillez, je vous prie, la respecter. ' 'Copyright (C) - C.B. allias Sechanbask] '--------------------------------------------------------------------------------------- ' Procedure : Nettoyage_en_une_boucle ' Initiateur : C.B. ' Purpose : v.8.01.06 '--------------------------------------------------------------------------------------- Function Nettoyage_en_une_boucle() 'on Error GoTo 0 On Error GoTo gestion 'si l'utilisateur souhaite cacher les hachures dans un calque If Nparametres.ChB_Cacher_hachures Then 'création du calque Set layCalque = ThisDrawing.layers.Add("- -Hachures") 'geler ce calque layCalque.Freeze = True 'mettre la couleur 8 au calque layCalque.color = "8" End If 'test pour la suppression des objects 'si l'utilisateur souhaite supprimer les cotes ou les points, les textes vides, etc. If Nparametres.ChB_cotes.Value = True Or Nparametres.ChB_Supprimer_points.Value = True Then 'boucler dans l'espace objet pour la suppression des objects 'pour chaque entitée dans l'espace objet For Each ent In ThisDrawing.ModelSpace 'si entint est une cote (permet de traiter toute les coté sans savoir si elle est alignée, linéaire etc.) If VBA.Right(entint.ObjectName, 9) = "Dimension" Then 'récupérer le nom de la coté dans strCote strCote = entint.ObjectName End If 'si l'entitée ent est... Select Case ent.ObjectName '...une ligne Case "AcDbLine" 'si l'utilisateur souhaite supprimer les points, les textes vides, etc. If Nparametres.ChB_Supprimer_points.Value = True Then 'prendre l'entitée entint comme un objet ligne Set objLine = ent 'si la longueur de la ligne est nulle If objLine.Length = 0 Then 'supprimer l'objet ligne ent.Delete End If End If 'Nparametres.ChB_Supprimer_points.Value = True '...une polyligne Case "AcDbPolyline" 'si l'utilisateur souhaite supprimer les points, les textes vides, etc. If Nparametres.ChB_Supprimer_points.Value = True Then 'prendre l'entitée entint comme un objet polyligne Set objPLine = ent 'si la longueur de la polyligne est nulle If objPLine.Length = 0 Then 'supprimer l'objet polyligne ent.Delete End If End If 'Nparametres.ChB_Supprimer_points.Value = True '...un point Case "AcDbPoint" 'si l'utilisateur souhaite supprimer les points, les textes vides, etc. If Nparametres.ChB_Supprimer_points.Value = True Then 'supprimer l'objet point ent.Delete End If '... un texte Case "AcDbText" 'si l'utilisateur souhaite supprimer les points, les textes vides, etc. If Nparametres.ChB_Supprimer_points.Value = True Then 'prendre l'entitée ent comme un objet texte Set objTexte = ent 'récupérer le contenu du texte strTexte = objTexte.FieldCode 'remplacer tous les espace par "rien" strTexte = VBA.Replace(strTexte, " ", "") 'si le texte est vide... If strTexte = "" Then 'supprimer l'objet texte ent.Delete End If End If 'Nparametres.ChB_Supprimer_points.Value = True '... un texte multiligne Case "AcDbMText" 'si l'utilisateur souhaite supprimer les points, les textes vides, etc. If Nparametres.ChB_Supprimer_points.Value = True Then 'prendre l'entitée entint comme un objet texte Set objMTexte = ent 'récupérer le contenu du texte strTexte = objMTexte.FieldCode 'remplacer tous les espace par "rien" strTexte = VBA.Replace(strTexte, " ", "") 'si le texte est vide... If strTexte = "" Then 'supprimer l'objet texte ent.Delete End If End If 'Nparametres.ChB_Supprimer_points.Value = True '... une cote Case strCote 'si l'utilisateur souhaite supprimer les cotes If Nparametres.ChB_cotes.Value = True Then 'supprimer l'objet cote ent.Delete End If 'Nparametres.ChB_cotes.Value = True End Select 'ent.ObjectName Next ent End If 'Nparametres.ChB_cotes.Value = True Or Nparametres.ChB_Supprimer_points.Value = True 'boucler dans l'espace objet pour modification des propriétés For Each ent In ThisDrawing.ModelSpace 'formater les objets en couleur ducalque, type de ligne du calque, et épaisseur de ligne par défaut If Nparametres.ChB_entite_couleur.Value = True Then 'formater la couleur de l'entité en DUCALQUE ent.color = acByLayer 'formater le type de ligne de l'entité en DUCALQUE ent.Linetype = "BYLAYER" 'formater l'épaisseur de ligne de l'entité en "PAR_DEFAUT" ent.Lineweight = acLnWtByLwDefault End If 'Nparametres.ChB_entite_couleur.Value = True 'si l'entitée entint est... Select Case ent.ObjectName '...une hachure Case "AcDbHatch" 'si l'utilisateur souhaite cacher les hachures dans un calque If Nparametres.ChB_Cacher_hachures Then 'mettre la hachure dans le calque "- -Hachures" ent.layer = "- -Hachures" End If 'si le texte est un texte simple ligne Case "AcDbText" 'si l'utilisateur souhaite formater les textes dont la couleur est forcée If Nparametres.ChB_liberer_textes.Value = True Then 'prendre l'entitée entint comme un objet texte Set objTexte = ent 'récupérer le contenu du texte strTexte = objTexte.FieldCode 'pour chaque couleur dans la palette, For intZ = 0 To 256 'remplacer la couleur forcée du texte par la couleur DUCALQUE strTexte = VBA.Replace(strTexte, "\C" & intZ & ";", "") 'mettre la chaine de caractère ainsi modifiée dans l'objet texte objTexte.TextString = strTexte Next intZ End If 'Nparametres.ChB_liberer_textes.Value = True 'si le texte est un multiligne Case "AcDbMText" 'si l'utilisateur souhaite formater les textes dont la couleur est forcée If Nparametres.ChB_liberer_textes.Value = True Then 'prendre l'entitée entint comme un objet Mtexte Set objMTexte = ent 'récupérer le contenu du texte strTexte = objMTexte.FieldCode 'pour chaque couleur dans la palette, For intZ = 0 To 256 'remplacer la couleur forcée du texte par la couleur DUCALQUE strTexte = VBA.Replace(strTexte, "\C" & intZ & ";", "") 'mettre la chaine de caractère ainsi modifiée dans l'objet texte objMTexte.TextString = strTexte Next intZ End If 'Nparametres.ChB_liberer_textes.Value = True End Select 'ent.ObjectName Next ent Exit Function gestion: ThisDrawing.Utility.Prompt " L'erreur " & Err.Number & " est survenue, Ligne: " & Erl() & ". Veuillez contacter le développeur (sechanbask@hotmail.com)." End Function '[Licence du projet et des procédures qui en dépendent est à placer en tête de chaque module et procédure du programme: 'Le mot " programme " fait appel ici à au projet VBA " Projet.dvb " ' '- le programme est libre d'utilisation et restera, '- le programme est libre de modification sauf la "licence" (texte entre crochés) et restera, '- le code restera opensource quelque soit son évolution et devra toujours être clairement renseigné, '- le code est compatible avec d'autres bibliothèques opensources ou non et le restera, '- Les initiales de l'initiateur du projet ainsi que le texte ici présent entre crochés sont et resteront dans l'entête de chaque procédure du programme. ' '* J'ai conscience que cette licence n'est juridiquement pas valable mais veuillez, je vous prie, la respecter. ' 'Copyright (C) - C.B. allias Sechanbask] '--------------------------------------------------------------------------------------- ' Procedure : formater_les_blocs ' Initiateur : C.B. ' Purpose : v.8.02.25 '--------------------------------------------------------------------------------------- Function formater_les_blocs() On Error GoTo gestion Dim objBlock As AcadBlock Dim ent As AcadEntity Dim entint As AcadEntity 'initialiser la variable qui sert à savoir si nous avons rencontrer un bloc avec attribut booblocs = False 'si l'utilisateur souhaite cacher les hachures dans un calque If Nparametres.ChB_Cacher_hachures Then 'création du calque Set layCalque = ThisDrawing.layers.Add("- -Hachures") 'geler ce calque layCalque.Freeze = True 'mettre la couleur 8 au calque layCalque.color = "8" End If 'Pour tous les blocs dans la collections de blocs (et non pas dans le dessin, si non impossible de traiter les blocs impriqués) For Each objBlock In ThisDrawing.Blocks 'si les 12 permiers caractère du nom du bloc commence par... Select Case VBA.Left(objBlock.Name, 12) '"*model_space ou "*paperspace" Case "*Model_Space", "*Paper_Space" 'ne rien faire car ce ne sont pas des blocs Case Else 'sinon 'si l'utilisateur souhaite formater les blocs If Nparametres.ChB_formater_blocs.Value = True Then 'pour toutes les entités (entint) qui constituent le bloc For Each entint In objBlock 'initialise la varible qui indique si le texte ou Mtexte a été supprimé. bootextesupp = False 'si entint est une cote (permet de traiter toute les coté sans savoir si elle est alignée, linéaire etc.) If VBA.Right(entint.ObjectName, 9) = "Dimension" Then 'récupérer le nom de la coté dans strCote strCote = entint.ObjectName End If 'formater la couleur de l'entité en DUCALQUE entint.color = acByLayer 'formater le type de ligne de l'entité en DUCALQUE entint.Linetype = "BYLAYER" 'formater l'épaisseur de ligne de l'entité en "PAR_DEFAUT" entint.Lineweight = acLnWtByLwDefault 'si l'entitée entint est... Select Case entint.ObjectName '...une hachure Case "AcDbHatch" 'si l'utilisateur souhaite cacher les hachures dans un calque If Nparametres.ChB_Cacher_hachures Then 'mettre la hachure dans le calque "- -Hachures" entint.layer = "- -Hachures" End If '... un attribut Case "AcDbAttributeDefinition" 'modifier la variable booblocs (pour savoir si on doit synchroniser les attributs) booblocs = True '... un texte Case "AcDbText" 'si l'utilisateur souhaite supprimer les points, les textes vides, etc. If Nparametres.ChB_Supprimer_points.Value = True Then 'prendre l'entitée entint comme un objet texte Set objTexte = entint 'récupérer le contenu du texte strTexte = objTexte.FieldCode 'remplacer tous les espace par "rien" strTexte = VBA.Replace(strTexte, " ", "") 'si le texte est vide... If strTexte = "" Then 'indiquer la suppression de l'objet texte bootextesupp = True 'supprimer l'objet texte entint.Delete End If End If 'Nparametres.ChB_Supprimer_points.Value = True 'si l'utilisateur souhaite formater les textes dont la couleur est forcée et si l'objet n'est pas supprimer_ 'dans la condition précédente If Nparametres.ChB_liberer_textes.Value = True And bootextesupp = False Then 'prendre l'entitée entint comme un objet texte Set objTexte = entint 'récupérer le contenu du texte strTexte = objTexte.FieldCode 'pour chaque couleur dans la palette, For intZ = 0 To 256 'remplacer la couleur forcée du texte par la couleur DUCALQUE strTexte = VBA.Replace(strTexte, "\C" & intZ & ";", "") 'mettre la chaine de caractère ainsi modifiée dans l'objet texte objTexte.TextString = strTexte Next intZ End If 'Nparametres.ChB_liberer_textes.Value = True And bootextesupp = False '... un texte multiligne Case "AcDbMText" 'si l'utilisateur souhaite supprimer les points, les textes vides, etc. If Nparametres.ChB_Supprimer_points.Value = True Then 'prendre l'entitée entint comme un objet texte Set objMTexte = entint 'récupérer le contenu du texte strTexte = objMTexte.FieldCode 'remplacer tous les espace par "rien" strTexte = VBA.Replace(strTexte, " ", "") 'si le texte est vide... If strTexte = "" Then 'indiquer la suppression de l'objet texte bootextesupp = True 'supprimer l'objet texte entint.Delete End If End If 'Nparametres.ChB_Supprimer_points.Value = True 'si l'utilisateur souhaite formater les textes dont la couleur est forcée et si l'objet n'est pas supprimer_ 'dans la condition précédente If Nparametres.ChB_liberer_textes.Value = True And bootextesupp = False Then 'prendre l'entitée entint comme un objet texte Set objMTexte = entint 'récupérer le contenu du texte strTexte = objMTexte.FieldCode 'pour chaque couleur dans la palette, For intZ = 0 To 256 'remplacer la couleur forcée du texte par la couleur DUCALQUE strTexte = VBA.Replace(strTexte, "\C" & intZ & ";", "") 'mettre la chaine de caractère ainsi modifiée dans l'objet texte objMTexte.TextString = strTexte Next intZ End If 'Nparametres.ChB_liberer_textes.Value = True And bootextesupp = False '...un point Case "AcDbPoint" 'si l'utilisateur souhaite supprimer les points, les textes vides, etc. If Nparametres.ChB_Supprimer_points.Value = True Then 'supprimer l'objet point entint.Delete End If '...une ligne Case "AcDbLine" 'si l'utilisateur souhaite supprimer les points, les textes vides, etc. If Nparametres.ChB_Supprimer_points.Value = True Then 'prendre l'entitée entint comme un objet ligne Set objLine = entint 'si la longueur de la ligne est nulle If objLine.Length = 0 Then 'supprimer l'objet ligne entint.Delete End If End If 'Nparametres.ChB_Supprimer_points.Value = True '...une polyligne Case "AcDbPolyline" 'si l'utilisateur souhaite supprimer les points, les textes vides, etc. If Nparametres.ChB_Supprimer_points.Value = True Then 'prendre l'entitée entint comme un objet polyligne Set objPLine = entint 'si la longueur de la polyligne est nulle If objPLine.Length = 0 Then 'supprimer l'objet polyligne entint.Delete End If End If 'Nparametres.ChB_Supprimer_points.Value = True '... une cote Case strCote 'si l'utilisateur souhaite supprimer les cotes If Nparametres.ChB_cotes.Value = True Then 'supprimer l'objet cote entint.Delete End If End Select 'entint.ObjectName Next entint End If 'Nparametres.ChB_formater_blocs.Value = True End Select 'VBA.Left(objBlock.Name, 12) Next objBlock 'pour les blocs If booblocs = True Then ThisDrawing.SendCommand "_attsync" & vbCr & "n" & vbCr & "*" & vbCr End If Exit Function gestion: ThisDrawing.Utility.Prompt " L'erreur " & Err.Number & " est survenue, Ligne: " & Erl() & ". Veuillez contacter le développeur (sechanbask@hotmail.com)." End Function [Edité le 26/2/2008 par sechanbask]

Ici le problème n'est pas la forme du code mais son algorithme. Si tu es capable d'écrire l'algorithme du programme, il sera très facile de répondre à cette demande en écrivant le code en VBA ou en n'importe quelle langage suporté par autocad. Apèrs avoir longuement réflechi, je n'ai toujours pas avancé, je n'arrive pas concevoir une méthode pour que cette idée devienne réalisable. Je m'explique en posant la questions ici sans réponse (suite à ma reflexion): Comment fait-on pour repérer relativement les entités entre elles, pour qu'en cherchant dans l'ensemble du plan on retrouve un même groupe ? Imagions que l'utilisateur pointe2 points il est facile d'en trouver 2 autre dans le dessin avec la même distance les séparant mais comment faire pour 2 lignes, 3 polylignes, 22 points, 15 attributs etc... Car il est simple de rechercher une entitée identique à celle que l'utilisateur pointe mais comment en chercher plusieurs et vérifier qu'elle constitue une "groupe" (pas au sens autocad mais littérale) afin de les agglutiner en blocs ? Ce sujet est des plus passionnant mais n'est-ce pas le saint Grâal ? J'aimerais vraiment trouver la solution mais ça me semble très complexe...

ce qu'il faut comme pour tout les projets : un algorithme, avec ça même moi qui connait rien au béton, je pourrais donner un coup de main...

bonjour, je pourrais certainement aider un peu mais je suis tellement charger que je n'arrive pas à suivre mes propres projets... alors il me faut une demande très précise pour que je suis puisse y répondre désolé...

le problème c'est que le code ne sera pas en lisp car je ne connais que le VBA, alors si ça te gène j'arrête mes recherches... En plus, avec les Xdata, on ne peut pas mettre beaucoup de donnée, le mieux ce sont les Xrecord... tiens moi au courant si je dois continuer...

oui c'est possible, avec de la programmation tu tu connais le lisp ou le VBA c'est possible. sinon, on est là pour ça : il me faudrait la couleur qui te gène et celle qui la remplace : ici, je te laisse le code pour changer la couleur bleu en rouge (mais j'estime qu'il est souvent préférable de mettre les objets dans la couleur de leur calque mais bon...) voilà le code VBA à mettre dans un module....(je te laisse aller voir ce post : http://www.cadxp.com/sujetXForum-17239.htm Sub formater_les_objets_DUCALQUE() On Error GoTo gestion Dim ent As AcadEntity Dim entInt As AcadEntity Dim objBlock As AcadBlock For Each ent In ThisDrawing.ModelSpace If ent.color = acBlue Then ent.color = acRed End If If ent.ObjectName = "AcDbBlockReference" Then Set objBlock = ThisDrawing.Blocks.Item(ent.Name) For Each entInt In objBlock If entInt.color = acBlue Then entInt.color = acRed End If Next entInt End If Next ent gestion: Debug.Print Err.Number End Sub bon courage et bonne utilisation, si tu as des questions... nous sommes là. P.S. Bred, je ne te savais si pessimiste... [Edité le 13/1/2008 par sechanbask]

c'est urgent ? si oui adresse toi au forum dédié au lisp sinon : les blocs sont dans un seul fichier ou plusieurs? j'aurais également besoin de savoir le nombre d'attribut par bloc et éventuellement l'étiquette de l'attribut. Enfin, l'attribut est-il constant ou non ? car s'il est constant, il faut que j'utilise une méthode différente.... [Edité le 3/1/2008 par sechanbask]

merci pour tout le premier code fonctionne à merveille, je ne sais pas pourquoi au début il ne voulait pas fonctionner... sujet résolu

ce sujet est résolu non ?

la protection n'est qu'une illusion car si qq'un est capable de codé ou crypter, une autre personne est capable de le faire... j'ai abandonné cette idée et j'ai rendu mon travail accessible à tous (j'ai mis le mot de passe mais tout le monde peut l'obtenir) mais je leur demande de ne pas le faire. En effet, la maintenance du projet sera bien plus compliqué si on est 5 à créér ou à modifier les projets... Ainsi, j'ai remarqué que j'avais davantage de retour pour l'amélioration et personne ne cherche à forcer le projet. concernant, le VB avec autocad, je ne l'ai pas mais il me semble que ça fonctionne comme pour le VBA en ajoutant les références et en lançant autocad. J'ai tenté d'utiliser VB.net mais beaucoup de syntaxe ont changé... bon courage

ça doit venir de ce pu*** de fisacad de m****... je testerai ça lundi en n'ouvrant qu'autocad... P.S. s'il me reste du temps avant d'être retraité, je ferais en sorte de ne plus avoir à utiliser les prologiciels vendus au prix d'une barre en or et qui ne valent pas une barre de chocolat... Par avance, je m'excuse auprès des amoureux du chocolat.

merci pour ce sujet fort utile....

je ne comprends pas ça ne fonctionne pas. si je sélectionne mon bloc avant j'obtiens l'ereur suivante : "; erreur: une erreur est survenue dans la fonction *erreur*paramètre de la variable AutoCAD rejeté: "OSMODE" nil" si je lance le commande et que je choisi mon bloc après. Rien ne se passe... bizarre, non ? j'ai une version 2006 full...

je n'ai que la version 2006, mais je pense que c'est au même endroit : Outils - Options, onglet ouvrir et enregistrer, cadre ouvrir fichier "Afficher le chemin complet dans le titre" bon courage

oui mais si on teste mon programme, on pourra aller bien plus loin dans l'exploitation des versions LT... donc tout ce que je souhaite c'est qu'une personne qui possède une version LT m'aide à faire des tests... après je ne me propose de résoudre son problème, je ponds le code, oui n'aura qu'à le tester.... et puis pourquoi tu réponds à sa place ? il est peut être intéressé par d'autre fonction ?

voilà le principe, Excel intente autocad grâce au VBA . http://www.cijoint.fr/cij47154110134519.xls ne pas avoir autocad d'ouvert il faut ouvrir le classeur excel, puis faire F8, cliquer sur Lancer_autocad et faire executer, là normalement le PC se met en branle et lance autocad 2007 LT. j'espère que c'est ta version car sinon ça marchera pas. Ce n'est bien sur que le début mais si autocad s'ouvre déjà c'est bien après ça devient plus compliquer mais la si puissance du VBA peux intenter autocad LT, tu pourras avoir beaucoup de fonctions supplémentaire pour autocad LT... Je n'en dis pas plus car si ça marche pas j'aurais l'air con. P.S. ce code n'est pas à moi mais il marche sur un autre forum http://discussion.autodesk.com/thread.jspa?threadID=595631.