a Guide on how to create vba script?

[hussein_atwi]

Hi,

I'm trying to build a script that takes the following off my excel sheet

• Name
• Length and width (to portrait a top view)
• Length and height (to portrait a side view)

The Idea for the script is to draw both views block them and hatch them and name the item.

I've never done it before so any type of guidance would be helpful. I have these all sorts of items from all sizes (1300+ items) that I would need to draw and considering that each item will have two views this will take me forever to accomplish without scripting.

Thanks in advance.

[Ed__Jobe]

First, you need to get a reference to the AutoCAD application. You can look at this post. Then you use the AcadApplication.Documents collection to work with drawings. Once you have a document, you can add entities to modelspace or paperspace using those object's Add*** methods, e.g. the ModelSpace.AddLine() method. Next you can search this forum for sample code.

[hussein_atwi]

Thanks @Ed__Jobe . I fondled with it all day long, eventually built a code over on excel.

code: 

Option Explicit
Sub DrawRectangles()
Dim CirObj As Object
Dim AutocadApp As Object
Dim SectionCoord(0 To 9) As Double
Dim Rectang As Object
Dim ActDoc As Object
Dim InsertP(0 To 2) As Double
Dim i As Long
Dim StartX As Double
Dim StartY As Double
Dim Spacing As Double
Dim RectCount As Long
Dim InputRange As Range
Dim InputRow As Range
Dim Name As String
Dim BlkName As String
Dim BlkObj As Object
StartX = 0
StartY = 0
Spacing = 2500
Set InputRange = ActiveSheet.Range("A2:B" & ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row) ' Change this to the range of your choice
For Each InputRow In InputRange.Rows
SectionCoord(0) = StartX: SectionCoord(1) = StartY
SectionCoord(2) = StartX + InputRow.Cells(1).Value: SectionCoord(3) = StartY
SectionCoord(4) = StartX + InputRow.Cells(1).Value: SectionCoord(5) = StartY + InputRow.Cells(2).Value
SectionCoord(6) = StartX: SectionCoord(7) = StartY + InputRow.Cells(2).Value
SectionCoord(8) = StartX: SectionCoord(9) = StartY
' Draw the rectangle and hatch it
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
Set ActDoc = AutocadApp.ActiveDocument
If ActDoc Is Nothing Then
Set ActDoc = AutocadApp.Documents.Add
End If
Set Rectang = ActDoc.ModelSpace.AddLightWeightPolyline(SectionCoord)
Rectang.Closed = True
Rectang.ConstantWidth = 0.2
Rectang.Update

Dim HatchObj As Object
Set HatchObj = ActDoc.ModelSpace.AddHatch(0, "SOLID")
HatchObj.Associative = True
HatchObj.AppendLoop acHatchLoopPolyline, SectionCoord
HatchObj.Evaluate
HatchObj.PatternScale = 0.2
HatchObj.Update
' Add a label to the rectangle
Name = InputRow.Cells(3).Value
If Name <> "" Then
InsertP(0) = StartX + InputRow.Cells(1).Value / 2
InsertP(1) = StartY + InputRow.Cells(2).Value / 2
InsertP(2) = 0 ' set Z coordinate to 0
Set CirObj = ActDoc.ModelSpace.AddText(Name, InsertP, InputRow.Cells(1).Value / 5)
CirObj.Alignment = acAlignmentCenter ' center the text horizontally
End If

' Create a block for the rectangle
BlkName = "RECTANGLE_" & RectCount
Set BlkObj = ActDoc.Blocks.Add(SectionCoord, BlkName)
BlkObj.Origin = InsertP
BlkObj.Update

' Add the rectangle to the block
Dim Ent As Object
For Each Ent In ActDoc.ModelSpace
If Ent.EntityType = acPolylines Then
Set Rectang = Ent
If Rectang.Length = 4 Then
If Rectang.Coordinates(0) = SectionCoord(0) And _
Rectang.Coordinates(1) = SectionCoord(1) And _
Rectang.Coordinates(2) = SectionCoord(2) And _
Rectang.Coordinates(3) = SectionCoord(3) And _
Rectang.Coordinates(4) = SectionCoord(4) And _
Rectang.Coordinates(5) = SectionCoord(5) And _
Rectang.Coordinates(6) = SectionCoord(6) And _
Rectang.Coordinates(7) = SectionCoord(7) And _
Rectang.Coordinates(8) = SectionCoord(8) And _
Rectang.Coordinates(9) = SectionCoord(9) Then
Set Ent = Rectang
Exit For
End If
End If
End If
Next Ent
BlkObj.AddEnt Ent
BlkObj.Update
' Add the block to the Excel sheet
Dim ObjRange As Object
Set ObjRange = ActiveSheet.Range("E" & InputRow.Row)
ObjRange.Value = BlkName
ObjRange.Hyperlinks.Add ObjRange, "", BlkName
' Clean up
Set AutocadApp = Nothing
Set ActDoc = Nothing
Set Rectang = Nothing
Set CirObj = Nothing
Set BlkObj = Nothing
RectCount = RectCount + 1

' Move to the next rectangle
StartY = StartY + InputRow.Cells(2).Value + Spacing
Next InputRow
End Sub

I have not yet been able to test it yet on my work laptop. I'll be able to when I'm back home on my own personal laptop instead. will see how it does for now.

*moderator edit* Please use the code window to post code. Use the </> button and choose Visual Basic as the format.

[Ed__Jobe]

' Draw the rectangle and hatch it
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
Set ActDoc = AutocadApp.ActiveDocument
If ActDoc Is Nothing Then
Set ActDoc = AutocadApp.Documents.Add
End If

The above code is not a good habit to get into. You should use functions for these tasks, like the ones I gave in the other post I linked to. It makes your code modular and reusable and easier to read. It also keeps the error handling where it belongs. It should look like below.

' Draw the rectangle and hatch it
  'Get acad object
Set AutocadApp = GetAcadApp()

Set ActDoc = AutocadApp.ActiveDocument
  If ActDoc Is Nothing Then
    Set ActDoc = AutocadApp.Documents.Add
  End If

[hussein_atwi]

Noted. I'll adjust it and test it tonight and tomorrow and see how it would do. Thank you.

[Ed__Jobe]

Check my previous post again. I was editing it while you posted.

[Ed__Jobe]

Also, normally, you wouldn't need to error trap a call to the ActiveDocument property, because you can't run vba in a zero document state. But if you are using ActiveX from another server (e.g. Excel), AutoCAD could open to the Start tab and the Documents.Count property would be 0. So a better solution would be to turn that into a function as well. See below.

' Draw the rectangle and hatch it
  'Get acad object
Set AutocadApp = GetAcadApp()

Set ActDoc = GetAcadDoc(AutocadApp)
'main sub continues

Public Function GetAcadDoc(app As AcadApplication) As AcadDocument
  If app.Documents.Count = 0 Then
    Set GetAcadDoc = app.Documents.Add
  Else
    Set GetAcadDoc = app.ActiveDocument
  End If
End Function

Further, in your posted code, you don't save your drawing. And you should quit AutoCAD rather than simply setting your object to nothing.

'previous edits
ActDocument.Save()
AutocadApp.Quit
Set AutocadApp = Nothing 'probably not necessary. I haven't tested.