Exemples de routine VBA

Pour faciliter votre compréhension, ces macros VBA sont simplifiées : pas de gestion des erreurs, pas de boite de dialogue, pas de travail sur les espaces PAPIER, ...

Nettoyer le calque 0

Une bonne pratique sous AutoCAD est de ne jamais rien laisser dans le calque 0 ! Si votre plan contient une multitude d'objets dans le calque 0, vous trouverez ci-dessous la macro VBA permettant de déplacer les objets vers un autre calque :

1) Définir le nom du nouveau calque et le créer
2) Parcourir les entités de l'espace OBJET
3) Changer le calque des objets contenus dans "0"

Sub NettoyerCalque0()
Dim NomNouveauCalque As String
NomNouveauCalque = "0bis"
ThisDrawing.Layers.Add (NomNouveauCalque)
For Each ent In ThisDrawing.ModelSpace
  If ent.Layer = "0" Then
   ent.Layer = NomNouveauCalque
  End If
Next ent
End Sub

Détecter les polylignes non fermées

1) Parcourir le dessin et forcer tous les objets en blanc
2) Rechercher les polylignes 2D
3) Forcer en rouge les polylignes ouvertes (en vert sinon)
4) Regénérer la vue

Sub PolylignesOuvertes()
For Each ent In ThisDrawing.ModelSpace
  ent.color = acWhite
  If ent.ObjectName = "AcDbPolyline" Then
   If ent.Closed = False Then
    ent.color = acRed
   Else
    ent.color = acGreen
   End If
  End If
Next ent
ThisDrawing.Regen (acActiveViewport)
End Sub

Mesurer la distance 2D entre deux points

Il est parfois difficile de mesurer une distance 2D entre deux points : il arrive souvent que l'on récupère la distance 3D en s'accrochant sur un point en Z. Vous trouverez ci-dessous une macro VBA qui ne tient pas compte des altitudes !

1) Cliquer le premier point
2) Cliquer le second point
3) Dessiner une ligne reliant les points
4) Calculer et arrondir la distance 2D entre les points
5) Afficher le résultat en ligne de commande

Sub Distance2D()
Dim Pt1 As Variant
Pt1 = ThisDrawing.Utility.GetPoint(, "Cliquer le premier point : ")
Dim Pt2 As Variant
Pt2 = ThisDrawing.Utility.GetPoint(, "Cliquer le second point : ")
ThisDrawing.ModelSpace.AddLine Pt1, Pt2
Dim DI As Double
DI = ((Pt1(0) - Pt2(0)) ^ 2 + (Pt1(1) - Pt2(1)) ^ 2) ^ 0.5
DI = Round(DI, 2)
ThisDrawing.Utility.Prompt ("Di2D= " & DI & " unité(s)") & vbCrLf
End Sub

Formater le nom des espaces AEC

Le langage VBA peut aussi s'utiliser sur les objets des produits verticaux ! (comme AutoCAD Architecture par exemple). La macro suivante formate les noms des espaces AEC en les mettant en majuscules :

1) Parcourir tout le dessin
2) Rechercher les espaces AEC
3) Mettre en majuscules les noms

Sub NomEspaceEnMajuscule()
For Each obj In ThisDrawing.ModelSpace
  If obj.ObjectName = "AecDbSpace" Then
   obj.Name = UCase(obj.Name)
  End If
Next obj
End Sub

Ajouter un préfixe à tous les calques

1) Demander le préfixe à l'utilisateur
2) Parcourir tous les calques du dessin
3) Ajouter le préfixe à chaque nom de calque

Sub AjouterPréfixeCalque()
Dim Prefixe As String
Prefixe = ThisDrawing.Utility.GetString(1, "Quel est le préfixe ?")
On Error Resume Next
  Dim L As AcadLayer
  For Each L In ThisDrawing.Layers
   L.Name = Prefixe & L.Name
  Next L
End Sub

Réinitialiser les noms de traceur sur AUCUN

1) Parcourir toutes les présentations
2) Attribuer un nouveau nom de traceur :
"Aucun" pour un AutoCAD ..., 2007, 2008 ou 2009
"Aucun(e)" pour un AutoCAD 2010, 2011, 2012, ...

Sub AucunNomTraceur()
On Error Resume Next
Dim Presentation As AcadLayout
For Each Presentation In ThisDrawing.Layouts
Presentation.ConfigName = "Aucun"
Presentation.ConfigName = "Aucun(e)"
Next Presentation
End Sub

Lister les chemins des références externes d'un dessin

1) Parcourir tous les blocs
2) Vérifier si il s'agit d'une référence externe
3) Écrire son chemin d'accès en ligne de commande

Sub ListerReferenceExterne()
Dim REF As AcadBlock
For Each REF In ThisDrawing.Blocks
  If REF.IsXRef Then
   ThisDrawing.Utility.Prompt REF.Path & vbCrLf
  End If
Next REF
End Sub