Besoin de développement sur AutoCAD ou ZWCAD ?
Avancez plus vite ! Je réalise vos projets avec vous, étape par étape, avec une assistance experte pour garantir efficacité et résultats sur mesure. Contactez-moi !

Quelques exemples de code VBA sur ZWcad et Autocad

Programme de création d’une ligne

‘Dans le code ci-dessous remplacer XXX par acad pour Autocad et zcad pour ZWcad

Option Explicit

'Création d'une structure pour la ligne (non exhaustive)
Type typeLine
    startPt(0 To 2) As Double 'Coordonnées X,Y,Z du 1er point
    endPt(0 To 2) As Double 'Coordonnées X,Y,Z du 2ème point
    calque As String 'Nom du calque
    color As Long 'Code couleur
    lineType As String 'Nom du type de ligne
End Type

'Programme principal
Sub monProgramme()

    'Déclaration des variables
    Dim line As typeLine
    Dim objLine As XXXLine

   'Votre code

   'Initialisation des paramètres de la ligne
   line.startPt(0) = 0
   line.startPt(1) = 0
   line.startPt(2) = 0
   line.endPt(0) = 100
   line.endPt(1) = 0
   line.endPt(2) = 0
   line.color = 5 'Négatif si non traité
   line.calque = "0" 'Vide si non traité
   line.lineType = "Continuous" 'Vide si non traité

   'Création de la ligne
   Set objLine = createLinePt2D(line)

   'Suite du programme

'Libérer mémoire
Set objLine = Nothing

End Sub

'Création de la ligne
Function createLinePt2D(line As typeLine) As XXXLine

    'Déclaration des variables
    Dim objLine As XXXLine
    Dim objLayer As XXXLayer

    'Test si calque existe
    If testCalqueExist(line.calque, objLayer) = False Then
        Set createLinePt2D = Nothing
        Exit Function
    End If

    'Création de la ligne dans l'espace model
    Set objLine = ThisDrawing.ModelSpace.AddLine(line.startPt,line.endPt)
    'Test si ligne correctement créée
    If Not objLine Is Nothing Then
        Set createLinePt2D = objLine
    
        objLine.Layer = line.calque
       
        On Error Resume Next
            If line.color > -1 Then
                objLine.color = line.color
            End If
            If line.lineType <> "" Then
                objLine.lineType = line.lineType
            End If
            If Err <> 0 Then
                MsgBox "Erreur color/type de ligne", vbInformation, "Erreur"
                Err.Clear
            End If
        On Error GoTo 0
    Else
        Set createLinePt2D = Nothing
    End If

    'Libère la mémoire
    Set objLayer = Nothing
    Set objLine = Nothing

End Function

'Test éxistance calque
Function testCalqueExist(calque As String, objLayer As XXXLayer) As Boolean

    testCalqueExist = True

    If calque <> "" Then
        On Error Resume Next
            Set objLayer = ThisDrawing.Layers(calque)
            If Err <> 0 Then
                Err.Clear
                testCalqueExist = False
            End If
        On Error GoTo 0
    Else
        Set objLayer = Nothing
    End If

End Function

Programme de mise à jour d’attributs sur un bloc

‘Dans le code ci-dessous remplacer XXX par acad pour Autocad et zcad pour ZWcad

Option Explicit

'Structure tableau de valeurs
type typeAttr
    nom as string
    value as variant
end type

'Exemple mise à jour d'une liste d'attribut
sub testMajAttr()
dim tabVar() as typeAttr
dim objBlk as XXXBlockReference
Dim p1 As Variant
	
     'Digitaliser le bloc
     ThisDrawing.Utility.GetEntity objBlk, p1, "Digitaliser un bloc"
	
     if not objblk is nothing then

	redim tabvar(3)
	tabVar(0).nom = "REF"
	tabVar(0).value = "Réf 12356"
	tabVar(1).nom = "QTE"
	tabVar(1).value = 125
	tabVar(2).nom = "PRIX"
	tabVar(2).value = 12.58
	tabVar(3).nom = "FOURNISSEUR"
	tabVar(3).value = "VW"
		
	majAllAttributs objBlk, tabVar
    endif

    'Libère la mémoire
    erase tabVar
    set objBlk = nothing
	
end sub

'Mise à jour de tous les attributs sur un bloc référence
'par rapport à un tableau initialisé auparavant
Function majAllAttributs(objBlk As XXXBlockReference, tabVar() as typeAttr) As Boolean
Dim objAttribut As Variant
Dim objAttributs As Variant
Dim attr As String
Dim i As Integer

    If objBlk.HasAttributes Then

        objAttributs = objBlk.GetAttributes
        For Each objAttribut In objAttributs
        
            attr = objAttribut.TagString
            
            For i = 0 To ubound(tabVar)
            
                If StrComp(attr, tabVar(i).nom, vbTextCompare) = 0 Then
                    objAttribut.TextString = tabVar(i).value
                    Exit For
                End If
                
            Next i

        Next objAttribut
        
    End If
    
End Function

Besoin de développement sur AutoCAD ou ZWCAD ?
Avancez plus vite ! Je réalise vos projets avec vous, étape par étape, avec une assistance experte pour garantir efficacité et résultats sur mesure. Contactez-moi !