Copie d'un bloc en lui donnant un nouveau nom

Cette macro sert à copier un bloc en lui donnant un nouveau nom. L'intérêt de cette manipulation, c'est de pouvoir ainsi éditer un de ces deux blocs et le modifier, sans que le second soit affecté par ces modifications.
Pratique et rapide quand il s'agit de créer des blocs légèrement différents, sans devoir repasser par la fenêtre de création de bloc.
Le code est commenté, si vous avez des questions ou des améliorations, n'hésitez pas à poster un commentaire !

Merci aux différents intervenants du forum AutoCAD qui m'ont aidé dans la réalisation de cette macro :)

Dernière chose : ce code comme tous les autres, n'a été testé que sur AutoCAD 2005.

---

'*********************************************************************
'Cette macro crée un bloc identique à celui sélectionné, mais
'avec un nom différent, et remplace la référence du bloc sélectionnée
'par le nouveau bloc.
'Ceci permet de modifier le nouveau bloc sans que ces modifs ne
's'appliquent au bloc original.
'-------------------
'V.1.0 du 26/01/2010
'*********************************************************************

Sub DerefBlocs()
Dim pntPntSel As Variant 'Point pour sélectionner l'entité
Dim pntOrigine As Variant 'Point d'origine du bloc à copier
Dim pntInsertion As Variant 'Point d'insertion de la référence du bloc à modifier
Dim objSelectionne As AcadObject 'Objet sélectionné
Dim objRefBloc As AcadBlockReference
Dim objOriBloc As AcadBlock 'Bloc origine
Dim objNewBloc As AcadBlock 'Nouveau bloc à créer
Dim objBloc As AcadBlock 'Variable bloc pour parcourir la collection de bloc du dessin
Dim objLayout As AcadLayout 'Variable pour déterminer dans quel espace la macro est lancée
Dim booExiste As Boolean 'Variable de test
Dim strNomOrigine As String 'Nom du bloc d'origine
Dim strNomNouveau As String 'Nom du nouveau bloc
Dim strNomPresentation As String 'Nom de l'espace courant
Dim intI As Integer 'Compteur pour le nom du nouveau bloc
Dim douX As Double, douY As Double, douZ As Double 'Valeurs de l'échelle du bloc sélectionné
Dim douA As Double 'Valeur de rotation du bloc sélectionné

On Error GoTo GestErrCdG 'Si la touche Echap est appuyée ou autre erreur
   
'Sélection à l'écran d'une référence de bloc :
    Do
        ThisDrawing.Utility.GetEntity objSelectionne, pntPntSel, "Selectionner un bloc ou cliquer dans le vide pour quitter  "
        If objSelectionne.ObjectName = "AcDbBlockReference" Then Exit Do
        MsgBox "Ceci n'est pas un bloc !"
    Loop

'Nom du bloc original :
    strNomOrigine = objSelectionne.Name
'Initialisation du bloc original
    Set objOriBloc = ThisDrawing.Blocks(strNomOrigine)
'Point origine du bloc origine :
    pntOrigine = objOriBloc.Origin
'Echelles et rotation du bloc origine
    douX = objSelectionne.XScaleFactor
    douY = objSelectionne.YScaleFactor
    douZ = objSelectionne.ZScaleFactor
    douA = objSelectionne.Rotation
   
'Point d'insertion de la référence de bloc à déréférencer
    pntInsertion = objSelectionne.InsertionPoint

'Nom du nouveau bloc en proposant un nouveau nom par défaut
    intI = 1
    Do
        Do
            booExiste = False
            strNomNouveau = strNomOrigine & " Copie " & intI
            'Cherche un nom qui n'existe pas en proposant un indice après Copie
            For Each objBloc In ThisDrawing.Blocks
                If objBloc.Name = strNomNouveau Then
                    intI = intI + 1
                    booExiste = True
                    Exit For
                End If
            Next objBloc
            If Not booExiste Then
                booExiste = False
                Exit Do
            End If
        Loop
        'Propose un nouveau nom :
        strNomNouveau = InputBox("Saisir le nouveau nom du bloc " & strNomOrigine & " :", "Nouveau bloc", strNomNouveau)
        'Si le bouton annuler est sélectionner, quitter la macro
        If strNomNouveau = "" Then Exit Sub
       
        'Teste le nouveau nom entré pour vérifier qu'il n'existe pas
        For Each objBloc In ThisDrawing.Blocks
            If objBloc.Name = strNomNouveau Then
                MsgBox "Ce nom existe déjà ! Saisir un nouveau nom"
                booExiste = True
                Exit For
            End If
        Next objBloc
        If Not booExiste Then Exit Do
    Loop

'Initialisation du nouveau bloc :
Set objNewBloc = ThisDrawing.Blocks.Add(pntOrigine, strNomNouveau)

'Copie le bloc origine dans le nouveau bloc
    Set objRefBloc = ThisDrawing.Blocks(strNomNouveau).InsertBlock(pntOrigine, strNomOrigine, 1#, 1#, 1#, 0)

'Explose le bloc origine dans le nouveau bloc
    objRefBloc.Explode

'Supprime le bloc original qui reste dans le nouveau bloc malgré l'Explode
    objRefBloc.Delete
    Set objRefBloc = Nothing

'Trouve quel est l'espace actif afin d'insérer le nouveau bloc au bon endroit
    strNomPresentation = ThisDrawing.ObjectIdToObject(objSelectionne.OwnerID).Layout.Name
    Set objLayout = ThisDrawing.Layouts(strNomPresentation)

'Insére la référence du nouveau bloc au même endroit que bloc original
    Set objRefBloc = objLayout.Block.InsertBlock(pntInsertion, strNomNouveau, douX, douY, douZ, douA)

'Donne les attributs du bloc origine au nouveau bloc
    'Calque
    objRefBloc.Layer = objSelectionne.Layer
    'Couleur
    objRefBloc.color = objSelectionne.color
    'Trait
    objRefBloc.Linetype = objSelectionne.Linetype
    'Ep du trait
    objRefBloc.Lineweight = objSelectionne.Lineweight
    'Echelle du trait
    objRefBloc.LinetypeScale = objSelectionne.LinetypeScale
   
'Efface la référence du bloc original
    objSelectionne.Delete

'Lance la commande pour éditer le nouveau bloc
    ThisDrawing.SendCommand "_EDITREF "

'Fin de la macro
    Exit Sub

GestErrCdG: 'Gestionnaire d'erreur : sort de la macro quand ECHAP est actionné
    Exit Sub
   
End Sub

---

Comments

[yusseeff]

merci bcp