AutoCAD 2014 二次开发 VBA 基础与实例

AutoCAD 2014 二次开发VBA 基础与实例第一集AutoCAD二次开发介绍
第二集AutoCAD VBA创建直线1
我们在用VBA在AutoCAD 中完成预期的操作时，需要调用VBA提供的类或方法。

这就要求我们了解vba的基本语法结构。

其实vba和vb的语法结构基本相同，如果学习过vb程序设计语言的话，那么对vba的语言结构就不会陌生，如果没有学过那么，我会逐步给大家来讲解vba的语法结构。

其实如果没有学过vb 语言，就直接学习vba也没有问题。

当然我们也不提倡为了学习vba而去学习vb 程序设计语言，因为没有必要，直接学习vba发而不会受到vb的影响，他们毕竟还是有一些差别的。

我们先来看一个简单的应用：
Vba语法讲解：Dim ps As Variant '定义变量类型,在vba中使用变量前一定要先定义
Dim pt1(0 To 2) As Double Dim pt2(2) As Double 两种定义数组的方法
CAD中的点可以用数组来表示，数组中的三个值分别为x、y、z
第三集AutoCAD VBA创建直线2
上面的过程可以在模型空间内画出一条指定起点和终点的直线，但是如果指定的不是起点和终点，那该怎么办呢，我们可以通过相关的函数将其转换成起点和终点的形式，也可以自定义函数来实现相应的操作。

我们看到了上面过程的最后一个表达式很长，自定义函数可减少这种代码的书写，当然，如果你是初学AutoCAD VBA编程的话，我建议还是尽量多些这些长的代码，因为他可以帮助你理解AutoCAD VBA中各种对象和方法以至属性之间的关系。

那么过程和函数之间有什么区别呢？我们用关键字Sub定义的一段代码为过程，而用关键字Function定义的一段代码为函数，过程和函数都可实现一定的功能或者操作。

过程没有返回值，而函数可以有返回值，这样就可将一长段代码其中的部分功能用函数封装起来。

这样做的好处是，使得代码的可读性更强，代码看起来更简练，同时如果多个功能代码都有相同的部分，则可以减少书写的次数。

第四集AutoCAD VBA创建直线2
第五集AutoCAD VBA创建多段线
再将创建多段线之前，我们先看一下多段线和轻量多段线的区别，如果你是创建二维图形，那么在用VBA创建时，只有坐标的参数有区
别，轻量多段线只有x、y两个坐标值，而多段线则有x、y、x三个坐标值。

下面我们先看一下如何通过代码来创建多段线和轻量多段线。

通过上面的代码我们可以创建多段线和轻量多段线，两者的区别仅在z轴坐标上。

如果我们要改变线的宽度那该怎么办呢？
可以通过改变相应的属性，最后调用update方法来实现。

当然我们也可以像上一集那样通过封装直线来封装多线，通过起点终点、或起点坐标终点坐标来实现多线的创建，但是通常在创建多线时，线的点数是不确定的，所以那样封装的意义就不是很大了。

那么如何在多线中包含圆弧，我们留到后面的章节来讲。

第六集AutoCAD VBA创建圆1
在AutoCAD 2014中，系统为我们提供了6种画圆的方法，而在AutoCAD VBA中，程序只提供了一种方法即AddCircle，在实际应用中可能要用到多种创建圆的方法，那么如何在VBA中也能像CAD实现多种方法来创建圆。

首先我们看一下在VBA中如何创建一个简单的圆
第七集AutoCAD VBA创建圆2
第八集AutoCAD VBA循环语句
第九集AutoCAD VBA创建圆弧1
在AutoCAD 2014 中，系统为我们提供了11种绘制圆弧的方法，但是在AutoCAD
VBA中，同样只提供了一种创建圆弧的方法，即AddArc。

而在通常的程序设计中我们可能会用到多种的圆弧创建方法，这就需要对基本的方法进行扩展。

这里我们封装6种方法
下面我们先来看一个简单的圆w弧创建实例
第十集AutoCAD VBA创建圆弧2
第十一集AutoCAD VBA创建矩形和多边形1
在AutoCAD 2014 中系统对矩形和多边形的绘制只提供了一种方法，而在AutoCAD VBA中并没有提供相应的方法，这是因为矩形和多边形都是多段线，这里我们用轻量多段线来实现矩形和多边形的创建。

