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.

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 *