Search
Beam Section

How to send command from Excel to draw beam section in AutoCAD ?

VBA sample code  to send command from Excel to AutoCAD to draw beam section.

Plain text
Copy to clipboard
Open code in new window
EnlighterJS 3 Syntax Highlighter
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

See beam detailing from Excel here

Sharing is caring:

Leave a Reply

Your email address will not be published. Required fields are marked *