CAD_VBA
AutoCAD VBA
一、A u t o C A D V B A简介
VBA（Visual Basic for Application）
VBA是AutoCAD的一种开发工具，具有强大的功能。Microsoft VBA是一种面向对象的编程环境，它与VB一样具有很强的开发功能。VBA与VB之间的区别就是VBA AutoCAD在同一处理
空间运行，为AutoCAD提供智能和快速的编程环境。VBA功能：创建对话框和其它界
面；
●创建工具栏；
●建立模块级宏指令；
●提供建立类模块的功能；
●具有完善的数据访问和管理能力；(ADO、DAO、RDO，C/S)
●能够使用Win32API提供的功能，建立应用程序与操作系统之间的通信；在
AutoCAD中使用VBA的好处Visual Basic编程环境易学易用；
●VBA作为AutoCAD的一个过程运行，这使程序执行速度变得非常快；
●对话框结构快速有效，允许开发者在设计时启动应用程序并能得到快速反
馈；（易于代码纠错和维护）
●对象可以独立出来，也可以嵌入AutoCAD图形。灵活性很强。
二、理解类和对象在AutoCAD VBA界面中有许多不同类型的对象。例如:
●图形对象，如线、弧、文本和标注都是对象；
●样式设置，如线型和标注样式均为对象；
●组织结构，如图层、组合和图块也是对象；
●图形显示，如视图和视口都是对象；
●甚至图形和AutoCAD应用程序本身也是对象。对象是通过分层方式来组织的，应用程序对象为根对象。这种分层结构的视图被归结为对象模型。对象模型提供了你访问下一层对象的途径。
集合对象是预先定义的对象，它包含所有相似对象的实例(即这些对象的父对象)。集合对象有以下的对象：
文档(Documents)集合
包含所有在当前AutoCAD进程打开的文档。
模型空间(ModelSpace)集合
包含在模型空间中的所有图形对象(图元)。
图纸空间(PaperSpace)集合
包含在活动图纸空间布局中的所有图形对象(图元)。
图块(Block)对象
包含在指定图块定义中的所有图元。
图块(Blocks)集合
包含在图形中的所有图块。
字典(Dictionaries)集合
包含在图形中的所有字典。
标注样式(DimStyles)集合
包含在图形中的所有标注样式。
组合(Groups)集合
包含在图形中的所有组合。
超级链接(Hyperlinks)集合
包含提供图元的所有超级链接。
图层(Layers)集合
包含在图形中的所有图层。
布局(Layouts)集合
包含在图形中的所有布局。
线型(Linetypes)集合
包含在图形中的所有线型。
菜单条(MenuBar)集合
包含当前显示于AutoCAD的所有菜单。
菜单组(MenuGroups)集合
包含当前装载到AutoCAD中的所有菜单和工具栏。
注册应用程序(RegisteredApplications)集合
包含在图形中的所有注册的应用程序。
选择集(SelectionSets)集合
包含在图形中所有的选择集。
字型(TextStyles)集合
包含在图形中所有的文字样式。
UCSs 集合
包含在图形中所有的用户坐标系统(UCS)。
视图(Views)集合
包含在图形中所有的视图。
视口(Viewports)集合
包含在图形中所有的视口。
三、理解对象的属性和方法
每一对象都关联着属性和方法。属性描述着单个对象的外观，而方法是一种可在单个对象上执行的行为。当对象创建后，你就可通过属性和方法查询和编辑对象。
例如，一个圆对象有圆心属性。该属性以三维世界坐标系统的坐标描述了圆的圆心。更改圆的圆心，你只要简单地将该属性设定为新的坐标。圆对象也有称为偏移(Offset)的方法。该方法可在相对于现存圆的指定偏移距离创建一个新的对象。关于圆对象所有属性和方法的列表，请参考AutoCAD ActiveX和VBA参考中的圆对象。
四、开发实例
目录
1、程序和文档窗口设置 (4)
2、视图 (5)
3、二维图形绘制 (5)
4、图层 (7)
5、用户输入 (8)
7、栅格图像 Raster (10)
8、计算面积 (10)
9、加载菜单 (11)
10、‘增加菜单按钮和创建菜单按钮 (11)
11、加载线型 (12)
12、文件File (13)
13、控制命令输入窗口SendCommand (14)
14、三维绘图 (14)
15、块 (综合练习) (15)
16、运行宏 (17)
1、程序和文档窗口设置
'''***************************************************************************** Sub MyWindow()
MsgBox ThisDrawing.WindowTitle '= \"杨彪绘图01\"
ThisDrawing.WindowState = acMin 'acMax 'acNorm
End Sub
Sub SetMyAcadTitle()
Dim hw&
hw = GetParent(GetParent(ThisDrawing.hwnd))
SetWindowText hw, \"杨彪地质编录出图子系统\"
Call InitialDZBL '初始化
ThisDrawing.WindowState = acMax
End Sub
Sub SetMyAcadWindow()
ThisDrawing.Application.WindowState = acNorm
ThisDrawing.Application.WindowLeft = 100
ThisDrawing.Application.WindowLeft = 100
ThisDrawing.Application.Width = 600
ThisDrawing.Application.Height = 600
End Sub
2、视图
'''************************************************************************** MyZoomView1()
ThisDrawing.Application.ZoomExtents
ZoomAll
End Sub
Sub MyZoomView2()
Dim VPn1 As Variant, VPn2 As V ariant
VPn1 = ThisDrawing.Utility.getpoint(, \" 缩放窗口左下点：\")
VPn2 = ThisDrawing.Utility.getpoint(, \" 缩放窗口右上点：\")
ThisDrawing.Application.ZoomWindow VPn1, VPn2
Sub
End Sub
3、二维图形绘制
‘addline
Sub Myaddline()
Dim ln As AcadLine
Dim startPt(2) As Double, EndPt(2) As Double
startPt(0) = 0
startPt(1) = 0
startPt(0) = 100
startPt(1) = 50
Set ln = ThisDrawing.ModelSpace.AddLine(startPt(), EndPt())
ln.color = acRed
ZoomAll
End Sub
‘LightWeightPolyline
Sub MyLightWeightPolyline ()
Dim MyPln As AcadLWPolyline
Dim Pnts(9) As Double
For I = 0 To 9
Pnts(I) = Rnd * 100
Next
' Pnts(0) = PntMin(0): Pnts(1) = PntMin(1)
' Pnts(2) = PntMin(0) + DWidth: Pnts(3) = PntMin(1)
' Pnts(4) = PntMin(0) + DWidth: Pnts(5) = PntMin(1) + DHeight
' Pnts(6) = PntMin(0): Pnts(7) = PntMin(1) + DHeight
' Pnts(8) = PntMin(0): Pnts(9) = PntMin(1)
Set MyPln = ThisDrawing.ModelSpace.AddLightWeightPolyline(Pnts)
Dim n As Integer
n = UBound(Pnts)
For K = 0 To (n / 2 - 1) '宽度设定
MyPln.SetWidth K, K / 5, Rnd * 10
Next
MyPln.color = acYellow
ZoomAll
End Sub
‘Polyline
Sub MyPolyline()
Dim MyPln As AcadPolyline
Dim Pnts(8) As Double '''必须是3*N的数组
For I = 0 To 8
Pnts(I) = Rnd * 100
Next
Set MyPln = ThisDrawing.ModelSpace.AddPolyline(Pnts)
Dim n As Integer
n = UBound(Pnts)
For K = 0 To (n / 3 - 1) '宽度设定
MyPln.SetWidth K, K / 5, Rnd * 10
Next
MyPln.color = acYellow
ZoomAll
End Sub
‘Light Circle and Hatch
Sub MyCircle()
Dim Cir(0) As AcadCircle
VPn1 = ThisDrawing.Utility.getpoint(, \" 输入插入点：\")
Set Cir(0) = ThisDrawing.ModelSpace.AddCircle(VPn1, 10#)
Set MyHatchObj = ThisDrawing.ModelSpace.AddHatch(0, MyHatchObj.AppendOuterLoop (Cir)
MyHatchObj.color = 1
MyHatchObj.Evaluate
End Sub
Sub Mytext()
Dim MyTxt As AcadText
Dim StrTxt As String
Dim VPnts(2) As Double
StrTxt = \"HoHai UniverSity 河海大学土木工程学院测绘工程系\"
True) \"Solid\
Set MyTxt = ThisDrawing.ModelSpace.AddText(StrTxt, VPnts, 100)
MyTxt.color = acRed
ZoomAll
End Sub
Sub MyPoint()
Dim Pnts(0 To 2) As Double
Dim I As Integer, J As Integer
Dim MyPoint As AcadPoint
Pnts(I) = 50
Pnts(I) = 60
Set MyPoint = ThisDrawing.ModelSpace.AddPoint(Pnts)
ZoomAll
End Sub
4、图层
Sub GetlayerName()
Dim MyLay As AcadLayer
Dim BLExist As Boolean
BLExist = False
Dim LayExit As Boolean
LayExit = False
For Each MyLay In ThisDrawing.Layers
If MyLay.Name = \"ybNewLayer\" Then LayExit = True
MsgBox MyLay.Name, vbInformation
Next
If LayExit Then
MsgBox \"图层：'ybNewLayer' 已经存在!\
Else
ThisDrawing.Layers.Add \"ybNewLayer\"
End If
ThisDrawing.Layers(\"ybNewLayer\").LayerOn = True
ThisDrawing.Layers(\"ybNewLayer\").Lock = False
ThisDrawing.ActiveLayer = ThisDrawing.Layers(\"ybNewLayer\")
'obj.Layer = \"ybNewLayer\"
ThisDrawing.Layers(\"ybNewLayer\").color = 1
End Sub
Sub Ch2_IterateLayer()
' 在图层集合中循环
On Error Resume Next
Dim I As Integer
Dim msg As String
msg = \"\"
For I = 0 To ThisDrawing.Layers.count - 1
msg = msg + ThisDrawing.Layers.Item(I).Name + vbCrLf
Next
MsgBox msg
End Sub
5、用户输入
'''*********************************************************************** GetInput()
Dim VPn1 As Variant, StrTF As String, KwordList As String, Str1 As String
Dim Obj1 As AcadObject
VPn1 = ThisDrawing.Utility.getpoint(, \" 输入插入点：\")
Str1 = ThisDrawing.Utility.GetString(1, \"请输入点号：\")
Sub
KwordList = \"Y N\"
ThisDrawing.Utility.InitializeUserInput 1, KwordList
StrTF = ThisDrawing.Utility.GetKeyword(\" 是否显示选点的坐标？(是Y)/(否N)：\")
If UCase(StrTF) = \"Y\" Then
MsgBox \"点\" & Str1 & \"：\" & \"X=\" & VPn1(0) & \" ; \" & \"Y=\" & VPn1(1) & \" : \" & \"Z=\" & VPn1(2), vbInformation
Else
End If
ThisDrawing.Utility.GetEntity Obj1, Pnt1, \"选择一个对象：\"
Obj1.color = 1
End Sub
Sub MyZoomView3()
Str1 = ThisDrawing.Utility.GetString(1, \"请按回车键：\")
ThisDrawing.Application.ZoomScaled 0.7, acZoomScaledRelative
End Sub
6、选择集合'''**** SelectionSets ***************************
Sub MySelectionSets()
Dim K As Integer
Dim ssetObj As AcadSelectionSet
Dim objCollection As AcadEntity
Dim ob As AcadEntity
Dim I As Integer
For I = ThisDrawing.SelectionSets.count - 1 To 0 Step -1
ThisDrawing.SelectionSets(I).Delete
Next I
' ThisDrawing.Utility.GetEntity objCollection, Pnt1, \"选择一个对象：\"
' objCollection.color = 1
Set ssetObj = ThisDrawing.SelectionSets.Add(\"ybssa\")
' Set ssetObj = ThisDrawing.ActiveSelectionSet
ssetObj.Select acSelectionSetAll
If ssetObj.count > 0 Then
MsgBox \"选择集中对象数目: \" & ssetObj.count
For Each ob In ssetObj
ob.color = acMagenta
Next
End If
End Sub
7、栅格图像Raster
Sub InsertRaster()
Dim a As AcadRasterImage
Dim b(2) As Double
Dim ly As AcadLayer
Dim PicFileName As String
Dim factor As Double
factor = 2#
Set ly = ThisDrawing.Application.ActiveDocument.Layers.Add(\"底图\")
PicFileName = \"E:\\图片\\Bliss.jpg\"
b(0) = 100
b(1) = 100
b(2) = 0
Set a ThisDrawing.Application.ActiveDocument.ModelSpace.AddRaster(PicFileName, factor, 45)
a.Transparency = True
=
b,
a.Layer = \"底图\"
ThisDrawing.Application.ZoomExtents
ThisDrawing.SaveAs \"E:\\yangbiao.dwg\"
End Sub
8、计算面积
'''************************计算面积**************************************
Sub Ch3_CalculateDefinedArea()
Dim p1 As Variant
Dim p2 As Variant
Dim p3 As Variant
Dim p4 As Variant
Dim p5 As Variant
' 从用户处取得点
p1 = ThisDrawing.Utility.getpoint(, vbCrLf & \"第一个点: \")
p2 = ThisDrawing.Utility.getpoint(p1, vbCrLf & \"第二个点: \")
p3 = ThisDrawing.Utility.getpoint(p2, vbCrLf & \"第三个点: \")
p4 = ThisDrawing.Utility.getpoint(p3, vbCrLf & \"第四个点: \")
p5 = ThisDrawing.Utility.getpoint(p4, vbCrLf & \"第五个点: \")
' 由这些点创建二维多段线
Dim polyObj As AcadLWPolyline
Dim vertices(0 To 9) As Double
vertices(0) = p1(0): vertices(1) = p1(1)
vertices(2) = p2(0): vertices(3) = p2(1)
vertices(4) = p3(0): vertices(5) = p3(1)
vertices(6) = p4(0): vertices(7) = p4(1)
vertices(8) = p5(0): vertices(9) = p5(1)
Set polyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline _
(vertices)
polyObj.Closed = True
ThisDrawing.Application.ZoomAll
' 显示多段线的面积
MsgBox \"通过定义的点形成的面积为\" & _
polyObj.Area, , \"计算定义的面积\"
End Sub
9、加载菜单
‘加载菜单
Sub MenuAutocad()
Dim acMenuGroup As AcadMenuGroup
For Each acMenuGroup In ThisDrawing.Application.MenuGroups
acMenuGroup.Unload
Next
Set acMenuGroup = ThisDrawing.Application.MenuGroups.Load(\"acad.mnc\True) End Sub
10、‘增加菜单按钮和创建菜单按钮
Sub CreateMenuFirst2()
Set acApp = ThisDrawing.Application
Dim acMenu As AcadPopupMenu
Dim acMenuItem As AcadPopupMenuItem
Dim NewacMenu As AcadPopupMenuItem
Set acMenu = acApp.MenuGroups(0).Menus(\"文件(&F)\")
Set acMenuItem = acMenu.AddMenuItem(0, \"杨彪\
Set acMenuItem = acMenu.AddMenuItem(0, \"杨彪4\
Set acMenu = ThisDrawing.Application.MenuGroups(0).Menus.Add(\"杨彪111\")
Set acMenuItem = acMenu.AddMenuItem(0, \"放大\
Set acMenuItem = acMenu.AddMenuItem(1, \"缩小\
Set acMenuItem = acMenu.AddMenuItem(2, \"全景显示\
Set acMenuItem = acMenu.AddMenuItem(3, \"最大显示\
Set acMenuItem = acMenu.AddMenuItem(4, \"鸟瞰\
Set acMenuItem = acMenu.AddMenuItem(5, \"移动\
acMenu.InsertInMenuBar 10
acApp.MenuGroups(0).SaveAs \"d:\\MyMenu.mnu\
End Sub
‘增加工具栏按钮和创建工具栏
Sub CreateToolFirst()
Set acApp = ThisDrawing.Application
Dim acToolbar As AcadToolbar
Dim acToolbarItem As AcadToolbarItem
Dim ToolbarItem As AcadToolbarItem
On Error Resume Next
Set acToolbar = ThisDrawing.Application.MenuGroups(0).Toolbars(\"常用\")
Set ToolbarItem = acToolbar.AddToolbarButton(0, \"杨彪22\\")
Call ToolbarItem.SetBitmaps(\"E:\\图标\\1.ico\图标\\2.ico\")
Set ToolbarItem = acToolbar.AddToolbarButton(0, \"杨彪124\showpic2 \")
Set acToolbar = ThisDrawing.Application.MenuGroups(0).Toolbars.Add(\"杨彪1111\") Set ToolbarItem = acToolbar.AddToolbarButton(0, \"放大\\")
Call ToolbarItem.SetBitmaps(\"E:\\图标\\3.ico\图标\\3.ico\")
Set ToolbarItem = acToolbar.AddToolbarButton(1, \"缩小\
Call ToolbarItem.SetBitmaps(\"E:\\图标\\4.bmp\图标\\4.bmp\")
Set ToolbarItem = acToolbar.AddToolbarButton(2, \"全景显示\
Set ToolbarItem = acToolbar.AddToolbarButton(3, \"最大显示\
Call ToolbarItem.SetBitmaps(\"E:\\图标\\5.ico\图标\\5.ico\")
acToolbar.Visible = True
acApp.MenuGroups(0).SaveAs \"d:\\mymenu.mnu\
End Sub
11、加载线型
'加载线型的子程序
Sub MLoadLineTypes()
Dim BL0 As Boolean
Dim I As Integer, ILen As Integer
Dim Str1 As String
Dim StrLine As String, StrLin As String
StrLin = ThisDrawing.Application.Path + \"\\Support\\\" + \"DZBL.lin\"
If Dir(StrLin) = \"\" Then
MsgBox \"没有找到线型文件\" + StrLin + \"不能进行操作\错误\"
End
End If
Open StrLin For Input As #1
On Error Resume Next
Do While Not EOF(1)
Line Input #1, StrLine
StrLine = Trim(StrLine & \" \")
ILen = Len(StrLine)
If ILen > 1 Then
Str1 = Mid(StrLine, 1, 1)
If Str1 = \"*\" Then
For I = 1 To ILen
If Mid(StrLine, I, 1) = \
Exit For
End If
Next
StrLine = Mid(StrLine, 2, I - 2)
BL0 = False
Call LineTypeExist(StrLine, BL0)
If Not BL0 Then '线型不存在则加载
ThisDrawing.Linetypes.Load StrLine, StrLin
End If
End If
End If
Loop
Close #1
'*FH3_LINE,FH3_LINE ----XXX----XXX----XXX----XXX
End Sub
12、文件File
'''**** File ***********************************
Sub Myfile()
Dim StrFilename As String
StrFilename = \"C:\\Documents and Settings\\yb.LH\\桌面\\drawing2.dwg\"
ThisDrawing.Application.Documents.Open StrFilename
For I = 0 To ThisDrawing.Application.Documents.count - 1
MsgBox ThisDrawing.Application.Documents(I).Name
Next
ThisDrawing.Application.Documents(\"Drawing5.dwg\").Activate '''注意大小写
ThisDrawing.Application.Documents(\"Drawing2.dwg\").Save
ThisDrawing.Application.Documents(\"Drawing2.dwg\").SaveAs \"d:\\drawing2.dwg\"
ThisDrawing.Application.Documents(\"drawing2.dwg\").Close
End Sub
13、控制命令输入窗口SendCommand
'''****************************************************************************** Sub MySendCommand()
ThisDrawing.SendCommand Chr(13) '回车
ThisDrawing.SendCommand Chr(32) '空格
ThisDrawing.SendCommand Chr(27) 'ESC
ThisDrawing.SendCommand Chr(27) + \"Z E \"
ThisDrawing.SendCommand \"_line \"
ThisDrawing.SendCommand \"_pan \"
End Sub
14、三维绘图
Sub yb3DMap()
Dim pt(2) As Double, z As Double
Dim box As Acad3DSolid
pt(0) = 500
pt(1) = 500
pt(2) = -5
Set box = ThisDrawing.ModelSpace.AddBox(pt, 1500, 1500, 10)
box.color = acYellow
For I = 1 To 200
pt(0) = Rnd * 1000
pt(1) = Rnd * 1000
z = Int(Rnd * 300) + 50
pt(2) = z / 2#
Set box = ThisDrawing.ModelSpace.AddBox(pt, Abs(Rnd * 100) + 20, Abs(Rnd * 100) + 20, z)
box.color = Int(Rnd * 100)
Next
ZoomAll
ThisDrawing.SendCommand \"-view _seiso \"
ThisDrawing.SendCommand Chr(27)
ThisDrawing.SendCommand \"_3dcorbit \"
End Sub
3DMesh
Sub Example_Add3DMesh() ' This example creates a 4 X 4 polygonmesh in model space.
Dim meshObj As AcadPolygonMesh
Dim mSize, nSize, count As Integer
Dim points(0 To 47) As Double
'Create the matrix of points
points(0) = 0: points(1) = 0: points(2) = 0
points(3) = 2: points(4) = 0: points(5) = 1
points(6) = 4: points(7) = 0: points(8) = 0
points(9) = 6: points(10) = 0: points(11) = 1
points(12) = 0: points(13) = 2: points(14) = 0
points(15) = 2: points(16) = 2: points(17) = 1
points(18) = 4: points(19) = 2: points(20) = 0
points(21) = 6: points(22) = 2: points(23) = 1
points(24) = 0: points(25) = 4: points(26) = 0
points(27) = 2: points(28) = 4: points(29) = 1
points(30) = 4: points(31) = 4: points(32) = 0
points(33) = 6: points(34) = 4: points(35) = 0
points(36) = 0: points(37) = 6: points(38) = 0
points(39) = 2: points(40) = 6: points(41) = 1
points(42) = 4: points(43) = 6: points(44) = 0
points(45) = 6: points(46) = 6: points(47) = 0
mSize = 4: nSize = 4
'creates a 3Dmesh in model space
Set meshObj = ThisDrawing.ModelSpace.Add3DMesh(mSize, nSize, points)
'Change the viewing direction of the viewport to better see the polygonmesh
Dim NewDirection(0 To 2) As Double
NewDirection(0) = -1: NewDirection(1) = -1: NewDirection(2) = 1
ThisDrawing.ActiveViewport.Direction = NewDirection
ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport
ZoomAll
End Sub
15、块 (综合练习)
Sub MyBlock()
Dim MySS As AcadSelectionSet
Dim PntTxtSta(0 To 2) As Double, PntTxtEnd(0 To 2) As Double, DTxtAngle As Double '文字插入点,角度
Dim MyPln As AcadLWPolyline
Dim Str1 As String, Str2 As String
Dim StrLineType As String, DLineWidth As Double, LLineColor As Long '线型名称、宽度、颜色
Dim Pns As Variant, Pntsta As Variant, PntEnd As V ariant, Pntln(0 To 3) As Double
Dim ExpObj As Variant
Call DeleAllSelect '删除所有选择集
Set MySS = ThisDrawing.SelectionSets.Add(\"ssa\")
MySS.Select acSelectionSetAll
If MySS.count < 1 Then
Exit Sub
End If
For I = MySS.count - 1 To 0 Step -1
Str1 = MySS(I).ObjectName
If Str1 = \"AcDbBlockReference\" Then
ExpObj = MySS(I).Explode
MySS(I).Delete
For J = 0 To UBound(ExpObj)
Select Case ExpObj(J).ObjectName
Case \"AcDbPolyline\"
Pnts = ExpObj(J).Coordinates
ExpObj(J).Delete
Set MyPln = ThisDrawing.ModelSpace.AddLightWeightPolyline(Pnts)
I1 = UBound(Pnts)
For K = 0 To (I1 / 2 - 1) '宽度设定
MyPln.SetWidth K, DLineWidth, DLineWidth
Next
StrLineType = \"Continuous\"
LLineColor = 2
MyPln.LineType = StrLineType
MyPln.color = LLineColor
Case \"AcDbLine\"
Pntsta = ExpObj(J).StartPoint
PntEnd = ExpObj(J).EndPoint
Pntln(0) = Pntsta(0): Pntln(1) = Pntsta(1)
Pntln(2) = PntEnd(0): Pntln(3) = PntEnd(1)
Pnts = Pntln
ExpObj(J).Delete
Set MyPln =
ThisDrawing.ModelSpace.AddLightWeightPolyline(Pnts)
StrLineType = \"Continuous\"
LLineColor = 3
MyPln.LineType = StrLineType
MyPln.color = LLineColor
'宽度设定
MyPln.SetWidth 0, DLineWidth, DLineWidth
Case \"AcDbPoint\"
Pns = ExpObj(J).Coordinates
ExpObj(J).Delete
ThisDrawing.ModelSpace.AddPoint (Pns)
Case Else
ExpObj(J).Delete '其他如文字、点不再进行处理
End Select
Next
End If
'不是块的不处理
Next
End Sub
16、运行宏
‘’’-vbarun
Sub hong()
ThisDrawing.Application.RunMacro \"InsertRaster\"
End Sub
VB下的AutoCAD自动化一、概念
自动化技术允许一个应用程序驱动另外一个程序。驱动程序被称为自动化客户，另一个为自动化服务器。
VB环境下的AutoCAD自动化就是指用VB驱动和操纵AutoCAD。VB为自动化客户
端，AutoCAD为自动化服务器。
程序界面
**********************程序源代码***************************
Dim nn As Integer
Dim RS As Recordset
Private Sub CommandButton1_Click()
Dim I As Integer
Const PDBCN As String = \"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\"
Set PCN = New ADODB.Connection
Set RS = New ADODB.Recordset
PCN.Open PDBCN + \"C:\\Documents and Settings\\yb.LH\\桌面\\移动拟合法内插\\data1.mdb\"
RS.Open \"select * from DSMR\
Set Me.Adodc1.Recordset = RS
' Me.DataGrid1.DataSource = RS
nn = RS.RecordCount
If RS.RecordCount > 0 Then MSFlexGrid1.Rows = RS.RecordCount + 1 Else Exit Sub
Me.MSFlexGrid1.ColWidth(0) = 500
Me.MSFlexGrid1.ColAlignment(0) = 3
For I = 1 To 3
Me.MSFlexGrid1.ColWidth(I) = 2500
Me.MSFlexGrid1.ColAlignment(I) = 3
Next
Me.MSFlexGrid1.TextMatrix(0, 0) = \"点号\"
Me.MSFlexGrid1.TextMatrix(0, 1) = \"X\"
Me.MSFlexGrid1.TextMatrix(0, 2) = \"Y\"
Me.MSFlexGrid1.TextMatrix(0, 3) = \"Z\"
RS.MoveFirst
I = 0
Do While Not RS.EOF
I = I + 1
Me.MSFlexGrid1.TextMatrix(I, 0) = RS.Fields(\"ID\")
Me.MSFlexGrid1.TextMatrix(I, 1) = RS.Fields(\"X\")
Me.MSFlexGrid1.TextMatrix(I, 2) = RS.Fields(\"Y\")
Me.MSFlexGrid1.TextMatrix(I, 3) = RS.Fields(\"Z\")
RS.MoveNext
Loop
' RS.Close
CommandButton2_Click
End Sub
Private Sub CommandButton2_Click()
Dim meshObj As AcadPolygonMesh
Dim mSize, nSize, count As Integer
'Create the matrix of points
' For I = 0 To nn
mSize = Int(Sqr(nn) - 1): nSize = Int(Sqr(nn) - 1)
ReDim points(mSize * nSize * 3 - 1) As Double
因篇幅问题不能全部显示，请点此查看更多更全内容