22 | 02 | 2017

Draw Beams and get Parts List with Lengths

In a lot of industries extrusions are used. For instance the branches that fabricate Window Frames, they use many of the same profiles with different dimensions. With the help of VBA we are going to create a program that can draw 3d and faked extrusions and on top of that a routine that can get the type and the length of the beam. 


To create a beam or extrusion effect we first have to start of with creating base block. Create three random block objects with a thickness of 1 mm. In this tutorial we used three squares with different dimentions called Beam 45x45; Beam 45x90 and Beam 90x90. And these are saves at C:\

'One of the blocks used in this tutorial (Beam 45x90)'

This 1mm thick block will be the base of the beam. To create the impression of a extruded beam we will use the Z scale to add length to the object.

 After creating the blocks open up a new project and create a userform called FRMBeam. Add controls like the image below. 


'Impression of FRMBeam'

Add following code to the form:

Private Sub CMBgetbeam_Click()
'*** Code from VisibleVisual.com ********
End Sub
Private Sub CMBinsert_Click()
On Error Resume Next
If OPTbeam1 = True Then
insertBlock "C:\Beam 45x45.dwg"
ElseIf OPTbeam2 = True Then
insertBlock "C:\Beam 45x90.dwg"
ElseIf OPTbeam3 = True Then
insertBlock "C:\Beam 90x90.dwg"
End If
End Sub
Sub insertBlock(ByVal dwgname As String)
On Error Resume Next
    Dim blockRefObj As AcadBlockReference
    Dim pnt, pnt2 As Variant
    Dim prompt1, prompt2 As String
    ThisDrawing.ActiveSpace = acModelSpace
    'Ask user for insert point
    prompt1 = vbCrLf & "Enter block insert point: "
    pnt = ThisDrawing.Utility.GetPoint(, prompt1)
    'Insert block at specified point
    Set blockRefObj = ThisDrawing.ModelSpace.insertBlock(pnt, dwgname, 1#, 1#, 1#, 0)
    'Ask user for rotation angle
    rotation = ThisDrawing.Utility.GetAngle(pnt, "Select Rotation Angle:")
    If Err Then rotation = 0
    blockRefObj.Rotate pnt, rotation
    'Ask user for extrusion length
    pnt2 = ThisDrawing.Utility.GetPoint(pnt, "Select end point or enter length (mm):")
    'Give the block length by changing the Z scale of the block.
    blockRefObj.ZScaleFactor = Distance(pnt, pnt2)
Exit Sub
End Sub
Function Distance(Point1, Point2) As Double
'This function is used to get  the distance between two points
Dim dist As Double
On Error Resume Next
For I = LBound(Point1) To UBound(Point1)
dist = dist + ((Point1(I) - Point2(I)) ^ 2)
If Err Then Exit For
Distance = Sqr(dist)
End Function

'The code above makes creation of beams easy but there is another benefit. We can create a parts list including extrusion lengths.
'To do so create a new userform called FRMcount and add a listview with three columns called List1.

 Add the following code to this form


Private Sub UserForm_Initialize()

'on startup code blockcount
End Sub
Public Sub blockcount()
Dim objAcEnt As AcadEntity
Dim objblock As AcadBlock
'first clear the listview
For Each objAcEnt In ThisDrawing.ModelSpace
If TypeOf objAcEnt Is AcadBlockReference Then
With List1
    Length = 0
    'Check is block has a Z scale factor and make it positive
    If objAcEnt.ZScaleFactor < -1 Then Length = Round(-objAcEnt.ZScaleFactor, 1)
    If objAcEnt.ZScaleFactor > 1 Then Length = Round(objAcEnt.ZScaleFactor, 1)
        If .ListCount = 0 Then
        .AddItem objAcEnt.Name
        .List(I, 1) = 1
        .List(I, 2) = Round(Length, 0)
         For I = 0 To .ListCount - 1
            'Search if block exist and if so if the length is the same
            If .List(I, 0) = objAcEnt.Name Then
            Length1 = Round(.List(I, 2), 0)
            Length2 = Round(Length, 0)
            If Length1 = Length2 Then
                If .List(I, 1) > 0 Then
                .List(I, 1) = .List(I, 1) + 1
                GoTo volgende
                End If
            ElseIf Length = 0 Then
                If .List(I, 1) > 0 Then
                .List(I, 1) = .List(I, 1) + 1
                GoTo volgende
                End If
            End If
            End If
         Next I
        .AddItem objAcEnt.Name
        .List(I, 1) = 1
        If Length = 0 Then
        .List(I, 2) = Round(Length, 0)
        End If
        End If
End With
End If
End Sub

 Now that this code is done use the FRMbeam form to create a small construction as shown below

"The result from the code above"

Now hit the get beams button on the FRMbeams form and the following window will pop up showing all blocks and extrusions.

Download AutoCad all files used in this tutorial below (registered users only):


Sign up now and upload your code to the website.

Help us to continue.....
Articles View Hits
Latest Articles