Autocad VBA Parameters -3-

A non-trivial VBA parametric project requires some structure to re-use standard techniques and a guide drawing to be made with user parameters identified that specifies the point values to be drawn. This sample project is a sheet metal frame that would be used to cap a hole. There are only two parts, top/bottom and side, but they are drawn both in front assembly and laid out flat before bending, so there are 4 basic drawing sub-routines. The drawing subroutines create geometry. Their only other job is to initialize bounding box variables so the calling program has the option to move into assembly, block, and/or rotate.

The parts are always drawn with lower left corner at or near 0,0. The master drawing is created manually before the programming is started. If carefully done, and revised until it works as needed, it will make the programming much easier.

2016-12-31_1

Give each project its own module. It solves naming issues if each project is given a simple project ID, then prefix all the subs with the ID. The draw subs are at the bottom and the controlling program at the top. The draw subs are completed first, all in a similar manner. Again it makes programming much simpler if all the controlling sketches are laid out consistently and thoroughly. The only variables passed are the user variables. Calculations are made in the drawing sub. The sketches should be consistent – variable D1 in one sketch is the same value D1 in another sketch.


Sub B1_chan_top_bent(A As Double, D As Double, E As Double)
Dim pt As Variant
Dim A1 As Double, A2 As Double
      A1 = A + D + D
      A2 = A + D

'bounding box pt_ll and pt_ur are global vars
Call initpt(pt_ll, -1, -1, 0)
Call initpt(pt_ur, A1 + 2, D + 2, 0)
   
pt = Array(0, E, D, E, D, 0, _
            A2, 0, A2, E, A1, E, _
            A1, D, 0, D)
Call draw_array(pt)

acadDoc.ActiveLayer = acadDoc.Layers.Item("Hidden")
Call line(D, E, A2, E)

'each drawing sub re-sets current layer to 0
acadDoc.ActiveLayer = acadDoc.Layers.Item("0")
Update
End Sub


Sub B1_chan_side_bent(B As Double, D As Double, E As Double)
Dim pt As Variant
Dim B1 As Double
B1 = B + E + E

'bounding box
  Call initpt(pt_ll, -1, -1, 0)
  Call initpt(pt_ur, B1 + 2, D + 2, 0)

pt = Array(0, 0, B1, 0, B1, D, 0, D)
Call draw_array(pt)

acadDoc.ActiveLayer = acadDoc.Layers.Item("Hidden")
Call line(0, E, B1, E)

acadDoc.ActiveLayer = acadDoc.Layers.Item("0")
Update
End Sub


Sub B1_chan_top_flat(A As Double, C As Double, D As Double, E As Double)
Dim pt As Variant
Dim A1 As Double, A2 As Double, C1 As Double, C2 As Double, D1 As Double
    A1 = A + D + D
    A2 = A + D
    D1 = D - E
    C1 = C + D1
    C2 = C + D1 + D1
    
 'bounding box
   Call initpt(pt_ll, -1, -1, 0)
   Call initpt(pt_ur, A1 + 2, C2 + 2, 0)
   
pt = Array(0, 0, A1, 0, A1, D1, _
        A2, D1, A2, C1, A1, C1, _
        A1, C2, 0, C2, 0, C1, _
        D, C1, D, D1, 0, D1)
Call draw_array(pt)

acadDoc.ActiveLayer = acadDoc.Layers.Item("UP")
Call line(D, D1, A2, D1)
Call line(D, C1, A2, C1)

acadDoc.ActiveLayer = acadDoc.Layers.Item("0")
Update
End Sub



Sub B1_chan_side_flat(B As Double, C As Double, D As Double, E As Double)
Dim pt As Variant
Dim B1 As Double, C1 As Double, C2 As Double, D1 As Double
B1 = B + E + E
D1 = D - E
C1 = C + D1
C2 = C + D1 + D1

'bounding box
 Call initpt(pt_ll, -1, -1, 0)
 Call initpt(pt_ur, B1 + 2, C2 + 2, 0)

'outside box
pt = Array(0, 0, B1, 0, B1, C2, 0, C2)
Call draw_array(pt)

acadDoc.ActiveLayer = acadDoc.Layers.Item("UP")
Call line(0, D1, B1, D1)
Call line(0, C1, B1, C1)

acadDoc.ActiveLayer = acadDoc.Layers.Item("0")
Update
End Sub

These can be called in any order. In this project i call the bent pieces first. I block them, then move them to an assembly position, using an arbitrary location (K, K). The side piece is drawn horizontal, so it is first rotated and moved about the same point. Again these points are located first on the sketches. The parts are blocked with a sub that accepts the bounding box coordinates, a name and a point for insert point. That routine works with any similar project. It creates a selection set using the bounding box, creates the block with name and insert point, adds the selection set entities to the block, erases the original entities and finally inserts the block. It assigns the block to a global var so the calling program can move it. These routines are in their own module shared by multiple projects.

