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
How to use this program?
Watch video tutorial HERE ON YouTube