Blocs imbriqués

[punky0147]

Je cherche à passer tous les éléments d'un document sur un même calque (calque 0 par exemple) et avec pour couleur "du calque", y compris les éléments internes aux blocs. Pour celà, je modifie toutes les définitions des blocs (thisdrawing.blocks) en mettant le calque à 0 et la couleur à "du calque", ensuite, je passe tous les objets du document (lignes, blocs, ...) que je met sur le calque 0 avec la couleur "du calque", je fait un update pour les blocs. Cependant, dans le cas de blocs imbriqués, les attributs se trouvant dans un bloc imbriqué ne changent pas de propriété (malgrés la redéfinition des blocs), et je ne peux pas faire un update, puisque je n'ai pas accès à ces attributs (du fait qu'ils font parti d'un bloc imbriqué dans un autre). Quelle est la solution ? Par exemple : j'ai un bloc A qui contient divers objets, dont un bloc B. Ce bloc B a des attributs. Comment forcé les propriétés de ces attributs ? Comment accèder aux objets qui constitue les bloc A sans décomposé celui-ci ? Si celà semble un peu flou, n'ésitez pas à me demander des précisions.

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