第6章化学工程常用图形VBA参数化编程方法及实例
6.1 VBA参数化编程方法简介
VBA的全称是Visual Basic for Application，它有着与VB 几乎相同的语法和开发环境。基于VBA的参数化编程允许用户对AutoCAD进行二次开发，由用户输入（或选择）参数值，程序自动绘制相应的图形。其编程的一般步骤是先由用户输入一个基准点，然后根据基准点计算出其它各点的位置，调用AutoCAD命令进行绘图，最后还要对绘制的图形进行编辑修改，达到最终的效果，具体来说，二维、三维参数化编程主要分为下面几个步骤：（1）绘制图形并确定点图
①交互绘制：拿到一个图形，首先要进行分析，这是必不可少的步骤。先要交互将图形绘制出来。
②确定基点和其它点名：基点就是用户绘图的插入点，要根据实际情况确定，例如圆的基准点一般选择圆心，螺钉类图形通常选其结合面的中心点等。用文字命令将点名写到交互绘制图形上，例如0、1、2…n以便后面编程用到时候方便。
③复杂图形：如果图形复杂，应该找出其相似的部分，单独编成函数，这样可以减少程序的代码量。
④特点分析：对称性、重复性、循环性是某些编程图形的特点，符合这种特点的图形，在编程中只需绘出一个单元图，其余通过镜像、复制、循环语句即可绘出，这在编程中也是很重要的，它可以大大降低编程的工作量，提高程序的质量。
（2）确定参数和尺寸参数表
①独立参数：参数化编程必须有参数，注意有些参数是独立的，需要由用户交互式输入，有些参数是不独立的，可能与某些独立参数相关，只需保留独立参数，不独立参数通过计算得到即可；
②尺寸参数表：此外通常标准件在手册上给出了图形各个尺寸参数的表格，技术人员需要根据表格中的参数及数据，将其输入使得计算机或CAD软件能够应用它们。
③参数取舍：有些参数比较多，像化工上用的法兰或螺钉标准件，编程的参数太多，使得其工作量增加很多，有些参数对于设计人员来说是不重要的，此时将其适当简化是应该的，比如倒角半径、螺纹内外直径差、一些非常小的无关尺寸，当然一定是不重要的尺寸可以简化，重要的尺寸决不能采用这种方法，由此达到尽可能简化参数的数量，降低编程的工作量。
④图形简化：有些图形真实的结果是非常复杂的，甚至有时用编程方法绘制相当麻烦，比如螺栓的头部圆角，法兰的各个侧面的倒角，此时应该将图形的圆角或倒角忽略，适当的忽略在参数化编程中是允许的，只要标注正确即可。
⑤重新命名：在设计手册常用件、标准件的参数化尺寸表中，通常有些不同参数名称是一样的，例如D、d、R、r，这些参数指代的不是同一内容，此时需要重新命名这些变量，比如用D1、D2、R1、R2等名称重新命名，因为程序中这些变量不分大小写，所以尺寸参数表和手册中的标准参数表的变量名称有时是不一样的，编程者务必注意这样的事情。
（3）列出编程点表
基准点和参数确定后，下面就需要列表计算其它各点的坐标位置，所有这些点都是根据基点和各个已知参数计算出来的，注意为了编程过程中不乱并便于检查程序，应该将其以文本表格形式列出，其具体形式请参见后面实例中的编程点表。
（4）初步编程
有了点图、尺寸参数表、编程点表，就可以用进入Visual Basic编辑器，开始编程。点击AutoCAD环境中的【工具】|【宏】|【Visual Basic 编辑器】菜单，进入VBA编辑环境。可以在VBA环境中插入窗体，设计VB风格的界面。将上述点图、尺寸参数表、编程点表作为重要依据，进行点和参数语句的编程，有时为了输入数据的简单，先提前赋值给某些变量，或调用数据库中的参数，直至最后能够用程序绘制出该图形。这里一定要熟悉在VBA环境中调用CAD 命令的格式，避免出错。
（5）调试
任何一位编程人员也不敢保证他所编的程序一点错误也没有，出错是在所难免的，这就需要调试，试运行程序。设置断点、跟踪变量都是调试程序的助手。此外还有可能需要在程序中加入尺寸参数表数据，再进一步调试，这一步调通意味着程序运行可以实现多组数据绘图。如果有必要，AutoCAD可对源代码进行工程级加密的功能，保护编程者的劳动。
注意：三维参数化编程除了要遵循上述主要步骤之外，还需要注意以下几点：
①编程中计算点的时候，尽量不要变换坐标系，除非万不得已不动；
②安排好空间点的位置，注意其变化；
③尽量多用三维旋转Rotate3d、移动Move等命令。
6.2化学工程二维图形VBA参数化编程实例
在化工CAD制图过程中，经常会用到大量的常用标准件的绘制问题，而这些标准件是常用的、结构一致，带有参数表的，这样的图形如果用交互式方法绘制，不仅麻烦，而且降低设计效率，利用AutoCAD系统提供的强大的参数化编程功能来减少工作量，来进行程序自动绘制，是AutoCAD软件系统的优越功能之一，本章将以化工常用标准件为例，用VBA编程模式，介绍法兰、法兰盖、封头、筒体、支座、人孔、手孔的二维参数化编程7个实例；鞍式支座、A型支承式支座、A型耳式支座、常压手孔、水平吊盖式平焊法兰人孔三维参数化
编程5个实例。
6.2.1 一种法兰二维编程实例
在化工管道中，法兰连接的使用十分广泛，法兰连接是化工制图中常用图形。环连接面整体钢制管法兰的剖面图见图6-1，该图是左右对称的结构，可以先绘制右侧部分，然后使用镜像命令复制出左侧部分。其点图、尺寸参数表、点表如下所示：
图6-1 环连接面整体钢制管法兰
图6-2 法兰点图
表6-1 环连接面整体钢制管法兰尺寸参数表
dn d dd k L nn th p e f c n s0 s1 xx
15 20 25 32 40 50 65 80 100 125 150 200 250 300 350 400 105 55 75 14 4 "M12" 35 6.5 9 20 45 10 15 75 130 68 90 18 4 "M16" 45 6.5 9 20 50 10 15 90 140 78 100 18 4 "M16" 50 6.5 9 24 61 10 18 100 155 86 110 22 4 "M20" 65 6.5 9 24 68 10 18 110 170 102 125 22 4 "M20" 75 6.5 9 26 82 10 21 125 180 112 135 22 4 "M20" 85 8 12 26 90 10 22 135 205 136 160 22 8 "M20" 110 8 12 26 105 10 20 160 215 146 170 22 8 "M20" 115 8 12 28 122 11 21 170 250 172 200 26 8 "M24" 145 8 12 30 146 12 23 200 295 208 240 30 8 "M27" 175 8 12 34 177 13 26 240 345 245 280 33 8 "M30X2" 205 8 12 36 204 14 27 280 415 306 345 36 12 "M33X2" 265 8 12 42 264 16 32 345 470 362 400 36 12 "M33X2" 320 8 12 46 320 19 35 400 530 422 460 36 16 "M33X2" 375 8 12 52 378 21 39 460 600 475 525 39 16 "M36X3" 420 8 12 56 434 23 42 525 670 540 585 42 16 "M39X3" 480 8 12 60 490 26 45 585我们以p0点为该图形的起点（插入点），xx，S0，SL，L，N，F，P，d，
K，dd，E，C为参数，确定p0～p17各点的坐标为：
接下来，就可以进行基于VBA的参数化编程。
（1）为了使用方便，首先在D盘根目录下构建名为“falanpan.mdb”的Access数据库，在库中创建一个名为“csb”的表格，存放各个参数数据，构建各个字段（注意顺序不能改变，否则后面的程序按字段顺序提取数据时会出错。）如图6-3所示，然后将表6-1中各个参数输入到数据库中（具体步骤请参考Access资料）。
（2）启动AutoCAD，点击【工具】|【宏】|【Visual Basic 编辑器】菜单，进入VBA编辑环境。在右侧“工程”项中点击鼠标右键，选择【插入】|【用户窗体】在VBA环境中插入一个用户窗体，过程如图6-4所示。接下来，在出现的“工具箱”中，单击鼠标右键，选择“附加控件”，向工具箱中添加
“Microsoft ADO Data Control 6.0(SP4)(OLEDB)”控件，以备用ADO方式访问参数库，如图6-5所示。
图6-3 构建数据库字段
图6-4 在VBA环境中插入用户窗体
图6-5 向工具箱添加ADO控件
（3）向用户窗体添加该Adodc控件，并将其“Visible”属性设为“False”以隐藏该控件。同时添加一个列表框、几个标签控件和几个文本框控件，为文本框命名与标签对应的名字（参见图6-6以及后面的ListBox1_Click函数），添加图像控件和两个按钮控件，并调整位置，然后向图像控件引入法兰图片，设置窗体和按钮“Caption”属性，如图6-6所示。
图6-6 窗体控件示意图
（4）双击用户窗体，进入代码界面，首先在代码的最上端声明通用变量：Dim Falanpan_Con As ADODB.Connection
Dim Falanpan_Rec As ADODB.Recordset
其中，Falanpan_Con和Falanpan_Rec，分别作为数据库对象和数据集对象。
选择窗体的“Initialize”响应函数，该函数负责连接数据库，向列表框添加数据库中法兰盘的各参数数据。Initialize函数代码如下：
Private Sub UserForm_Initialize()
'以ADO方式打开数据库
Set Falanpan_Con = New ADODB.Connection
Set Falanpan_Rec = New ADODB.Recordset
Dim SQL As String
SQL = "provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\falanpan.mdb" '数据库的路径不同则这里需要修改
Falanpan_Con.Open SQL
Falanpan_Rec.Open "csb", Falanpan_Con, adOpenDynamic, adLockBatchOptimistic
'计算打开的数据表中有几条记录
On Error Resume Next
Dim count1 As Integer
count1 = 0
Falanpan_Rec.MoveFirst
Do While Not Falanpan_Rec.EOF
count1 = count1 + 1
Falanpan_Rec.MoveNext
Loop
'数据库的指针指向第一条记录
Falanpan_Rec.MoveFirst
'向列表框添加记录
ListBox1.ColumnCount = 6
ListBox1.AddItem
ListBox1.List(0, 0) = "型号"
ListBox1.List(0, 1) = "D"
ListBox1.List(0, 2) = "d"
ListBox1.List(0, 3) = "K"
ListBox1.List(0, 4) = "L"
ListBox1.List(0, 5) = "n"
For i = 1 To count1
ListBox1.AddItem Falanpan_Rec(0)
ListBox1.List(i, 0) = Falanpan_Rec(1)
ListBox1.List(i, 1) = Falanpan_Rec(2)
ListBox1.List(i, 2) = Falanpan_Rec(3)
ListBox1.List(i, 3) = Falanpan_Rec(4)
ListBox1.List(i, 4) = Falanpan_Rec(5)
ListBox1.List(i, 5) = Falanpan_Rec(6)
Falanpan_Rec.MoveNext
Next
'初始选择确定按钮
CommandButton1.SetFocus
'默认选择第一条记录
ListBox1.Selected(1) = True
End Sub
（5）在窗体上双击列表框，编写列表框的点击响应函数，实现选择不同类型法兰盘时，文本框显示数据的改变，如下所示：
Private Sub ListBox1_Click()
'点击listbox框的首行，不能绘图
If ListBox1.ListIndex = 0 Then
Exit Sub
Else
CommandButton1.Enabled = True
End If
On Error Resume Next
Falanpan_Rec.MoveFirst
For i = 1 To ListBox1.ListIndex - 1 '注意：首行已经用于显示字段名，所以，下标为1为第一个记录Falanpan_Rec.MoveNext
Next
TxtD.Text = Falanpan_Rec(2) 'falanpan_rec(0)和(1)分别为ID号和型号
Txtd2.Text = Falanpan_Rec(3)
TxtK.Text = Falanpan_Rec(4)
TxtL.Text = Falanpan_Rec(5)
Txtn.Text = Falanpan_Rec(6)
Txtth.Text = Falanpan_Rec(7)
Txtp.Text = Falanpan_Rec(8)
Txte.Text = Falanpan_Rec(9)
Txtf.Text = Falanpan_Rec(10)
Txtc.Text = Falanpan_Rec(11)
Txtn2.Text = Falanpan_Rec(12)
Txts0.Text = Falanpan_Rec(13)
Txts1.Text = Falanpan_Rec(14)
Txtxx.Text = Falanpan_Rec(15)
End Sub
（6）回到窗体界面，双击“确定”按钮，出现代码窗口。在这个函数中，要分别创建粗实线层、中心线层、剖面线层并设置其颜色、线型和线宽。在绘图过程中，首先提示输入基点，然后根据点表6-2计算法兰盘右半侧的各点坐标；接下来调用绘图命令绘制图形。在绘制过程中，用到了绘制直线命令和镜像命令。剖面线的绘制要先绘制边界直线，然后在边界直线围成的区域内调用打剖面线命令绘制剖面线。
Private Sub CommandButton1_Click() '绘制法兰盘
'隐藏窗体，以显示绘图区
Me.Hide
'设定粗实线层颜色
Dim CSXLayObj As AcadLayer
Set CSXLayObj = https://www.doczj.com/doc/da10423633.html,yers.Add("粗实线层")
CSXLayObj.color = acWhite
'设定粗实线层的线型
Dim entObj As AcadLineType
Dim found1 As Boolean
found1 = False
For Each entObj In ThisDrawing.Linetypes
If StrComp(https://www.doczj.com/doc/da10423633.html,, "continuous", 1) = 0 Then
found1 = True
Exit For
End If
Next
'如果没有加载粗实线线型，则从线型文件acad.lin中加载
ThisDrawing.Linetypes.Load "continuous", "acad.lin"
End If
CSXLayObj.Linetype = "continuous"
'设定粗实线层的线宽
CSXLayObj.Lineweight = acLnWt030
Dim currLayer As AcadLayer '用于保存当前图层的对象变量
Dim newLayer As AcadLayer '保存新当前图层的对象变量
Set currLayer = ThisDrawing.ActiveLayer
Set newLayer = https://www.doczj.com/doc/da10423633.html,yers("粗实线层")
ThisDrawing.ActiveLayer = newLayer
'输入插入点
Dim insertPnt As Variant
On Error GoTo GetPointWrong
insertPnt = ThisDrawing.Utility.GetPoint(, "请输入插入点：")
'计算各点坐标
Dim Pnt1(0 To 2) As Double
Dim xx As Double
xx = CDbl(Txtxx.Text) 'CDbl为将文本数据转换成双精度数据函数
Pnt1(0) = insertPnt(0)
Pnt1(1) = insertPnt(1) - xx
Pnt1(2) = insertPnt(2) '平面绘图中，Z坐标为0
Dim Pnt2(0 To 2) As Double
Pnt2(0) = insertPnt(0) + 0.5 * CDbl(Txtn2.Text) - (CDbl(Txts1.Text) - CDbl(Txts0.Text)) Pnt2(1) = insertPnt(1)
Pnt2(2) = insertPnt(2)
Dim Pnt3(0 To 2) As Double
Pnt3(0) = Pnt2(0)
Pnt3(1) = Pnt2(1) - (CDbl(Txtxx.Text) - CDbl(Txtc.Text) - CDbl(Txte.Text)) / 3
Pnt3(2) = insertPnt(2)
Dim Pnt4(0 To 2) As Double
Pnt4(0) = insertPnt(0) + 0.5 * CDbl(Txtn2.Text)
Pnt4(1) = insertPnt(1) - (CDbl(Txtxx.Text) - CDbl(Txtc.Text) - CDbl(Txte.Text))
Pnt4(2) = insertPnt(2)
Dim Pnt5(0 To 2) As Double
Pnt5(0) = Pnt4(0) + (CDbl(TxtD.Text) - CDbl(Txtn2.Text)) / 2
Pnt5(1) = Pnt4(1)
Pnt5(2) = insertPnt(2)
Dim Pnt6(0 To 2) As Double
Pnt6(0) = Pnt5(0)
Pnt6(1) = Pnt5(1) - CDbl(Txtc.Text)
Pnt6(2) = insertPnt(2)
Dim Pnt7(0 To 2) As Double
Pnt7(0) = Pnt6(0) - (CDbl(TxtD.Text) - CDbl(Txtd2.Text)) / 2
Pnt7(1) = Pnt6(1)
Pnt7(2) = insertPnt(2)
Dim Pnt8(0 To 2) As Double
Pnt8(0) = Pnt7(0)
Pnt8(1) = Pnt7(1) - CDbl(Txte.Text)
Pnt8(2) = insertPnt(2)
Dim Pnt9(0 To 2) As Double
Pnt9(0) = insertPnt(0) + 0.5 * CDbl(Txtn2.Text) - CDbl(Txts1.Text)
Pnt9(1) = insertPnt(1)
Pnt9(2) = insertPnt(2)
Dim Pnt10(0 To 2) As Double
Pnt10(0) = Pnt9(0)
Pnt10(1) = Pnt9(1) - CDbl(Txtxx.Text)
Pnt10(2) = insertPnt(2)
Dim Pnt11(0 To 2) As Double
Pnt11(0) = Pnt5(0) - (CDbl(TxtD.Text) - CDbl(TxtK.Text) + CDbl(TxtL.Text)) / 2 Pnt11(1) = Pnt5(1)
Pnt11(2) = insertPnt(2)
Dim Pnt12(0 To 2) As Double
Pnt12(0) = Pnt11(0)
Pnt12(1) = Pnt11(1) - CDbl(Txtc.Text)
Pnt12(2) = insertPnt(2)
Dim Pnt13(0 To 2) As Double
Pnt13(0) = Pnt11(0) + CDbl(TxtL.Text)
Pnt13(1) = Pnt11(1)
Pnt13(2) = insertPnt(2)
Dim Pnt14(0 To 2) As Double
Pnt14(0) = Pnt12(0) + CDbl(TxtL.Text)
Pnt14(1) = Pnt12(1)
Pnt14(2) = insertPnt(2)
Dim Pnt15(0 To 2) As Double
Pnt15(0) = Pnt1(0) + (CDbl(Txtp.Text) - CDbl(Txtf.Text)) / 2
Pnt15(1) = Pnt1(1)
Pnt15(2) = insertPnt(2)
Dim Pnt16(0 To 2) As Double
Pnt16(0) = Pnt15(0) + 0.5 * CDbl(Txtf.Text)
Pnt16(1) = Pnt15(1) + CDbl(Txtf.Text)
Pnt16(2) = insertPnt(2)
Dim Pnt17(0 To 2) As Double
Pnt17(0) = Pnt15(0) + CDbl(Txtf.Text)
Pnt17(1) = Pnt15(1)
Pnt17(2) = insertPnt(2)
'绘制半个法兰盘中不是剖面线边界的直线
Dim linObj(0 To 4) As AcadLine
Set linObj(0) = ThisDrawing.ModelSpace.AddLine(insertPnt, Pnt9)
Set linObj(1) = ThisDrawing.ModelSpace.AddLine(Pnt11, Pnt13)
Set linObj(2) = ThisDrawing.ModelSpace.AddLine(Pnt12, Pnt14)
Set linObj(3) = ThisDrawing.ModelSpace.AddLine(Pnt15, Pnt17)
Set linObj(4) = ThisDrawing.ModelSpace.AddLine(Pnt10, Pnt1)
'绘制半个法兰盘中是剖面线边界的直线
Dim outerLoop(0 To 11) As AcadEntity '注意：对象数量要严格和边界直线数一致Set outerLoop(0) = ThisDrawing.ModelSpace.AddLine(Pnt9, Pnt2)
Set outerLoop(1) = ThisDrawing.ModelSpace.AddLine(Pnt2, Pnt3)
Set outerLoop(2) = ThisDrawing.ModelSpace.AddLine(Pnt3, Pnt4)
Set outerLoop(3) = ThisDrawing.ModelSpace.AddLine(Pnt4, Pnt11)
Set outerLoop(4) = ThisDrawing.ModelSpace.AddLine(Pnt11, Pnt12)
Set outerLoop(5) = ThisDrawing.ModelSpace.AddLine(Pnt12, Pnt7)
Set outerLoop(6) = ThisDrawing.ModelSpace.AddLine(Pnt7, Pnt8)
Set outerLoop(7) = ThisDrawing.ModelSpace.AddLine(Pnt8, Pnt17)
Set outerLoop(8) = ThisDrawing.ModelSpace.AddLine(Pnt17, Pnt16)
Set outerLoop(9) = ThisDrawing.ModelSpace.AddLine(Pnt16, Pnt15)
Set outerLoop(10) = ThisDrawing.ModelSpace.AddLine(Pnt15, Pnt10)
Set outerLoop(11) = ThisDrawing.ModelSpace.AddLine(Pnt10, Pnt9)
Dim outerLoop2(0 To 3) As AcadEntity '注意：对象数量要严格和边界直线数一致Set outerLoop2(0) = ThisDrawing.ModelSpace.AddLine(Pnt13, Pnt5)
Set outerLoop2(1) = ThisDrawing.ModelSpace.AddLine(Pnt5, Pnt6)
Set outerLoop2(2) = ThisDrawing.ModelSpace.AddLine(Pnt6, Pnt14)
Set outerLoop2(3) = ThisDrawing.ModelSpace.AddLine(Pnt14, Pnt13)
'设定剖面线层颜色
Dim hatchLayObj As AcadLayer
Set hatchLayObj = https://www.doczj.com/doc/da10423633.html,yers.Add("剖面线层")
hatchLayObj.color = acYellow
Set newLayer = https://www.doczj.com/doc/da10423633.html,yers("剖面线层")
ThisDrawing.ActiveLayer = newLayer
'设定剖面线层的线型
Dim entObj1 As AcadLineType
Dim found As Boolean
found = False
For Each entObj1 In ThisDrawing.Linetypes
If StrComp(https://www.doczj.com/doc/da10423633.html,, "continuous", 1) = 0 Then
found = True
Exit For
End If
Next
'如果没有加载剖面线线型，则从线型文件acad.lin中加载
If Not (found) Then
ThisDrawing.Linetypes.Load "continuous", "acad.lin"
End If
hatchLayObj.Linetype = "continuous"
Dim hatchObj As AcadHatch '声明剖面线对象变量
Dim patternName As String '保存剖面线模式名称的对象变量
Dim patternType As Long '保存剖面线模式类型的对象变量
Dim assocVar As Boolean '判断剖面线与轮廓是否结合
'定义剖面线模式
patternName = "Ansi31"
patternType = acHatchPatternTypePreDefined
assocVar = True '与边界结合
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(patternType, patternName, assocVar) '将外轮廓线和剖面线关联起来，并计算，使剖面线与边界吻合，完成打右侧的剖面线hatchObj.AppendOuterLoop (outerLoop)
hatchObj.Evaluate
hatchObj.AppendOuterLoop (outerLoop2)
hatchObj.Evaluate
'通过镜像绘制另一半
Dim i As Integer
Dim retVal(0 To 11) As AcadLine '注意打剖面线时数组的大小要和轮廓线数量一致Dim retval2(0 To 3) As AcadLine 'retVal1，2分别是镜像后的对象集（直线集）
For i = 0 To 4 '镜像不是剖面线边界的直线
linObj(i).Mirror insertPnt, Pnt1
Next
'镜像是剖面线边界的直线并记录其镜像后的线集以便绘制镜像后区域内的剖面线
For i = 0 To 11
Set retVal(i) = outerLoop(i).Mirror(insertPnt, Pnt1)
Next
For i = 0 To 3
Set retval2(i) = outerLoop2(i).Mirror(insertPnt, Pnt1)
Next
'给镜像的另一半打剖面线
hatchObj.AppendOuterLoop (retVal)
hatchObj.Evaluate
hatchObj.AppendOuterLoop (retval2)
hatchObj.Evaluate
'绘制中心线
'设定中心线层颜色
Dim CenterLayObj As AcadLayer
Set CenterLayObj = https://www.doczj.com/doc/da10423633.html,yers.Add("中心线层")
CenterLayObj.color = acGreen
Set newLayer = https://www.doczj.com/doc/da10423633.html,yers("中心线层")
ThisDrawing.ActiveLayer = newLayer
'设定中心线层的线型
found = False
For Each entObj1 In ThisDrawing.Linetypes
If StrComp(https://www.doczj.com/doc/da10423633.html,, "Center", 1) = 0 Then
found = True
Exit For
End If
Next
'如果没有加载中心线线型，则从线型文件acad.lin中加载
If Not (found) Then
ThisDrawing.Linetypes.Load "center", "acad.lin"
End If
CenterLayObj.Linetype = "Center"
'设定中心线层的线宽
'CenterLayObj.Lineweight = acLnWt000
'画中心线
Dim midPnt2(0 To 2) As Double
Dim midPnt3(0 To 2) As Double
midPnt1(0) = 0.5 * (Pnt11(0) + Pnt13(0))
midPnt1(1) = Pnt11(1)
midPnt1(2) = insertPnt(2)
midPnt2(0) = 0.5 * (Pnt12(0) + Pnt14(0))
midPnt2(1) = Pnt12(1)
midPnt2(2) = insertPnt(2)
midPnt3(0) = 0.5 * (Pnt15(0) + Pnt17(0))
midPnt3(1) = Pnt15(1)
midPnt3(2) = insertPnt(2)
Dim linObj1 As AcadLine
Set linObj1 = ThisDrawing.ModelSpace.AddLine(insertPnt, Pnt1) '绘制整个图形的中心线
'以中心线的中点为基点将其加长1.1倍
Dim midPnt(0 To 2) As Double
midPnt(0) = (insertPnt(0) + Pnt1(0)) / 2
midPnt(1) = (insertPnt(1) + Pnt1(1)) / 2
midPnt(2) = insertPnt(2)
linObj1.ScaleEntity midPnt, 1.1
Set linObj1 = ThisDrawing.ModelSpace.AddLine(midPnt1, midPnt2) '绘制右侧第二条中心线
'以中心线的中点为基点将其加长1.1倍
midPnt(0) = (midPnt1(0) + midPnt2(0)) / 2
midPnt(1) = (midPnt1(1) + midPnt2(1)) / 2
midPnt(2) = insertPnt(2)
linObj1.ScaleEntity midPnt, 1.1
linObj1.Mirror insertPnt, Pnt1 '镜像与右侧第二条中心线对称的中心线
Set linObj1 = ThisDrawing.ModelSpace.AddLine(Pnt16, midPnt3) '绘制右侧第三条中心线
'以中心线的中点为基点将其加长1.1倍
midPnt(0) = (Pnt16(0) + midPnt3(0)) / 2
midPnt(1) = (Pnt16(1) + midPnt3(1)) / 2
midPnt(2) = insertPnt(2)
linObj1.ScaleEntity midPnt, 1.1
linObj1.Mirror insertPnt, Pnt1 '镜像与右侧第三条中心线对称的中心线
'恢复原来的图层
ThisDrawing.ActiveLayer = currLayer
ThisDrawing.SendCommand ("Zoom e ") '执行范围放大命令，注意执行命令的格式及空格
Unload Me
Exit Sub
GetPointWrong: '容错处理
Unload Me
MsgBox ("输入点错误!")
End Sub
（7）完成窗体代码编写后，可以在VBA环境中插入“模块”（方式与插入窗体类似），编写如下代码：
Public Sub Flp()
Load UserForm1
UserForm1.Show
End Sub
然后回到AutoCAD环境，选择【工具】|【宏】|【宏】，调出定义的宏，选择“运行”按钮就可以执行整个程序。对话框界面如图6-7所示：
图6-7 环连接面整体钢制管法兰对话框