How to adapt the VBA code given in the HELP AutoCAD for Excel macros

 ;;;;;;;;;;;;;;;;;;;;  Description ;;;;;;;;;;;;;;;;;
When you want to adapt a code given in the Help section of AutoCAD for excel macro purposes.
Here under an extract of a code from the tremendous " AutoCAD Help" for VBA developper.

Thus, you just have to replace in the original code : Thisdrawing by a local variable as follows :



Dim AcadApp As AcadApplication
Dim AcadDoc As Variant
Set AcadApp = GetObject(, "AutoCAD.Application.17")
Set AcadDoc = AcadApp.Application.ActiveDocument

Modify the Attributes values with VBA or insert a block with attributes in AutoCAD

 ;;;;;;;;;;;;;;;;;;;;  Description ;;;;;;;;;;;;;;;;;
Here under an implementation of GetAttributes method in order to :
- Modify the Attributes values with VBA
- Insert a block with attributes in AutoCAD

.TagString = attribute name
.TextString = attribute value
varAttributes(0) -> first attribute defined in the block
varAttributes(1) -> second attribute defined in the block

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Dim blockRefObj2 As AcadBlockReference
    insertionPnt(0) = Range("F19")
    insertionPnt(1) = Range("F20")
    insertionPnt(2) = 0
    Set blockRefObj2 = AcadDoc.ModelSpace.InsertBlock _
               (insertionPnt, "MANHOLE", 1#, 1#, 1#, 0)
   
    Dim varAttributes As Variant
    varAttributes = blockRefObj2.GetAttributes
    varAttributes(0).TextString = "200"
    varAttributes(1).TextString = "20"

Get Started with AutoLISP and VBA in AutoCAD

Don't hesitate to go to the "Help" section in AutoCAD because you'll find a tremendous quantity of information and examples on how to implement your code or just to solve syntax code issues.
Sometimes, you'll save time in searching your information in the AutoCAD Help section than going to the messy Internet.

Add a block with attributes in AutoCAD with an Excel macro VBA

Description :
This macro creates a block with attributes (one of them is invisible to the user : "mode = acAttributeModeInvisible").
Here, I've created a manhole block but you can add and change each parameters to see their respective influence on the drawing.

Don't forget :
if you launch this macro many time with the same insertion point, you'll get nested block with repetitive attributes.
'------------------------ THE VBA CODE ------------------------------------
Sub MANHOLEBLOCK()

On Error Resume Next
 With ThisWorkbook.VBProject.References
 Application.DisplayAlerts = False
 .AddFromFile "C:\Program Files\Common Files\Autodesk Shared\acax17fra.tlb"
 End With
 Application.DisplayAlerts = True
 On Error GoTo 0
 '..la suite


Dim AcadApp As AcadApplication
Dim AcadDoc As AcadDocument

On Error Resume Next

Set AcadApp = GetObject(, "AutoCAD.Application.17")
If Err Then
Err.Clear
Set AcadApp = CreateObject("AutoCAD.Application.17")
End If

MsgBox "Now running! : " + AcadApp.Name + " version :" + AcadApp.Version

Set AcadDoc = AcadApp.Application.ActiveDocument

AcadDoc.Regen acActiveViewport
ZoomAll
AcadApp.Application.Visible = True



    ' Define the block
    Dim blockObj As AcadBlock
    Dim insertionPnt(0 To 2) As Double
    insertionPnt(0) = 0
    insertionPnt(1) = 0
    insertionPnt(2) = 0
    Set blockObj = AcadDoc.Blocks.Add _
                     (insertionPnt, "MANHOLE")

    ' Add an attribute to the block
    Dim attributeObj1 As AcadAttribute
    Dim height1 As Double
    Dim mode1 As Long
    Dim prompt1 As String
    Dim insertionPoint1(0 To 2) As Double
    Dim tag1 As String
    Dim value1 As String
    height1 = 1
    mode1 = acAttributeModeVerify
    prompt1 = "Give plateform Level "
    insertionPoint1(0) = 3
    insertionPoint1(1) = 3
    insertionPoint1(2) = 0
    tag1 = "fil d'eau 1"
    value1 = Range("G16")
    Set attributeObj1 = blockObj.AddAttribute(height1, mode1, _
                          prompt1, insertionPoint1, tag1, value1)
                        
                        
    ' Add an attribute to the block
    Dim attributeObj As AcadAttribute
    Dim height As Double
    Dim mode As Long
    Dim prompt As String
    Dim insertionPoint(0 To 2) As Double
    Dim tag As String
    Dim value As String
    height = 1
    mode = acAttributeModeInvisible
    prompt = "Give invert Level 2"
    insertionPoint(0) = -2
    insertionPoint(1) = 3
    insertionPoint(2) = 0
    tag = "fil d'eau 2"
    value = Range("h16")
    Set attributeObj = blockObj.AddAttribute(height, mode, _
                          prompt, insertionPoint, tag, value)
    ' Insert the block, creating a block reference
    ' and an attribute reference
    Dim blockRefObj As AcadBlockReference
    insertionPnt(0) = 2
    insertionPnt(1) = 2
    insertionPnt(2) = 0
    Set blockRefObj = AcadDoc.ModelSpace.InsertBlock _
               (insertionPnt, "MANHOLE", 1#, 1#, 1#, 0)

End Sub

Problems with VBA References in Excel

Sometimes you can encounter problems with the references for AutoCAD.
If they're not loaded into Excel your code won't work.
So in the "Microsoft Visual Basic Editor" go to -> Tools -> Reference -> and select as above the AutoCAD libraries

Drawings from Excel to AutoCAD with VBA macro, e.g. : Retaining wall sectional elevation

;;;;;;;;;;; Description ;;;;;;;;;;;;;;;
This macro to be inserted into a module and parametrized with your own values (range(x)) (it works only in AutoCAD 2008 but can be easily changed).

This macro to be inserted into a module and parametrized with your own values.
This macro combines many VBA functions to draw in AutoCAD a retaining wall section.
It's up to you to imagine all possibilities that it opens.
The code is free of use and to be extended as you wish.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

'MACRO REALIZED BY DDM 

Sub CUTWALLtoCAD()

On Error Resume Next
 With ThisWorkbook.VBProject.References
 Application.DisplayAlerts = False
 .AddFromFile "C:\Program Files\Common Files\Autodesk Shared\acax17fra.tlb"
 End With
 Application.DisplayAlerts = True
 On Error GoTo 0



Dim AcadApp As AcadApplication

On Error Resume Next

Set AcadApp = GetObject(, "AutoCAD.Application.17")
If Err Then
Err.Clear
Set AcadApp = CreateObject("AutoCAD.Application.17")
End If

MsgBox "Now running! : " + AcadApp.Name + " version :" + AcadApp.Version

Set AcadDoc = AcadApp.Application.ActiveDocument

AcadDoc.Regen acActiveViewport
ZoomAll
AcadApp.Application.Visible = True



'-------------------- TO DRAW WALL OUTLINE -------------
Dim getcenter As Variant
Dim plineObj As AcadPolyline
Dim points(0 To 26) As Double

getcenter = AcadDoc.Utility.GetPoint(, "Insertion Point ?")

   
    ' Define the 2D polyline points
    points(0) = getcenter(0): points(1) = getcenter(1): points(2) = getcenter(2)
    points(3) = points(0): points(4) = points(1) + Range("C13"): points(5) = 0
    points(6) = points(3) - Range("C15"): points(7) = points(4): points(8) = 0
    points(9) = points(6): points(10) = points(7) + Range("C17"): points(11) = 0
    points(12) = points(9) - Range("C14"): points(13) = points(10): points(14) = 0
    points(15) = points(12): points(16) = points(13) - Range("C17"): points(17) = 0
    points(18) = points(0) - Range("c16"): points(19) = points(1) + Range("C13"): points(20) = 0
    points(21) = points(0) - Range("c16"): points(22) = points(1): points(23) = 0
    points(24) = points(0): points(25) = points(1): points(26) = 0
    ' Create a lightweight Polyline object in model space
    Set plineObj = AcadDoc.ModelSpace.AddPolyline(points)
    plineObj.Closed = True
    plineObj.Update
   
   
'-------------------- -------------
    Dim plineterre1Obj As AcadPolyline
    Dim pts_terre1(0 To 5) As Double
   
       ' Define the 2D polyline points
pts_terre1(0) = points(6): pts_terre1(1) = points(7) + Range("C19"): pts_terre1(2) = 0
pts_terre1(3) = points(0) + 500: pts_terre1(4) = pts_terre1(1): pts_terre1(5) = 0

Set plineterre1Obj = AcadDoc.ModelSpace.AddPolyline(pts_terre1)


 Dim plineterre2Obj As AcadPolyline
    Dim pts_terre2(0 To 5) As Double
   
       ' Define the 2D polyline points
pts_terre2(0) = points(15): pts_terre2(1) = points(7) + Range("C18"): pts_terre2(2) = 0
pts_terre2(3) = points(18) - 500: pts_terre2(4) = pts_terre2(1): pts_terre2(5) = 0

Set plineterre2Obj = AcadDoc.ModelSpace.AddPolyline(pts_terre2)


Dim plineterre3Obj As AcadPolyline
Dim pts_terre3(0 To 11) As Double
   
pts_terre3(0) = pts_terre1(0): pts_terre3(1) = pts_terre1(1): pts_terre3(2) = 0
pts_terre3(3) = pts_terre1(3): pts_terre3(4) = pts_terre1(4): pts_terre3(5) = 0
pts_terre3(6) = pts_terre3(3): pts_terre3(7) = pts_terre3(4) - 150: pts_terre3(8) = 0
pts_terre3(9) = pts_terre3(0): pts_terre3(10) = pts_terre3(1) - 150: pts_terre3(11) = 0

Set plineterre3Obj = AcadDoc.ModelSpace.AddPolyline(pts_terre3)
plineterre3Obj.Closed = True
plineterre3Obj.Visible = False


Dim plineterre4Obj As AcadPolyline
Dim pts_terre4(0 To 11) As Double

       ' Define the 2D polyline pts_terre4 pour la réalisation des hachures
pts_terre4(0) = pts_terre2(0): pts_terre4(1) = pts_terre2(1): pts_terre4(2) = 0 '1er point des terres sur patin avant
pts_terre4(3) = pts_terre2(3): pts_terre4(4) = pts_terre2(4): pts_terre3(5) = 0
pts_terre4(6) = pts_terre4(3): pts_terre4(7) = pts_terre4(4) - 150: pts_terre4(8) = 0
pts_terre4(9) = pts_terre4(0): pts_terre4(10) = pts_terre4(1) - 150: pts_terre4(11) = 0

Set plineterre4Obj = AcadDoc.ModelSpace.AddPolyline(pts_terre4)
plineterre4Obj.Closed = True
plineterre4Obj.Visible = False


 '-------------------- -------------
    Dim hatchObj As AcadHatch
    Dim hatchObj1 As AcadHatch
    ' Create the outer boundary for the hatch. (a circle)
    Dim outerLoop(0 To 0) As AcadEntity
    Dim outerLoop1(0 To 0) As AcadEntity
       
    Set outerLoop(0) = plineterre3Obj
    Set outerLoop1(0) = plineterre4Obj
   
     'Create the associative Hatch object in model space
    Set hatchObj = AcadDoc.ModelSpace.AddHatch(acHatchPatternTypePreDefined, "EARTH", True)
    Set hatchObj1 = AcadDoc.ModelSpace.AddHatch(acHatchPatternTypePreDefined, "EARTH", True)
       
    ' Append the outerboundary to the hatch object, and display the hatch
    hatchObj.PatternScale = 10
    hatchObj.AppendOuterLoop (outerLoop)
    hatchObj.Evaluate
   
    hatchObj1.PatternScale = 10
    hatchObj1.AppendOuterLoop (outerLoop1)
    hatchObj1.Evaluate
   
    AcadDoc.Regen acActiveViewport
    ZoomAll
    AcadApp.Application.Visible = True

End Sub

AutoLISP Code : Write a text

;;; Function: writext ;
;;;--------------------------------------------------------------------;
;;; Description: This function writes and creates the text chosen ;
;;; ;
;;;------------------------------------------------------------------- ;

(defun writext (POINT H title / SYS)
(setq SYS (getvar "dtexted"))
(command "setvar" "dtexted" "1")
(command "_text" "j" "m" POINT H "0" title)
(command "SETVAR" "DTEXTED" SYS)
)