Sub make_ss_blk(pt_ll() As Double, pt_ur() As Double, strblkname As String, pt_insert() As Double)
  'creates new ss, adds items to it with a crossing window
  'creates new block, adds ss to blk with counting loop
  'deletes original entities and inserts the block
  'creates an object reference to the block objpersistent for moving/rotating
  
    Dim objss As AcadSelectionSet
    Dim objBlock As AcadBlock
    Dim i As Integer
        
    Call addss("my_block")
    Set objss = acadDoc.SelectionSets.Item("my_block")
       objss.Select acSelectionSetCrossing, pt_ll, pt_ur
  
 ' make_blk(objss, strblkname, pt_insert)
    On Error Resume Next
    Set objBlock = acadDoc.Blocks.Item(strblkname)
    objBlock.Delete
    On Error GoTo 0
    
    Set objBlock = acadDoc.Blocks.Add(pt_insert, strblkname)
    
    ReDim Obj(0 To objss.Count - 1) As AcadObject
     'Copy each object selected in the block
    For i = 0 To objss.Count - 1
    Set Obj(i) = objss(i)
    Next i
    acadDoc.CopyObjects Obj, objBlock
   
    objss.Erase
    objss.Delete
    
    Set objpersistent = acadDoc.ModelSpace.InsertBlock(pt_insert, strblkname, 1, 1, 1, 0)
     
End Sub

Sub addss(strname As String)
    Dim objss As AcadSelectionSet
   On Error Resume Next
    If "" = strname Then
    Exit Sub
    End If
    
    Set objss = acadDoc.SelectionSets.Item(strname)
    objss.Delete
    Set objss = acadDoc.SelectionSets.Add(strname)
    If objss Is Nothing Then
    MsgBox "unable to add " & strname
    Else
    'MsgBox "added"
    End If
End Sub

The main calling program will vary depending on interface. Here is the basic one with variable values called out near the top.


Option Explicit
'ProjID B1
'Project Name - Inside Cap Channel
'ProjDesc - to cap existing hole
'a b c d e

Public Const Pi As Double = 3.14159265359
Public Const halfPI = Pi / 2

Public pt0(0 To 2) As Double
Public pt_ll(0 To 2) As Double
Public pt_ur(0 To 2) As Double

Public objss As AcadSelectionSet
Public objent As AcadEntity
Public objpersistent As AcadEntity


Sub B1_draw_inside_cap_chan_assy()

Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double
Dim K As Double
K = 50
Call init_part

'assy vars
Dim A As Double, B As Double, C As Double, D As Double, E As Double
'A is X, B is Y, C is ID THK, D is BENT FLG, E is GA

A = 24
B = 36
C = 4.125
D = 2.5
E = 0.125

Call B1_chan_top_bent(A, D, E)
Call make_ss_blk(pt_ll, pt_ur, "B1_chan_top", pt0)
Call initpt(pt1, A / 2 + D, 0, 0)
Call initpt(pt2, K, K + B / 2, 0)
objpersistent.Move pt1, pt2

Call B1_chan_side_bent(B, D, E)
Call make_ss_blk(pt_ll, pt_ur, "B1_chan_side", pt0)
Call initpt(pt1, B / 2 + E, 0, 0)
Call initpt(pt2, K + A / 2, K, 0)
objpersistent.Rotate pt1, -halfPI
objpersistent.Move pt1, pt2

Call B1_chan_top_flat(A, C, D, E)
addss ("FlatPattern")
Set objss = acadDoc.SelectionSets.Item("FlatPattern")
objss.Select acSelectionSetWindow, pt_ll, pt_ur

Call initpt(pt2, 0, 48, 0)
    For Each objent In objss
    objent.Move pt0, pt2
    Next

Call B1_chan_side_flat(B, C, D, E)
addss ("FlatPattern")
Set objss = acadDoc.SelectionSets.Item("FlatPattern")
objss.Select acSelectionSetWindow, pt_ll, pt_ur

Call initpt(pt2, 0, 24, 0)
    For Each objent In objss
    objent.Move pt0, pt2
    Next

Call initpt(pt2, K, K, 0)
Call cap_chan_sect(C + (2 * E), D, E)
objpersistent.Move pt0, pt2

Update
End Sub

This creates –
2016-12-31_2

The section view is a straightforward drawing sub

Sub cap_chan_sect(C As Double, D As Double, E As Double)
Dim pt As Variant
   Call initpt(pt_ll, -1, -1, 0)
   Call initpt(pt_ur, D + 2, C + 2, 0)
   
pt = Array(0, 0, D, 0, D, E, E, E, E, C - E, D, C - E, D, C, 0, C)
Call draw_array(pt)

Update
End Sub

The init-part sub is simply because i like to be able to run programs in a completely new blank drawing. it creates layers, but also makes the initial connection between excel VBA code and autocad.

Sub init_part()
 Call initpt(pt0, 0, 0, 0)
 Call connect_acad
 Call newlayer("UP", 4, acLnWtByLwDefault, "Continuous")
 Call newlayer("Down", 6, acLnWtByLwDefault, "Hidden")
 Call newlayer("Hidden", 6, acLnWtByLwDefault, "Hidden")
 acadDoc.ActiveLayer = acadDoc.Layers.Item("0")
End Sub

Anything you can draw manually with specificity and clearly defined variables you can automate. It is only slightly more effort to automate dimensioning. Practice will refine your technique.

Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s