VBA sample code to send command from Excel to AutoCAD to draw beam section.
Option Explicit
Sub DrawRectange()
Dim AutocadApp As Object
Dim SectionCoord(0 To 9) As Double
Dim Topbar As Integer
Dim BottomBar As Integer
Dim Cover As Integer
Dim Rectang As Object
Dim ActDoc As Object
Dim CirObj As Object
Dim Nbrtopbar As Integer
Dim Nbrbotbar As Integer
Dim Topsize As Integer
Dim Botsize As Integer
Dim midbar As Integer
Dim Midsize As Integer
Dim FilledCir As Object
Dim Marray(0) As Object
Dim OffsetRect As Variant
Dim Stirrup As Object
Dim Spacing As Double
Dim i As Integer
Dim centerCircle(2) As Double
'****** 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****
''Point 1
SectionCoord(0) = 0: SectionCoord(1) = 0
''Point 2
SectionCoord(2) = ActiveSheet.Range("f5").Value: SectionCoord(3) = 0
''Point 3
SectionCoord(4) = ActiveSheet.Range("f5").Value: SectionCoord(5) = ActiveSheet.Range("f6").Value
''Point 4
SectionCoord(6) = 0: SectionCoord(7) = ActiveSheet.Range("f6").Value
''Point 1 again to close the polyline
SectionCoord(8) = 0: SectionCoord(9) = 0
''****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
Set Rectang = ActDoc.modelspace.AddLightWeightPolyline(SectionCoord)
Cover = ActiveSheet.Range("f14")
Nbrtopbar = ActiveSheet.Range("f8")
Nbrbotbar = ActiveSheet.Range("f10")
Topsize = ActiveSheet.Range("f9")
Botsize = ActiveSheet.Range("f11")
midbar = ActiveSheet.Range("f12")
Midsize = ActiveSheet.Range("f13")
OffsetRect = Rectang.Offset(-Cover)
Set Stirrup = OffsetRect(0)
Stirrup.constantwidth = 5
''***Bottom rebar*****
Spacing = (ActiveSheet.Range("F5") - 2 * Cover - Botsize - 10) / (Nbrbotbar - 1)
For i = 1 To Nbrbotbar
If i = 1 Then
centerCircle(0) = (Cover + Botsize / 2 + 5): centerCircle(1) = (Cover + Botsize / 2 + 5)
Else
centerCircle(0) = (Cover + Botsize / 2 + 5 + Spacing * (i - 1)): centerCircle(1) = (Cover + Botsize / 2 + 5)
End If
Set CirObj = ActDoc.modelspace.addcircle(centerCircle, Botsize / 2)
CirObj.Color = acRed
Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True)
Set Marray(0) = CirObj
With FilledCir
.appendouterloop (Marray)
.Evaluate
.Color = acRed
.Update
End With
Next i
''***Top rebar*****
Spacing = (ActiveSheet.Range("F5") - 2 * Cover - Topsize - 10) / (Nbrtopbar - 1)
For i = 1 To Nbrtopbar
If i = 1 Then
centerCircle(0) = (Cover + Topsize / 2 + 5): centerCircle(1) = (ActiveSheet.Range("F6") - Cover - Botsize / 2 - 5)
Else
centerCircle(0) = (Cover + Topsize / 2 + 5 + Spacing * (i - 1)): centerCircle(1) = (ActiveSheet.Range("F6") - Cover - Topsize / 2 - 5)
End If
Set CirObj = ActDoc.modelspace.addcircle(centerCircle, Topsize / 2)
CirObj.Color = acRed
Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True)
Set Marray(0) = CirObj
With FilledCir
.appendouterloop (Marray)
.Evaluate
.Color = acRed
.Update
End With
Next i
If midbar <> 0 And midbar = 2 Then
centerCircle(0) = (Cover + Midsize / 2 + 5): centerCircle(1) = (ActiveSheet.Range("F6") / 2)
Set CirObj = ActDoc.modelspace.addcircle(centerCircle, Midsize / 2)
CirObj.Color = acRed
Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True)
Set Marray(0) = CirObj
With FilledCir
.appendouterloop (Marray)
.Evaluate
.Color = acRed
.Update
End With
centerCircle(0) = (Cover + Midsize / 2 + ActiveSheet.Range("F5") - 2 * Cover - Midsize - 5): centerCircle(1) = (ActiveSheet.Range("F6") / 2)
Set CirObj = ActDoc.modelspace.addcircle(centerCircle, Midsize / 2)
CirObj.Color = acRed
Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True)
Set Marray(0) = CirObj
With FilledCir
.appendouterloop (Marray)
.Evaluate
.Color = acRed
.Update
End With
End If
AutocadApp.ZoomExtents
Set AutocadApp = Nothing
Set ActDoc = Nothing
Set Rectang = Nothing
Set CirObj = Nothing
Set Marray(0) = Nothing
Set FilledCir = Nothing
End Sub
Option Explicit
Sub DrawRectange()
Dim AutocadApp As Object
Dim SectionCoord(0 To 9) As Double
Dim Topbar As Integer
Dim BottomBar As Integer
Dim Cover As Integer
Dim Rectang As Object
Dim ActDoc As Object
Dim CirObj As Object
Dim Nbrtopbar As Integer
Dim Nbrbotbar As Integer
Dim Topsize As Integer
Dim Botsize As Integer
Dim midbar As Integer
Dim Midsize As Integer
Dim FilledCir As Object
Dim Marray(0) As Object
Dim OffsetRect As Variant
Dim Stirrup As Object
Dim Spacing As Double
Dim i As Integer
Dim centerCircle(2) As Double
'****** 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****
''Point 1
SectionCoord(0) = 0: SectionCoord(1) = 0
''Point 2
SectionCoord(2) = ActiveSheet.Range("f5").Value: SectionCoord(3) = 0
''Point 3
SectionCoord(4) = ActiveSheet.Range("f5").Value: SectionCoord(5) = ActiveSheet.Range("f6").Value
''Point 4
SectionCoord(6) = 0: SectionCoord(7) = ActiveSheet.Range("f6").Value
''Point 1 again to close the polyline
SectionCoord(8) = 0: SectionCoord(9) = 0
''****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
Set Rectang = ActDoc.modelspace.AddLightWeightPolyline(SectionCoord)
Cover = ActiveSheet.Range("f14")
Nbrtopbar = ActiveSheet.Range("f8")
Nbrbotbar = ActiveSheet.Range("f10")
Topsize = ActiveSheet.Range("f9")
Botsize = ActiveSheet.Range("f11")
midbar = ActiveSheet.Range("f12")
Midsize = ActiveSheet.Range("f13")
OffsetRect = Rectang.Offset(-Cover)
Set Stirrup = OffsetRect(0)
Stirrup.constantwidth = 5
''***Bottom rebar*****
Spacing = (ActiveSheet.Range("F5") - 2 * Cover - Botsize - 10) / (Nbrbotbar - 1)
For i = 1 To Nbrbotbar
If i = 1 Then
centerCircle(0) = (Cover + Botsize / 2 + 5): centerCircle(1) = (Cover + Botsize / 2 + 5)
Else
centerCircle(0) = (Cover + Botsize / 2 + 5 + Spacing * (i - 1)): centerCircle(1) = (Cover + Botsize / 2 + 5)
End If
Set CirObj = ActDoc.modelspace.addcircle(centerCircle, Botsize / 2)
CirObj.Color = acRed
Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True)
Set Marray(0) = CirObj
With FilledCir
.appendouterloop (Marray)
.Evaluate
.Color = acRed
.Update
End With
Next i
''***Top rebar*****
Spacing = (ActiveSheet.Range("F5") - 2 * Cover - Topsize - 10) / (Nbrtopbar - 1)
For i = 1 To Nbrtopbar
If i = 1 Then
centerCircle(0) = (Cover + Topsize / 2 + 5): centerCircle(1) = (ActiveSheet.Range("F6") - Cover - Botsize / 2 - 5)
Else
centerCircle(0) = (Cover + Topsize / 2 + 5 + Spacing * (i - 1)): centerCircle(1) = (ActiveSheet.Range("F6") - Cover - Topsize / 2 - 5)
End If
Set CirObj = ActDoc.modelspace.addcircle(centerCircle, Topsize / 2)
CirObj.Color = acRed
Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True)
Set Marray(0) = CirObj
With FilledCir
.appendouterloop (Marray)
.Evaluate
.Color = acRed
.Update
End With
Next i
If midbar <> 0 And midbar = 2 Then
centerCircle(0) = (Cover + Midsize / 2 + 5): centerCircle(1) = (ActiveSheet.Range("F6") / 2)
Set CirObj = ActDoc.modelspace.addcircle(centerCircle, Midsize / 2)
CirObj.Color = acRed
Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True)
Set Marray(0) = CirObj
With FilledCir
.appendouterloop (Marray)
.Evaluate
.Color = acRed
.Update
End With
centerCircle(0) = (Cover + Midsize / 2 + ActiveSheet.Range("F5") - 2 * Cover - Midsize - 5): centerCircle(1) = (ActiveSheet.Range("F6") / 2)
Set CirObj = ActDoc.modelspace.addcircle(centerCircle, Midsize / 2)
CirObj.Color = acRed
Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True)
Set Marray(0) = CirObj
With FilledCir
.appendouterloop (Marray)
.Evaluate
.Color = acRed
.Update
End With
End If
AutocadApp.ZoomExtents
Set AutocadApp = Nothing
Set ActDoc = Nothing
Set Rectang = Nothing
Set CirObj = Nothing
Set Marray(0) = Nothing
Set FilledCir = Nothing
End Sub
Option Explicit Sub DrawRectange() Dim AutocadApp As Object Dim SectionCoord(0 To 9) As Double Dim Topbar As Integer Dim BottomBar As Integer Dim Cover As Integer Dim Rectang As Object Dim ActDoc As Object Dim CirObj As Object Dim Nbrtopbar As Integer Dim Nbrbotbar As Integer Dim Topsize As Integer Dim Botsize As Integer Dim midbar As Integer Dim Midsize As Integer Dim FilledCir As Object Dim Marray(0) As Object Dim OffsetRect As Variant Dim Stirrup As Object Dim Spacing As Double Dim i As Integer Dim centerCircle(2) As Double '****** 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**** ''Point 1 SectionCoord(0) = 0: SectionCoord(1) = 0 ''Point 2 SectionCoord(2) = ActiveSheet.Range("f5").Value: SectionCoord(3) = 0 ''Point 3 SectionCoord(4) = ActiveSheet.Range("f5").Value: SectionCoord(5) = ActiveSheet.Range("f6").Value ''Point 4 SectionCoord(6) = 0: SectionCoord(7) = ActiveSheet.Range("f6").Value ''Point 1 again to close the polyline SectionCoord(8) = 0: SectionCoord(9) = 0 ''****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 Set Rectang = ActDoc.modelspace.AddLightWeightPolyline(SectionCoord) Cover = ActiveSheet.Range("f14") Nbrtopbar = ActiveSheet.Range("f8") Nbrbotbar = ActiveSheet.Range("f10") Topsize = ActiveSheet.Range("f9") Botsize = ActiveSheet.Range("f11") midbar = ActiveSheet.Range("f12") Midsize = ActiveSheet.Range("f13") OffsetRect = Rectang.Offset(-Cover) Set Stirrup = OffsetRect(0) Stirrup.constantwidth = 5 ''***Bottom rebar***** Spacing = (ActiveSheet.Range("F5") - 2 * Cover - Botsize - 10) / (Nbrbotbar - 1) For i = 1 To Nbrbotbar If i = 1 Then centerCircle(0) = (Cover + Botsize / 2 + 5): centerCircle(1) = (Cover + Botsize / 2 + 5) Else centerCircle(0) = (Cover + Botsize / 2 + 5 + Spacing * (i - 1)): centerCircle(1) = (Cover + Botsize / 2 + 5) End If Set CirObj = ActDoc.modelspace.addcircle(centerCircle, Botsize / 2) CirObj.Color = acRed Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True) Set Marray(0) = CirObj With FilledCir .appendouterloop (Marray) .Evaluate .Color = acRed .Update End With Next i ''***Top rebar***** Spacing = (ActiveSheet.Range("F5") - 2 * Cover - Topsize - 10) / (Nbrtopbar - 1) For i = 1 To Nbrtopbar If i = 1 Then centerCircle(0) = (Cover + Topsize / 2 + 5): centerCircle(1) = (ActiveSheet.Range("F6") - Cover - Botsize / 2 - 5) Else centerCircle(0) = (Cover + Topsize / 2 + 5 + Spacing * (i - 1)): centerCircle(1) = (ActiveSheet.Range("F6") - Cover - Topsize / 2 - 5) End If Set CirObj = ActDoc.modelspace.addcircle(centerCircle, Topsize / 2) CirObj.Color = acRed Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True) Set Marray(0) = CirObj With FilledCir .appendouterloop (Marray) .Evaluate .Color = acRed .Update End With Next i If midbar <> 0 And midbar = 2 Then centerCircle(0) = (Cover + Midsize / 2 + 5): centerCircle(1) = (ActiveSheet.Range("F6") / 2) Set CirObj = ActDoc.modelspace.addcircle(centerCircle, Midsize / 2) CirObj.Color = acRed Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True) Set Marray(0) = CirObj With FilledCir .appendouterloop (Marray) .Evaluate .Color = acRed .Update End With centerCircle(0) = (Cover + Midsize / 2 + ActiveSheet.Range("F5") - 2 * Cover - Midsize - 5): centerCircle(1) = (ActiveSheet.Range("F6") / 2) Set CirObj = ActDoc.modelspace.addcircle(centerCircle, Midsize / 2) CirObj.Color = acRed Set FilledCir = ActDoc.modelspace.addhatch(acHatchPatternTypePreDefined, "Solid", True) Set Marray(0) = CirObj With FilledCir .appendouterloop (Marray) .Evaluate .Color = acRed .Update End With End If AutocadApp.ZoomExtents Set AutocadApp = Nothing Set ActDoc = Nothing Set Rectang = Nothing Set CirObj = Nothing Set Marray(0) = Nothing Set FilledCir = Nothing End Sub
How to use this program?
Watch video tutorial HERE ON YouTube