May 22, 2021
Following a comment on my YouTube channel requesting a tutorial on how to draw a circular column section in AutoCAD from Excel, I decided to write and share the below program.
VBA simple code to draw circular column section in AutoCAD using excel VBA.
Option Explicit
Const PI = 3.14159265358979
Sub DrawRectange()
Dim AutocadApp As Object
Dim Cover As Integer
Dim Column As Object
Dim ActDoc As Object
Dim CirObj As Object
Dim Nbrbar As Integer
Dim FilledCir As Object
Dim Marray(0) As Object
Dim OffsetRect As Variant
Dim rebarsectionPos As Variant
Dim Stirrup As Object
Dim ColumnCenter As Variant
Dim ColumnDiameter As Double
Dim Barsize As Double
Dim i As Integer
'****** Launch Autocad application****
On Error Resume Next
Set AutocadApp = GetObject(, "Autocad.application")
On Error GoTo 0
If AutocadApp Is Nothing Then
Set AutocadApp = CreateObject("Autocad.application")
AutocadApp.Visible = True
End If
''****Read Input****
ColumnDiameter = ActiveSheet.Range("f5")
Cover = ActiveSheet.Range("f6")
Nbrbar = ActiveSheet.Range("f8")
Barsize = ActiveSheet.Range("f9")
''****Draw rectangle****
On Error Resume Next
Set ActDoc = AutocadApp.ActiveDocument
On Error GoTo 0
If ActDoc Is Nothing Then
Set ActDoc = AutocadApp.Documents.Add
End If
On Error Resume Next
ColumnCenter = ActDoc.Utility.GetPoint(, "Select the position of column.")
Set Column = ActDoc.modelspace.AddCircle(ColumnCenter, ColumnDiameter / 2)
OffsetRect = Column.Offset(-Cover)
Set Stirrup = OffsetRect(0)
Stirrup.constantwidth = 5
''Add rebar section
Dim angle As Double
angle = 0
For i = 1 To Nbrbar
rebarsectionPos = ActDoc.Utility.PolarPoint(ColumnCenter, angle, (ColumnDiameter / 2 - Barsize / 2 - Cover))
Set CirObj = ActDoc.modelspace.AddCircle(rebarsectionPos, Barsize / 2)
CirObj.Color = acRed
''filled rebar section
Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True)
Set Marray(0) = CirObj
With FilledCir
.appendouterloop (Marray)
.Evaluate
.Color = acRed
.Update
End With
angle = angle + (2 * PI) / Nbrbar
Next i
AutocadApp.ZoomExtents
Set AutocadApp = Nothing
Set ActDoc = Nothing
Set CirObj = Nothing
Set Marray(0) = Nothing
Set FilledCir = Nothing
End Sub
Option Explicit
Const PI = 3.14159265358979
Sub DrawRectange()
Dim AutocadApp As Object
Dim Cover As Integer
Dim Column As Object
Dim ActDoc As Object
Dim CirObj As Object
Dim Nbrbar As Integer
Dim FilledCir As Object
Dim Marray(0) As Object
Dim OffsetRect As Variant
Dim rebarsectionPos As Variant
Dim Stirrup As Object
Dim ColumnCenter As Variant
Dim ColumnDiameter As Double
Dim Barsize As Double
Dim i As Integer
'****** Launch Autocad application****
On Error Resume Next
Set AutocadApp = GetObject(, "Autocad.application")
On Error GoTo 0
If AutocadApp Is Nothing Then
Set AutocadApp = CreateObject("Autocad.application")
AutocadApp.Visible = True
End If
''****Read Input****
ColumnDiameter = ActiveSheet.Range("f5")
Cover = ActiveSheet.Range("f6")
Nbrbar = ActiveSheet.Range("f8")
Barsize = ActiveSheet.Range("f9")
''****Draw rectangle****
On Error Resume Next
Set ActDoc = AutocadApp.ActiveDocument
On Error GoTo 0
If ActDoc Is Nothing Then
Set ActDoc = AutocadApp.Documents.Add
End If
On Error Resume Next
ColumnCenter = ActDoc.Utility.GetPoint(, "Select the position of column.")
Set Column = ActDoc.modelspace.AddCircle(ColumnCenter, ColumnDiameter / 2)
OffsetRect = Column.Offset(-Cover)
Set Stirrup = OffsetRect(0)
Stirrup.constantwidth = 5
''Add rebar section
Dim angle As Double
angle = 0
For i = 1 To Nbrbar
rebarsectionPos = ActDoc.Utility.PolarPoint(ColumnCenter, angle, (ColumnDiameter / 2 - Barsize / 2 - Cover))
Set CirObj = ActDoc.modelspace.AddCircle(rebarsectionPos, Barsize / 2)
CirObj.Color = acRed
''filled rebar section
Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True)
Set Marray(0) = CirObj
With FilledCir
.appendouterloop (Marray)
.Evaluate
.Color = acRed
.Update
End With
angle = angle + (2 * PI) / Nbrbar
Next i
AutocadApp.ZoomExtents
Set AutocadApp = Nothing
Set ActDoc = Nothing
Set CirObj = Nothing
Set Marray(0) = Nothing
Set FilledCir = Nothing
End Sub
Option Explicit Const PI = 3.14159265358979 Sub DrawRectange() Dim AutocadApp As Object Dim Cover As Integer Dim Column As Object Dim ActDoc As Object Dim CirObj As Object Dim Nbrbar As Integer Dim FilledCir As Object Dim Marray(0) As Object Dim OffsetRect As Variant Dim rebarsectionPos As Variant Dim Stirrup As Object Dim ColumnCenter As Variant Dim ColumnDiameter As Double Dim Barsize As Double Dim i As Integer '****** Launch Autocad application**** On Error Resume Next Set AutocadApp = GetObject(, "Autocad.application") On Error GoTo 0 If AutocadApp Is Nothing Then Set AutocadApp = CreateObject("Autocad.application") AutocadApp.Visible = True End If ''****Read Input**** ColumnDiameter = ActiveSheet.Range("f5") Cover = ActiveSheet.Range("f6") Nbrbar = ActiveSheet.Range("f8") Barsize = ActiveSheet.Range("f9") ''****Draw rectangle**** On Error Resume Next Set ActDoc = AutocadApp.ActiveDocument On Error GoTo 0 If ActDoc Is Nothing Then Set ActDoc = AutocadApp.Documents.Add End If On Error Resume Next ColumnCenter = ActDoc.Utility.GetPoint(, "Select the position of column.") Set Column = ActDoc.modelspace.AddCircle(ColumnCenter, ColumnDiameter / 2) OffsetRect = Column.Offset(-Cover) Set Stirrup = OffsetRect(0) Stirrup.constantwidth = 5 ''Add rebar section Dim angle As Double angle = 0 For i = 1 To Nbrbar rebarsectionPos = ActDoc.Utility.PolarPoint(ColumnCenter, angle, (ColumnDiameter / 2 - Barsize / 2 - Cover)) Set CirObj = ActDoc.modelspace.AddCircle(rebarsectionPos, Barsize / 2) CirObj.Color = acRed ''filled rebar section Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True) Set Marray(0) = CirObj With FilledCir .appendouterloop (Marray) .Evaluate .Color = acRed .Update End With angle = angle + (2 * PI) / Nbrbar Next i AutocadApp.ZoomExtents Set AutocadApp = Nothing Set ActDoc = Nothing Set CirObj = Nothing Set Marray(0) = Nothing Set FilledCir = Nothing End Sub
How to use this program?
Watch video tutorial HERE ON YouTube
- Version 1.0.0
- Download 27329
- File Size 22 KB
- File Count 1
- Create Date May 22, 2021
- Last Updated June 4, 2021
File | Action |
---|---|
Draw Circular column section.zip | Download |
If you believe my tools are helping you and would like to support me, please use the below button to donate.
.
thank you
Hi Maadh,
You are Welcome.
You have observed very interesting details! ps decent site.
I found your blog website on google and check a couple of of your early posts. Proceed to keep up the excellent operate. I just extra up your RSS feed to my MSN News Reader. Looking for forward to studying more from you afterward!…