在前面几集里，我们都是通过直接给定坐标来实现相应的创建，从这一集开始我们使用通过在模型空间中拾取坐标点或通过命令行来传递参数。

即使用utility对象中和用户交互的方法来实现。

创建矩形
正实现创建正多边形时，我给大家介绍一个编程时经常用到的技巧“死去活来法”
第十二集AutoCAD VBA创建矩形和多边形2
Dim side As Integer
Dim ptCen As Variant
Dim ptSide As Variant
Dim radius As Double
Dim ptArr() As Double
Dim angDiv As Double
Dim angFromX As Double
side = ThisDrawing.Utility.GetInteger("输入正多边形的边数:")
ReDim ptArr(side * 2 - 1) As Double
angDiv = 2 * 3.1415927 / side
ptCen = ThisDrawing.Utility.GetPoint(, "指定正多边形的中心:")
ptSide = ThisDrawing.Utility.GetPoint(ptCen, "指定正多边形一个边的中心点:")
radius = Sqr((ptSide(0) - ptCen(0)) ^ 2 + (ptSide(1) - ptCen(1)) ^ 2)
radius = radius / Cos(angDiv / 2)
angFromX = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSide)
angFromX = angFromX - angDiv / 2
Dim i As Integer
For i = 0 To side * 2 - 2 Step 2
angFromX = angFromX + angDiv
第十三集AutoCAD VBA创建椭圆
在AutoCAD 2014种，系统为我们提供了两种创建椭圆的方法和一个创建椭圆弧
第十四集AutoCAD VBA填充
在AutoCAD 中系统给我们提供了3种填充方法，同样在VBA中我们只有一种方法AddHatch。

下面我们介绍，如何编程来实现填充。

接着我们看一下渐变填充
第十六集AutoCAD VBA创建文字
用AutoCAD VBA创建文字的部分，在AutoCAD 2014种属于注释，但是鉴于其重要性，我们放在这一集来讲，AutoCAD为我们提供了单行文字和多行文字，VBA同样也为我们提供了两种方法。

verticalalignment
要想对上面代码进行封装也很简单。

第十七集修改图元对象属性
在AutoCAD中通过编程来改变图元对象的属性时，我们首先要做的就是选择图元，我们可以通过utility对象提供的方法getEntity方法进行选择，我们来看一个示范
上面的这种方法每次只能修改一个图元对象，如果要实现连续的选择修改，我们则要通过循环来完成。

第十八AutoCAD VBA 循环控制语句
第十九集根据现有图元创建图元1
在AutoCAD中，我们通常需要根据模型空间中现有的图元来绘制一些新的图元，如果用AutoCAD本身提供的绘图命令我们可能要做一些辅助的点或者线。

如果制作一次或者一组这样的操作，用AutoCAD绘图命令要比VBA编程来的简单，但是如果这样的操作有上百次或者上千次，那么使用VBA来实现效率就会高的多，我们这里先讲几个简单的应用，效率更高的应用在我们学习了选择集之后，我再给大家演示。

上面的实例是对文字的操作，下面我们来看一个对圆的操作第二十集根据现有图元创建图元2
同样，像上面一样我们可以创建出其他一些可能需要的图形，比如内接正多边形，外切正多边形，添加文字。

第二十一选择集1
在前面两集中我们看到了通过utility对象的方法GetEntity可以实现和用户的交换操作，在模型空间内选择一个图元对象，然后对其属性进行修改。

同样的可以根据其属性的相关内容，创建其相关联的图元。

但是这个方法有一定的局限性，我们可不可以像AutoCAD软件本身提供的功能那样，在模型空间内通过框选或者窗选来选定一批图元，并对符合要求的图元进行批量的操作，以提供工作效率呢？这就是我们从本集开始讲的选择集。

