This is a sample VBA routine written for AutoCAD Rel 14.
This application will parametrically draw metric structural steel sections
and is intended as an aid towards a better understanding of VBA and
AutoCAD.
Usage.
Unzip the files VbaSteel.dvb and VbaSteel.Lsp to any directory in your
AutoCAD search path.
Type (load "vbasteel") at the command prompt.
Type "vbasteel" to run the application.
The Source Code.
Private Sub cmdCancel1_Click()
Me.Hide
UserForm2.Show
End Sub
Private Sub cmdOK1_Click()
Const PI = 3.141592654
'define PI as constant
Dim Height As Double
Dim Width As Double
Dim t1 As Double
Dim t2 As Double
Dim r1 As Double
Dim acadApp As Object
Dim acadDoc As Object
Dim acadUtil As Object
Dim inPnt As Variant
Dim North As Variant
Dim South As Variant
Dim West As Variant
Dim East As Variant
'declare variables
West = (PI * (180# / 180#))
'convert 180 degrees to radians
North = (PI * (90# / 180#))
'Convert 90 degrees to radians
East = 0
'convert 0 degrees to radians
South = (PI * (270# / 180#))
'convert 270 degrees to radians
NL = Chr(13) & Chr(10)
'define New Line
prompt1 = NL & "Insertion Point: "
'define prompt
Set acadApp = GetObject(, "AutoCAD.Application")
'get reference to AutoCAD
Set acadDoc = acadApp.ActiveDocument
'get reference to Drawing
Set acadUtil = acadDoc.Utility
'get reference to Utility Object
Me.Hide
'hide the dialogue
Select Case ListBox1.ListIndex
'use the select case function to retrieve
'section choosen in list box
Case 0
'if case index = 0
Height = 152.4
'set height
Width = 152.4
'set width
t1 = 6.1
'set web thickness
t2 = 6.8
'set flange thickness
r1 = 7.6
'set root radius
Case 1
Height = 157.5
Width = 152.9
t1 = 6.6
t2 = 6.4
r1 = 7.6
Case 2
Height = 161.8
Width = 154.4
t1 = 8.1
t2 = 11.5
r1 = 7.6
Case 3
Height = 203.2
Width = 203.2
t1 = 7.3
t2 = 11#
r1 = 10.2
Case 4
Height = 206.2
Width = 203.9
t1 = 8#
t2 = 12.5
r1 = 10.2
Case 5
Height = 209.6
Width = 205.2
t1 = 9.3
t2 = 14.2
r1 = 10.2
End Select
'end select case
inPnt = acadUtil.GetPoint(, prompt1)
'get the insertion point
Dim inPntv(0 To 2) As Double
'declare point variable
For i = 0 To 2
'convert x, y & z from variables to doubles
inPntv(i) = inPnt(i)
Next
Dim pt1 As Variant
'declare variants
pt1 = acadUtil.PolarPoint(inPntv, East, t1 / 2)
'use polar function to calculate point
Dim pt1v(0 To 2) As Double
For i = 0 To 2
pt1v(i) = pt1(i)
Next
Dim pt2 As Variant
pt2 = acadUtil.PolarPoint(pt1v, North, (Height - t2 - t2) / 2)
Dim pt2v(0 To 2) As Double
For i = 0 To 2
pt2v(i) = pt2(i)
Next
Dim pt2a As Variant
Dim pt2b As Variant
Dim pt3 As Variant
pt2a = acadUtil.PolarPoint(pt2v, South, r1)
pt2b = acadUtil.PolarPoint(pt2v, East, r1)
pt3 = acadUtil.PolarPoint(pt2v, East, (Width - t1) / 2)
Dim pt3v(0 To 2) As Double
For i = 0 To 2
pt3v(i) = pt3(i)
Next
Dim pt4 As Variant
pt4 = acadUtil.PolarPoint(pt3v, North, t2)
Dim pt4v(0 To 2) As Double
For i = 0 To 2
pt4v(i) = pt4(i)
Next
Dim pt5 As Variant
pt5 = acadUtil.PolarPoint(pt4v, West, Width)
Dim pt5v(0 To 2) As Double
For i = 0 To 2
pt5v(i) = pt5(i)
Next
Dim pt6 As Variant
pt6 = acadUtil.PolarPoint(pt5v, South, t2)
Dim pt6v(0 To 2) As Double
For i = 0 To 2
pt6v(i) = pt6(i)
Next
Dim pt7 As Variant
pt7 = acadUtil.PolarPoint(pt6v, East, (Width - t1) / 2)
Dim pt7v(0 To 2) As Double
For i = 0 To 2
pt7v(i) = pt7(i)
Next
Dim pt7a As Variant
Dim pt7b As Variant
Dim pt8 As Variant
pt7a = acadUtil.PolarPoint(pt7v, West, r1)
pt7b = acadUtil.PolarPoint(pt7v, South, r1)
pt8 = acadUtil.PolarPoint(pt7v, South, Height - t2 - t2)
Dim pt8v(0 To 2) As Double
For i = 0 To 2
pt8v(i) = pt8(i)
Next
Dim pt8a As Variant
Dim pt8b As Variant
Dim pt9 As Variant
pt8a = acadUtil.PolarPoint(pt8v, North, r1)
pt8b = acadUtil.PolarPoint(pt8v, West, r1)
pt9 = acadUtil.PolarPoint(pt8v, West, (Width - t1) / 2)
Dim pt9v(0 To 2) As Double
For i = 0 To 2
pt9v(i) = pt9(i)
Next
Dim pt10 As Variant
pt10 = acadUtil.PolarPoint(pt9v, South, t2)
Dim pt10v(0 To 2) As Double
For i = 0 To 2
pt10v(i) = pt10(i)
Next
Dim pt11 As Variant
pt11 = acadUtil.PolarPoint(pt10v, East, Width)
Dim pt11v(0 To 2) As Double
For i = 0 To 2
pt11v(i) = pt11(i)
Next
Dim pt12 As Variant
pt12 = acadUtil.PolarPoint(pt11v, North, t2)
Dim pt12v(0 To 2) As Double
For i = 0 To 2
pt12v(i) = pt12(i)
Next
Dim pt13 As Variant
pt13 = acadUtil.PolarPoint(pt12v, West, (Width - t1) / 2)
Dim pt13v(0 To 2) As Double
For i = 0 To 2
pt13v(i) = pt13(i)
Next
Dim pt13a As Variant
Dim pt13b As Variant
pt13a = acadUtil.PolarPoint(pt13v, East, r1)
pt13b = acadUtil.PolarPoint(pt13v, North, r1)
Dim moSpace As Object
'declare model space object
Set moSpace = acadDoc.ModelSpace
'get the model space object
Dim lwpolyObj As Object
'declare the light weight polyline object
Dim ptArray(0 To 35) As Double
'declare the array of doubles
ptArray(0) = pt1(0)
'set the array points
ptArray(1) = pt1(1)
ptArray(2) = pt2a(0)
ptArray(3) = pt2a(1)
ptArray(4) = pt2b(0)
ptArray(5) = pt2b(1)
ptArray(6) = pt3(0)
ptArray(7) = pt3(1)
ptArray(8) = pt4(0)
ptArray(9) = pt4(1)
ptArray(10) = pt5(0)
ptArray(11) = pt5(1)
ptArray(12) = pt6(0)
ptArray(13) = pt6(1)
ptArray(14) = pt7a(0)
ptArray(15) = pt7a(1)
ptArray(16) = pt7b(0)
ptArray(17) = pt7b(1)
ptArray(18) = pt8a(0)
ptArray(19) = pt8a(1)
ptArray(20) = pt8b(0)
ptArray(21) = pt8b(1)
ptArray(22) = pt9(0)
ptArray(23) = pt9(1)
ptArray(24) = pt10(0)
ptArray(25) = pt10(1)
ptArray(26) = pt11(0)
ptArray(27) = pt11(1)
ptArray(28) = pt12(0)
ptArray(29) = pt12(1)
ptArray(30) = pt13a(0)
ptArray(31) = pt13a(1)
ptArray(32) = pt13b(0)
ptArray(33) = pt13b(1)
ptArray(34) = pt1(0)
ptArray(35) = pt1(1)
Set lwpolyObj = moSpace.AddLightWeightPolyline(ptArray)
'draw the beam
Dim newBulge As Double
'declare the bulge (Radius)
newBulge = 0 - (Tan(1.570796327 / 4))
'Calculate the bulge (radius)
Call lwpolyObj.SetBulge(1, newBulge)
'radius vertice number 1
Call lwpolyObj.SetBulge(7, newBulge)
'radius vertice number 7
Call lwpolyObj.SetBulge(9, newBulge)
'radius vertice number 9
Call lwpolyObj.SetBulge(15, newBulge)
'radius vertice number 15
Rot = CDbl(Txb1.Text)
'get the rotation angle and convert
'to double
Rot1 = PI * (Rot / 180)
'convert to radians
Call lwpolyObj.Rotate(inPntv, Rot1)
'rotate the beam
End Sub
Private Sub ListBox1_Click()
Txb1.SetFocus
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
cmdOK1_Click
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_Initialize()
'add the beam sizes to the list box
ListBox1.AddItem "152x152x23"
ListBox1.AddItem "152x152x30"
ListBox1.AddItem "152x152x37"
ListBox1.AddItem "203x203x46"
ListBox1.AddItem "203x203x52"
ListBox1.AddItem "203x203x60"
ListBox1.ListIndex = 0
End Sub
|
