Scribd
Upload
26 views

1

This VBA code launches AutoCAD and draws a reinforced concrete section plan by: 1) Reading coordinates from an Excel sheet to define the outline geometry. 2) Drawing the outline as a lightweight polyline. 3) Adding rebar based on parameters in the Excel sheet, including bottom, top and mid-level rebar. 4) Placing rebar using circles and hatched regions for visual representation. 5) Centering and scaling the drawing when complete.

Uploaded by

rajesh
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
26 views

1

This VBA code launches AutoCAD and draws a reinforced concrete section plan by: 1) Reading coordinates from an Excel sheet to define the outline geometry. 2) Drawing the outline as a lightweight polyline. 3) Adding rebar based on parameters in the Excel sheet, including bottom, top and mid-level rebar. 4) Placing rebar using circles and hatched regions for visual representation. 5) Centering and scaling the drawing when complete.

Uploaded by

rajesh
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 4

Option Explicit

Sub DrawPlan()

'****** Launch Autocad application****


Dim AutocadApp As Object
Dim ActDoc As Object

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****
Dim SectionCoord(0 To 9) As Double
''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****
Dim Rectang As Object
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)

' offset
Dim OffsetRect As Variant
Dim Cover As Integer
Dim Stirrup As Object
Cover = ActiveSheet.Range("f14")

OffsetRect = Rectang.Offset(-Cover)
Set Stirrup = OffsetRect(0)
Stirrup.constantwidth = 5
Stirrup.Color = acGreen

'comman

Dim CirObj As Object


Dim FilledCir As Object
Dim Spacing As Double
Dim i As Integer
Dim centerCircle(2) As Double

''***Bottom rebar*****
Dim BottomBar As Integer
Dim Nbrbotbar As Integer
Dim Botsize As Integer
Dim Marray(0) As Object
Nbrbotbar = ActiveSheet.Range("f10")
Botsize = ActiveSheet.Range("f11")

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*****
Dim Topbar As Integer
Dim Nbrtopbar As Integer
Dim Topsize As Integer
Nbrtopbar = ActiveSheet.Range("f8")
Topsize = ActiveSheet.Range("f9")

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

'Midbar
Dim midbar As Integer
Dim Midsize As Integer
midbar = ActiveSheet.Range("f12")
Midsize = ActiveSheet.Range("f13")

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

MsgBox ("plot to Autocad")

End Sub

You might also like