选择集
选择集集合
第二十二选择集2
上面演示了全部选择模型空间的图元对象，下来看一下窗选和框选
上面的程序就和AutoCAD系统提供的选择方式基本一致，左到右窗选，右到左框选下面我们看一下通过过滤选择
第二十三集选择集创建时过滤图元
条件或者的选择
第二十四集手动添加图元到选择集
在前面我们介绍了通过窗选或框选图元对象来创建选择集，我们来看一下如何逐个的将图元对象加入选择集。

因为批量添加图元到选择集后，我们从选择集中提取图元时，提取的顺序就是未知的，逐个添加到选择集后我们可以控制提取时的顺序。

下面我们先看一下图元是按怎样的顺序添加到选择集中的。

从上面的演示我们看到了选择集添加对象时的顺序时可以控制的。

下面我们看如何取出选择集中的对象，并在添加时加入一些错误控制语句
第二十五集文字对齐操作
实现对齐
Public Sub DemoSSetSort()
On Error Resume Next
Dim objEntity(0) As AcadEntity '选择集的additems方法的参数为数组
Dim SSet As AcadSelectionSet
Dim pickedPoint As Variant
Set SSet = createSSet("mySelectionSet")
'加入误操作判断
xunhuan: Do
ThisDrawing.Utility.GetEntity objEntity(0), pickedPoint, "选择对象:"
If Err <> 0 Then '通过错误判断退出循坏
'误操作具体判断语句
Dim CheckStr As String
CheckStr = ThisDrawing.Utility.GetString(False, "继续选择请输入<C>,结束选择请输入空格：")
If StrComp(CheckStr, "c") = 0 Or StrComp(CheckStr, "C") = 0 Then
Err = 0
GoTo xunhuan
Else
Exit Do
End If
End If
'对图元误选择处理
If StrComp(objEntity(0).EntityName, "AcDbText", vbTextCompare) = 0 Then
SSet.AddItems objEntity
End If
Loop While IsEmpty(objEntity) = False
SSetSort SSet
End Sub
'对其操作的过程
Public Sub SSetSort(ByVal SSet As AcadSelectionSet)
Dim destionPt(2) As Double
Dim insertionPt(2) As Double
Dim objText As AcadText
Dim i As Integer
Dim ptGet As Variant
ptGet = ThisDrawing.Utility.GetPoint(, "拾取对齐点:")
For i = 0 To SSet.Count - 1
Set objText = SSet.Item(i)
If i = 0 Then
' destionPt(0) = objText.InsertionPoint(0)
' destionPt(1) = objText.InsertionPoint(1)
' destionPt(2) = objText.InsertionPoint(2)
destionPt(0) = ptGet(0)
第二十六集对话框基础
第二十七、八集文字多重替换
Private Sub CmdCancel_Click()
On Error Resume Next
SSet.Delete
End
End Sub
Private Sub CmdOK_Click()
On Error Resume Next
Dim objEntity As AcadText
'For Each objEntity In SSet
'objEntity.color = acRed
'Next
If OpAll.Value = True Then
pickSSetAll
End If
If SSet.Count = 0 Then
CmdPick_Click
End If
If Err <> 0 Then
CmdPick_Click
End If
replaceText TextFind1.text, TextReplace1.text, TextFind2.text, TextReplace2.text, TextFind3.text, TextReplace3.text, TextFind4.text, TextReplace4.text
SSet.Delete
End
End Sub
Private Sub CmdPick_Click()
UserForm1.Hide
pickSSet
UserForm1.show
End Sub
Private Sub OpAll_Click()
CmdPick.Visible = False
End Sub
Private Sub OpSelect_Click()
CmdPick.Visible = True
End Sub
Private Sub UserForm_Initialize()
第二十九集字典
1 什么是VBA字典？
字典（dictionary）是一个储存数据的小仓库。

共有两列。

第一列叫key , 不允许有重复的元素。

第二列是item,每一个key对应一个item，本列允许为重复
Key item
A 10
B 20
C 30
Z 10
2 即然有数组，为什么还要学字典？
原因:提速，具体表现在
1) A列只能装入非重复的元素，利用这个特点可以很方便的提取不重复的值
2) 每一个key对应一个唯一的item，只要指定key的值，就可以马上返回其对应的item，利用字典可以实现快速的查找
3 字典有什么局限？
字典只有两列，如果要处理多列的数据，还需要通过字符串的组合和拆分来实现。

