CAD - VBA

AutoCAD VBA

一、AutoCAD VBA简介

?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应用程序本身也是对象。对象是通过分层方式来组织

的，应用程序对象为根对象。这种分层结构的视图被归结为对象模型。对象模型提供了你访问下一层对象的途径。

AutoCAD Application3DFace3DPolyPreferencesDocuments3DSolidArcAttributeDocumentBlocksBlocksDocumentAttributeRefBlockrefCircleDim3PointAngularDimAlignedModelSpacePaperSpacePViewPortDictionariesDictionarieHyperLinksDimAngularHyperLinkDimDiametricDimOrdinateDimRadialXRecordDimRotatedDimStylesGroupsLayersLayoutsLineTypesplotConfigurationsRigisteredAppsSelectionSetsViewPortsTextStylesUCSsViewsDatabasePreferencesDimStyleGroupLayerLayoutEllipseExternalReferenceHatchLeaderLightWeightPolylineLineTypeplotConfigurationRigisteredAppSelectionSetViewPortLineMInsertBlockMLineMtextPointPolygonFaceMeshTextStyleUCSViewPolylinePolygonMeshRasterRayRegionPlotUtilityPopupMenusPopupMenuPopupMenuItemshapeSolidSPlineTextToleranceMenuBarPopupMenuMenuGroupsMenuGroupToolBarsToolBarsTraceToolBarItemXLine 集合对象是预先定义的对象，它包含所有相似对象的实例(即这些对象的父对象)。集合对象有以下的对象：

文档(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、视图

'''************************************************************************** Sub MyZoomView1()

ThisDrawing.Application.ZoomExtents ZoomAll End Sub

Sub MyZoomView2()

Dim VPn1 As Variant, VPn2 As Variant

VPn1 = ThisDrawing.Utility.getpoint(, \缩放窗口左下点：\ VPn2 = ThisDrawing.Utility.getpoint(, \缩放窗口右上点：\ ThisDrawing.Application.ZoomWindow VPn1, VPn2 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

‘LightCircle 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 = \河海大学土木工程学院测绘工程系\ 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 = \ MsgBox MyLay.Name, vbInformation Next

If LayExit Then

MsgBox \图层：'ybNewLayer' 已经存在!\ Else

ThisDrawing.Layers.Add \ End If

ThisDrawing.Layers(\

ThisDrawing.Layers(\

ThisDrawing.ActiveLayer = ThisDrawing.Layers(\ 'obj.Layer = \

ThisDrawing.Layers(\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、用户输入

'''*********************************************************************** Sub 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, \请输入点号：\

KwordList = \ N\

ThisDrawing.Utility.InitializeUserInput 1, KwordList

StrTF = ThisDrawing.Utility.GetKeyword(\是否显示选点的坐标？(是 Y)/(否 N)：\

If UCase(StrTF) = \

MsgBox \点\：\\ 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(\' Set ssetObj = ThisDrawing.ActiveSelectionSet ssetObj.Select acSelectionSetAll If ssetObj.count > 0 Then

MsgBox \选择集中对象数目: \ 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 = \图片\\Bliss.jpg\ b(0) = 100 b(1) = 100 b(2) = 0

Set a = ThisDrawing.Application.ActiveDocument.ModelSpace.AddRaster(PicFileName, b, factor, 45)

a.Transparency = True a.Layer = \底图\

ThisDrawing.Application.ZoomExtents ThisDrawing.SaveAs \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(\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 \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(\图标\\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(\图标\\3.ico\图标\\3.ico\

Set ToolbarItem = acToolbar.AddToolbarButton(1, \缩小\ Call ToolbarItem.SetBitmaps(\图标\\4.bmp\图标\\4.bmp\

Set ToolbarItem = acToolbar.AddToolbarButton(2, \全景显示\ \

Set ToolbarItem = acToolbar.AddToolbarButton(3, \最大显示\ Call ToolbarItem.SetBitmaps(\图标\\5.ico\图标\\5.ico\

acToolbar.Visible = True

acApp.MenuGroups(0).SaveAs \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 + \ If Dir(StrLin) = \

MsgBox \没有找到线型文件\不能进行操作\错误\ 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 = \

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 = \桌面\\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(\ '''注意大小写

ThisDrawing.Application.Documents(\

ThisDrawing.Application.Documents(\ ThisDrawing.Application.Documents(\End Sub

13、控制命令输入窗口SendCommand

'''****************************************************************************** Sub MySendCommand()

ThisDrawing.SendCommand Chr(13) '回车 ThisDrawing.SendCommand Chr(32) '空格 ThisDrawing.SendCommand Chr(27) 'ESC

ThisDrawing.SendCommand Chr(27) + \

ThisDrawing.SendCommand \ \ThisDrawing.SendCommand \ \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 \ ThisDrawing.SendCommand Chr(27) ThisDrawing.SendCommand \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 Variant, Pntln(0 To 3) As Double Dim ExpObj As Variant

Call DeleAllSelect '删除所有选择集

Set MySS = ThisDrawing.SelectionSets.Add(\ 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 = \ ExpObj = MySS(I).Explode MySS(I).Delete

For J = 0 To UBound(ExpObj)

Select Case ExpObj(J).ObjectName

Case \

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 = \ LLineColor = 2

MyPln.LineType = StrLineType

MyPln.color = LLineColor

Case \

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 = \LLineColor = 3

MyPln.LineType = StrLineType MyPln.color = LLineColor '宽度设定

MyPln.SetWidth 0, DLineWidth, DLineWidth

Case \

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 \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 = \

Set PCN = New ADODB.Connection

Set RS = New ADODB.Recordset

PCN.Open PDBCN + \and Settings\\yb.LH\\桌面\\移动拟合法内插\\data1.mdb\

RS.Open \ 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) = \ Me.MSFlexGrid1.TextMatrix(0, 2) = \ Me.MSFlexGrid1.TextMatrix(0, 3) = \

RS.MoveFirst I = 0

Do While Not RS.EOF I = I + 1

Me.MSFlexGrid1.TextMatrix(I, 0) = RS.Fields(\ Me.MSFlexGrid1.TextMatrix(I, 1) = RS.Fields(\ Me.MSFlexGrid1.TextMatrix(I, 2) = RS.Fields(\ Me.MSFlexGrid1.TextMatrix(I, 3) = RS.Fields(\ 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

If RS.RecordCount > 0 Then RS.MoveFirst

For I = 0 To mSize - 1 For J = 0 To nSize - 1

points((I * nSize + J) * 3) = I: points((I * nSize + J) * 3 + 1) = J: points((I * nSize + J) * 3 + 2) = RS.Fields(\ RS.MoveNext Next Next

'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

Private Sub CommandButton3_Click()

ThisDrawing.SendCommand Chr(27) + Chr(27) ThisDrawing.SendCommand \ ThisDrawing.Regen acActiveViewport End Sub

Private Sub CommandButton4_Click()

ThisDrawing.SendCommand Chr(27) + Chr(27) ThisDrawing.SendCommand \ ThisDrawing.Regen acActiveViewport End Sub

Private Sub CommandButton5_Click() Unload Me End Sub

**********************程序源代码***************************

本文来源：https://www.bwwdw.com/article/dror.html