字典调用会耗费一定时间，如果是数据量不大，字典的优势就无法体现出来。

4 字典在哪里？如何创建字典？
字典是由scrrun.dll链接库提供的，
工具-引用-浏览-找到scrrun.dll-确定
Set d = CreateObject("scripting.dictionary")
第三十集字典
Public SSet As AcadSelectionSet
第三十一集材料统计
第三十二集馈线修改器
插件演示，编程思路及专业知识讲解。

馈线损耗表
1/2 馈线800、900Mhz 0.05=<radio9m2<=0.1
7/8 馈线800、900Mhz 0.0333=<radio9m8<0.0444
1/2 馈线1800Mhz 0.1=<radio18m2<=0.11
7/8 馈线1800Mhz 0.05=<radio18m8<=0.06
1/2 馈线2200Mhz 0.1=<radio22m2<=0.12
7/8 馈线2200Mhz 0.057=<radio22m8<=0.067
1/2 馈线2400Mhz 0.1=<radio24m2<=0.125
7/8 馈线2400Mhz 0.06=<radio24m8<=0.071
每米衰减取值范围
1/2 馈线800、900Mhz 0.05=<radio9m2<=0.1
1/2 馈线1800Mhz 0.1=<radio18m2<=0.11
1/2 馈线2200Mhz 0.1=<radio22m2<=0.12
1/2 馈线2400Mhz 0.1=<radio24m2<=0.125
2G: 1/2 0.05=<ratio <0.12 7/8 0.02=<ratio<0.05
7/8 馈线800、900Mhz 0.0333=<radio9m8<0.0444 7/8 馈线1800Mhz 0.05=<radio18m8<=0.06
7/8 馈线2200Mhz 0.057=<radio22m8<=0.067
7/8 馈线2400Mhz 0.06=<radio24m8<=0.071
非2G 1/2 0.09=<ratio<0.13 7/8 0.04=<ratio<0.08第三十三集馈线修改器
对话框设计及代码实现
ClearTextBox
ClearData
End Sub
Private Sub CmbBoxwl_Change()
changLabel
ClearTextBox
ClearData
End Sub
Private Sub CmdCancel_Click()
ClearData
End
End Sub
Private Sub CmdOK_Click()
RepalceText
MsgBox "修改完成"
ClearData
ClearTextBox
'WriteTxtBox
End Sub
Private Sub CmdPick_Click()
UserForm1.Hide
ClearData
pickSSet
AddDictionary CmbBoxgg.Text, CmbBoxwl.Text WriteDataToArr
ArrSortbyNum
WriteTxtBox
UserForm1.show
End Sub
Private Sub CmdSortMeter_Click()
ArrSortbyMeter
WriteTxtBox
End Sub
Private Sub Txt14_Change()
On Error Resume Next
ChangeArr Txt14.Text, 1
WriteTxtBox
End Sub
Private Sub Txt24_Change() On Error Resume Next
ChangeArr Txt24.Text, 2
WriteTxtBox
End Sub
Private Sub Txt34_Change() On Error Resume Next
ChangeArr Txt34.Text, 3
WriteTxtBox
End Sub
Private Sub Txt44_Change() On Error Resume Next
ChangeArr Txt44.Text, 4
WriteTxtBox
End Sub
Private Sub Txt54_Change() On Error Resume Next
ChangeArr Txt54.Text, 5
WriteTxtBox
End Sub
Private Sub Txt64_Change() On Error Resume Next
ChangeArr Txt64.Text, 6
WriteTxtBox
End Sub
Private Sub Txt74_Change() On Error Resume Next
ChangeArr Txt74.Text, 7
WriteTxtBox
End Sub
Private Sub Txt84_Change() On Error Resume Next
ChangeArr Txt84.Text, 8
WriteTxtBox
End Sub
Private Sub Txt94_Change() On Error Resume Next
ChangeArr Txt94.Text, 9
WriteTxtBox
End Sub
Private Sub Txt104_Change() On Error Resume Next
ChangeArr Txt104.Text, 10。