6 地形图绘制.ppt

1、6 地形图图式符号库,线型 填充图案 形和字体,数字测图软件的地形图图式符号库, 是以国家标准图式为依据的图形数据库。 库的功能首先是各种地物符号的绘制, 其次是这些符号的组织、检索、管理和应用, 此外还必须提供对符号库本身进行增加、删除、修改等操作的维护功能, 以满足不同专业用户的需求。,对于不同的比例尺, 图式中有不同的规定, 这种不同可以体现在符号的类型图案以及依何种比例尺等方面。在一个完善的图式符号库中, 应包括不同比例尺的符号。除了国家标准外, 在铁路、电力等行业还制定有各自的部门标准, 它们主要是针对专业特点作了若干补充, 同时也可能带来符号分类体系的变化。随着测绘事业的发展, 图

2、式本身也存在更新的问题。所有这些都要求数字化成图软件的图式符号库能适应不同应用条件的变化, 应具有更新和调整功能。,1 图式符号库的设计,数字测图软件的图式符号库的设计方法应与其图形系统的实现方法相一致。对于具有独立图形系统的数字测图软件来说, 符号库的设计有两种方法: 沿用通用的CAD 图形软件的符号库系统, 并实现与之兼容的应用程序； 根据自己的图形数据结构和图形应用平台，开发专门的符号库结构和实现方法。,各种地形符号首先可分为三大类。 点状 线状 面状,1 图式符号库的设计,只有一个定位点, 对应一个固定的、不依比例 尺而变化的图形符号。根据朝向的不同, 点状符号又可分为垂直于南图廓和按

3、真实方向描绘两类。,(1)点状符号,其特点是符号依据定位线绘制。根据线划构成的复杂程度, 线状符号又分为: 比较简单的(简单线型) , 如简易公路、等级公路的边等；比较复杂的(复杂线型) , 如行树、围墙、高压电力线等。,(2)线状符号,(3)面状符号,其定位线要求构成封闭的区域,称为面状符号。根据区域内填充的不同,又可分成线填充方式(如特种房屋) 及点填充方式(如草地、树林),2 AutoCAD图式符号库的建立,基于AutoCAD 二次开发的测图软件, 一般都考虑在AutoCAD系统中利用AutoCAD 提供用户定义的图块(BLOCK)和填充(HATCH) 图案的功能建立图式符号库。,Aut

4、oCAD 中的图形元素称为实体, 图块是若干实体的集合, 并被赋予一个名称。该集合本身也成为一个实体, 可作为一个整体进行诸如插入、拷贝、移动、删除等操作。图块定义有一个插入点, 即定位点。,(1) 图块建立,例如制作三角点符号，在AutoCAD用Pline按照图式规定的大小绘制3mm边长的正三角形，用Point在三角形中心绘制一点，并设置为基点。用地形图图式编号“311”为文件名，存入符号库指定的目录中，这样就完成了三角点符号的制作。用类似的方法制作其它符号。下图为图式符号库中制作的部分常用地形图图式符号。,类似于围墙的地形图图式属于线形符号，例如栏栅、铁路、土堤、斜坡等，以及房屋、台阶等非

5、线形符号均可以设计成相应的自定义图形函数。为方便一系列自定义函数的调用，一般设计成下拉式菜单，点击后自动调用。对于个别函数可在AutoCAD命令行用“load”命令加载：（ load“路经、函数名” ），然后按函数名调用。,(2)线型定制,AutoCAD 提供了标准的填充模式库, 也允许建立用户自己的填充模式库, 因而能够为阵列式的面状符号（例如果园、竹林、草坪等）建库。,(3)符号填充,AutoCAD的二次开发技术,线型的开发与定制 图案的开发与定制 菜单的开发与定制 AutoLisp二次开发,线型及线型文件,系统提供一些标准线型，由ACAD.LIN库文件定义。 系统提供标准线型文件有两个，

6、acadiso.lin用于公制图形，acad.lin则用于英制图形。 标准线型分通用线型、ISO线型和复杂线型三类型。 简单线型： 包括通用线型和ISO标准线型，它是由实线段、点和空线段组成的。 复杂线型：除了包含简单线型的结构外，还包含了“形”和“文本”的定义。,1)线型定制,线型库文件定义了24种通用线型和14种标准线型。 通用线型 24种通用线型分为8类，每类有3种结构形式。分别用不同的实、空线段长度来区分。 线型名分为“类名”、“类名2”和“类名X2”， 基本形式，如BORDER 基本形式比例的0.5倍，如BORDER2 基本形式比例的2倍，如BORDERX2。,1.简单线型,通用线型

7、 *BORDER,Border _ _ . _ _ . _ _ . _ _ . _ _ . A, 12.7, -6.35, 12.7, -6.35, 0, -6.35 *BORDER2,Border (.5x) _._._._._._._._._._. A, 6.35, -3.175, 6.35, -3.175, 0, -3.175 *BORDERX2,Border (2x) _ _ . _ _ . A, 25.4, -12.7, 25.4, -12.7, 0, -12.7 *CENTER,Center _ _ _ _ _ _ _ _ _ A, 31.75, -6.35, 6.35, -6.3

8、5 *CENTER2,Center (.5x) _ _ _ _ _ _ _ _ _ A, 19.05, -3.175, 3.175, -3.175 *CENTERX2,Center (2x) _ _ _ _ A, 63.5, -12.7, 12.7, -12.7,标准线型 14种ISO线型，是按ISO128(ISO/DIS12011)标准设定，线的宽度均为1mm。,*ACAD_ISO02W100,ISOdash _ _ _ _ _ _ _ A,12,-3 *ACAD_ISO03W100,ISOdash space _ _ _ A,12,-18 *ACAD_ISO04W100,ISOlong-d

9、ash dot _ . _ . A,24,-3,0,-3 *ACAD_ISO05W100,ISOlong-dashdouble-dot _ . A,24,-3,0,-3,0,-3 *ACAD_ISO07W100,ISOdot . . . . . . . . . . . . A,0,-3,2 复杂线型 系统提供7种复杂线型。 复杂线型除具有简单线型的结构之外，还在线型之间夹杂有文字或特定的图形符号。,*FENCELINE1,Fenceline circle -0-0-0 A,6.35,-2.54,CIRC,ltypeshp.shx,x=-2.54,s=2.54,-2.54,25.4 *FENCE

10、LINE2,Fenceline square - A,6.35,-2.54,BOX,ltypeshp.shx,x=-2.54,s=2.54,-2.54,25.4 *TRACKS,Tracks -|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|- A,3.81,TRACK1,ltypeshp.shx,s=6.35,3.81 *BATTING,Batting SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS A,.00254,-2.54,BAT,ltypeshp.shx,x=-2.54,s=2.54,-5.08, BAT,ltypeshp

11、.shx,r=180,x=2.54,s=2.54,-2.54,3 CAD线型文件的格式 线型文件是一种ASCII码文件，一个线型文件可以定义多种线型。每一种线型的定义在线型文件中占两行。 第一行称为标题行 格式为：*线型名，线型说明 * ：标记符不能省略， 线型名：由多个符号组成，符号为字母、数字、 特殊符号和空格等。 标记符和线型名之间不允许有空格。 线型说明：可省略项，用文字说明或用符号表示； 若省略线型说明，线型名后面不加逗号； 线型说明部分长度不能超过47个字符。,定义简单线型 标题行：*线型名，线型说明 描述行：对齐方式码，dish1,dish2,dashn 对齐方式码: 定义线型的

12、对齐方式，目前只有一种对齐方式，即两端对齐方式，用A表示。 dish1,dish2,dashn： 指组成线型结构线段的长度。 其中 dish0 画一段长度为dish的实线段 dish=0 画一个圆点 dish0 画一段长度为dish的空线段,建立新线型(断层上盘线），从图中可以看出，该线型由一个1.5个单位长度和一个0.25个单位长度实线段，两个长度为0.25个单位的空线段。 把该线型取名为“XDHX”，其线型定义如下： *XDHX，新点划线 A,1.5,-0.25,0.25,-0.25 在描述行中，为节约字符，纯小数前导零可以省略。 *XDHX，新点划线 A,1.5,-0.25,0.25,-

13、0.25,定义复杂线型 复杂线型定义和简单线型的语法相似，只是在描述行增加嵌入文本字符或形形的描述。 复杂线型定义的格式如下： 标题行：*线型名，线型说明 描述行： 对齐方式码，dish1,dish2,嵌入文本字符或形说明,dashn 其中，嵌入文本字符的定义语法为： “文本字符”,文本式样名,R=n1,A=n2,S=n3,X=n4,Y=n5 嵌入形的定义语法为： 形名,形文件名,R=n1,A=n2,S=n3,X=n4,Y=n5,R、A、S、X和Y五个选择定义项，其含义如下： R=n1：文本或形相对当前线段方向的转角，度。 其缺省值为0，表示与所给线段方向一致。 A=n2：文本或形相X轴的绝对

14、转角。 可使其保持一种方向，指定A值，A=0，水平。 R和A不能同时指定，若都没指定，取R=0。 S=n3：确定文本或形的比例系数。 X=n4和Y=n5：确定相对于当前点的偏移量。 缺省时，文本或形的插入点放在此当前点。 n4：沿着当前线段方向偏移量， n40时和当前线段方向相同，n40时于该方向相同，n50时相反。,例1 定义含字符“X”的复杂线型来表示断层的下盘线 线型名为“XLINE”，其定义如下： *XLINE，-X-X- A,1.0,-.25,“X”,STANDARD,S=0.2,R=0,X=-0.1,Y=-0.1,-.25 例2 用图形“”来定义表示矿图中断层下盘线的线型 先建立一

15、个形文件“XXFH.SHP”把“”定义成形 形的名称为X，把文件编译存放在支撑目录下 线型名取为为“DCXPX”，其定义如下： *DCXPX，-X-X- A,1.0,-.25,X,XXFH.SHX,S=0.2,R=0,X=-0.1,Y=-0.1,-.25,2)填充图案,CAD的图案文件 AutoCAD系统为图案填充操作提供一个标准图案库文件，即ACAD.PAT。 文件提供实体填充和 50 多个符合工业标准的填充图案（可以表现泥土、砖或陶瓷等材质）。 文件提供 14 种符合 ISO（国际标准化组织）标准的填充图案。 当选择 ISO 图案时，可以指定笔宽。笔宽决定了图案中的线宽。,*ANSI31,

16、ANSI 铁、砖和石 45, 0, 0, 0, 3.175 *ANSI33,ANSI 青铜、黄铜和紫铜 45, 0, 0, 0, 6.35 *TRIANG,等边三角形 60,0,0,4.7625,8.24889,4.7625,-4.7625 120,0,0,4.7625,8.24889,4.7625,-4.7625 0,-2.38125,4.12445,4.7625,8.24889,4.7625,-4.7625,部分填充图案及其定义描述,图案的构成,其右边图形是用沉凝灰岩岩性符号图案填充的图形。 它是由左边的三种图案图形叠加以后形成的。 图案填充是由一簇或几簇有规律的图案线组成，每一簇图案线中

17、的各条线相互平行且线型相同。,图案的定义格式,图案文件是一个ASCII码文件 系统提供一个标准图案库文件，即ACAD.PAT。 用户可以扩充标准图案文件，或自己定义图案文件。 一个图案文件可以存放一个或多个图案的定义。 每一个图案定义有一个标题行，标题行之后有一个或多个定义行。 每一个图案的定义行定义了这个图案的一组平行线。 图案的定义如下： *图案名，图案描述说明 angle，x，y，del-x，del-y，d1，d2，,右图为泥岩及砂质泥岩的岩性符号填充图。从图中可看出，岩性符号的图案是由三条实线和一条点划线组成。 岩性符号的具体定义如下： *nyjsny,190 niyanjishazh

18、iniyan 0,0,0,0,.50 0,0,.08,0,.50 0,0,.16,0,.50 0,0,.25,0,.50,.25,-.50 0,.55,.25,.0,.5,0,0,-.76,其中：angle：基准图案线与X轴正向夹角(单位：度)。 x,y ：基准图案线经过的坐标点，一般为原点。 del-x：相邻内线间沿平行线本身方向上的位移量 del-y：相邻平行线之间的距离。 d1,d2：大于0代表一线段，小于0时表示间隔。,图案文件及图案库的建立,扩充和修改ACAD.PAT标准图案文件, 用文本编辑器调出ACAD.PAT文件，在该文件中插入自己的图案定义，然后存盘退出。 修改原有的图案定义

19、时，首先要找到该图案的定义处，直接修改其定义参数，然后存盘即可。 启动AutoCAD系统，可用新增或修改后的图案进行图案填充，图案的填充方法和AutoCAD中原标准图案的填充方法相同。,图案是由三个直线簇组成的，并且每个线簇都是虚线。这三个线簇分别是竖直的平行线簇，起始方向向下，即角度为270度，两个斜向平行线，,*Y,“Y”图案 270,0,0,.7071078,.7071078,.1875,-1.2267135 45,0,0,0,1,.1875,-.8125 135,0,0,0,1,.1875,-.8125,一个斜向右上，角度为45度，另一个斜向左下，角度为135度。根据各线簇之间的几何关

20、系，经计算写出该图案的定义如下：,1 制定岩性名称和图案名称对照表,每一种岩石类别都用一种图案符号来表示，因此，必须建立绘制岩性图案的岩性图例符号库。 在定义岩性图案时，建立一种岩石和一种图案形式对应关系， 构造岩石名称与其图案名称的对应表，,2 建立专用岩性符号图案文件,*ht,131 黄土 90,0,0,0,.125 *nt,132 粘土 0,0,0,.250,.500,.500,-.250 *sznt,1336 砂质粘土 0,0,0,.25,.25,.25,-.125,0,-.125 *fsy,188 粉砂岩 0,0,0,.25,-.5,0,-.125,0,-.5 0,.375,0,.2

21、5,-.5,0,-.125,0,-.5 *nzsy,189 泥质砂岩 0,0,0,.5,-.50,0,-.125,0,-.25,.25,-.25 *clsy,190 粗粒砂岩 0,0,0,.5,-.75,0,-.75 0,0,0,.5,-.75,0,-.75,练习,1按下图所示尺寸要求定义双短画线，定义线型的名称为“双短画线”，说明部分写sd两个字母。,练习,2定义如下图所示的填充图案，填充图案的名称为“3241-A”。,*3241-A 0,0,0,0,4,4,-4 0,4,2,0,8,4,-4 90,0,0,0,4,4,-4 90,2,4,0,8,4,-4,AutoCAD二次开发技术,明经通

22、道： ,推荐网站：,一、 AutoCAD VBA简介,VBA（Visual Basic for Application）,VBA是AutoCAD的一种开发工具，具有强大的功能。Microsoft VBA是一种面向对象的编程环境，它与VB一样具有很强的开发功能。VBA与VB之间的区别就是VBA AutoCAD在同一处理空间运行，为AutoCAD提供智能和快速的编程环境。,AutoCAD VBA开发的程序,VBA功能：,创建对话框和其它界面； 创建工具栏； 建立模块级宏指令； 提供建立类模块的功能； 具有完善的数据访问和管理能力；(ADO、DAO、RDO，C/S) 能够使用Win32API提供的功

23、能，建立应用程序与操作系统之间的通信；,在AutoCAD中使用VBA的好处,Visual Basic编程环境易学易用； VBA作为AutoCAD的一个过程运行，这使程序执行速度变得非常快； 对话框结构快速有效，允许开发者在设计时启动应用程序并能得到快速反馈；（易于代码纠错和维护） 对象可以独立出来，也可以嵌入AutoCAD图形。灵活性很强。,在工具菜单中选择宏-VBA管理器。 或者，在AutoCAD中调用VBAMAN命令。,你可以使用VBA管理器查看装载在当前AutoCAD进程的所有VBA工程。VBA管理器一个AutoCAD工具，它允许你装载、卸载、保存、创建、嵌入和分离VBA工程。,VBA管

24、理器,VBA管理器,在AutoCAD VBA界面中有许多不同类型的对象。例如: 图形对象，如线、弧、文本和标注都是对象； 样式设置，如线型和标注样式均为对象； 组织结构，如图层、组合和图块也是对象； 图形显示，如视图和视口都是对象； 甚至图形和AutoCAD应用程序本身也是对象。,对象是通过分层方式来组织的，应用程序对象为根对象。这种分层结构的视图被归结为对象模型。对象模型提供了你访问下一层对象的途径。,二、理解类和对象,对象模型视图,1.文档(Documents)集合 包含所有在当前AutoCAD进程打开的文档。 2.模型空间(ModelSpace)集合 包含在模型空间中的所有图形对象(图元

25、)。 3.图纸空间(PaperSpace)集合 包含在活动图纸空间布局中的所有图形对象(图元)。 4.图块(Block)对象 包含在指定图块定义中的所有图元。 5.图块(Blocks)集合 包含在图形中的所有图块。,6.字典(Dictionaries)集合 包含在图形中的所有字典。 7.标注样式(DimStyles)集合 包含在图形中的所有标注样式。 8.组合(Groups)集合 包含在图形中的所有组合。 9.超级链接(Hyperlinks)集合 包含提供图元的所有超级链接。 10.图层(Layers)集合 包含在图形中的所有图层。,11.布局(Layouts)集合 包含在图形中的所有布局。

26、12.线型(Linetypes)集合 包含在图形中的所有线型。 13.菜单条(MenuBar)集合 包含当前显示于AutoCAD的所有菜单。 14.菜单组(MenuGroups)集合 包含当前装载到AutoCAD中的所有菜单和工具栏。 15.注册应用程序(RegisteredApplications)集合 包含在图形中的所有注册的应用程序。,16.选择集(SelectionSets)集合 包含在图形中所有的选择集。 17.字型(TextStyles)集合 包含在图形中所有的文字样式。 18.UCSs 集合 包含在图形中所有的用户坐标系统(UCS)。 19.视图(Views)集合 包含在图形中所

27、有的视图。 20.视口(Viewports)集合 包含在图形中所有的视口。,每一对象都关联着属性和方法。属性描述着单个对象的外观，而方法是一种可在单个对象上执行的行为。当对象创建后，你就可通过属性和方法查询和编辑对象。 例如，一个圆对象有圆心属性。该属性以三维世界坐标系统的坐标描述了圆的圆心。更改圆的圆心，你只要简单地将该属性设定为新的坐标。圆对象也有称为偏移(Offset)的方法。该方法可在相对于现存圆的指定偏移距离创建一个新的对象。关于圆对象所有属性和方法的列表，请参考AutoCAD ActiveX和VBA参考中的圆对象。,三、理解对象的属性和方法,四 |开发例程,1、程序和文档窗口设置

28、2、视图 3、二维图形绘制 4、图层 5、用户输入 7、栅格图像 Raster 8、计算面积 9、加载菜单 10、增加菜单按钮和创建菜单按钮 11、加载线型 12、文件File 13、控制命令输入窗口SendCommand 14、三维绘图 15、块 (综合练习) 16、运行宏,1、程序和文档窗口设置 * Sub MyWindow() MsgBox ThisDrawing.WindowTitle = 杨彪绘图01 ThisDrawing.WindowState = acMin acMax acNorm End Sub Sub SetMyAcadTitle() Dim hw& hw = GetPa

29、rent(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.Wid

30、th = 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.Applic

31、ation.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 LightWeig

32、htPolyline Sub MyLightWeightPolyline () Dim MyPln As AcadLWPolyline Dim Pnts(9) As Double For I = 0 To 9 Pnts(I) = Rnd * 100 Next 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 MyP

33、ln.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

34、, 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, Solid, True) MyHatchObj.Appe

35、ndOuterLoop (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 河海大学土木工程学院测绘工程系 Set MyTxt = ThisDrawing.ModelSpace.AddText(StrTxt, VPnts, 100) MyTxt.color = acRed ZoomAll End Sub Sub MyPoint()

36、 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 = Fal

37、se For Each MyLay In ThisDrawing.Layers If MyLay.Name = ybNewLayer Then LayExit = True MsgBox MyLay.Name, vbInformation Next If LayExit Then MsgBox 图层：ybNewLayer 已经存在!, vbCritical Else ThisDrawing.Layers.Add ybNewLayer End If ThisDrawing.Layers(ybNewLayer).LayerOn = True ThisDrawing.Layers(ybNewLaye

38、r).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 + ThisDra

39、wing.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 = Y N ThisDrawing

40、.Utility.InitializeUserInput 1, KwordList StrTF = ThisDrawing.Utility.GetKeyword( 是否显示选点的坐标？(是 Y)/(否 N)：) If UCase(StrTF) = Y Then MsgBox 点 & Y= & VPn1(1) & : & Z= & VPn1(2), vbInformation Else End If ThisDrawing.Utility.GetEntity Obj1, Pnt1, 选择一个对象： Obj1.color = 1 End Sub Sub MyZoomView3() Str1 = T

41、hisDrawing.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.Selec

42、tionSets.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.co

43、unt 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.Acti

44、veDocument.Layers.Add(底图) PicFileName = E:图片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 E:yangbiao.dwg End Sub,8、计算面积

45、 *计算面积* Sub Ch3_CalculateDefinedArea() Dim p1 As Variant ,p2 As Variant , p3 As Variant , p4 As Variant, p5 As Variant 从用户处取得点 p1 = ThisDrawing.Utility.getpoint(, vbCrLf & 第一个点: ) p2 = ThisDrawing.Utility.getpoint(p1, vbCrLf & 第二个点: ) p3 = ThisDrawing.Utility.getpoint(p2, vbCrLf & 第三个点: ) p4 = ThisD

46、rawing.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) vert

47、ices(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()

48、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 AcadPopupMen

49、u Dim acMenuItem As AcadPopupMenuItem Dim NewacMenu As AcadPopupMenuItem Set acMenu = acApp.MenuGroups(0).Menus(文件(&F) Set acMenuItem = acMenu.AddMenuItem(0, 杨彪, ._OPEN ) Set acMenuItem = acMenu.AddMenuItem(0, 杨彪4, -vbarun showpic2 ) Set acMenu = ThisDrawing.Application.MenuGroups(0).Menus.Add(杨彪111

50、) Set acMenuItem = acMenu.AddMenuItem(0, 放大, .Z 1.5XP ) Set acMenuItem = acMenu.AddMenuItem(1, 缩小, .Z 0.7XP ) Set acMenuItem = acMenu.AddMenuItem(2, 全景显示, .Z A ) Set acMenuItem = acMenu.AddMenuItem(3, 最大显示, .Z E ) Set acMenuItem = acMenu.AddMenuItem(4, 鸟瞰, ._DISVIEWER ) Set acMenuItem = acMenu.AddMe

51、nuItem(5, 移动, .PAN ) acMenu.InsertInMenuBar 10 acApp.MenuGroups(0).SaveAs d:MyMenu.mnu, 1 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 acTo

52、olbar = ThisDrawing.Application.MenuGroups(0).Toolbars(常用) Set ToolbarItem = acToolbar.AddToolbarButton(0, 杨彪22, help1, ._OPEN ) Call ToolbarItem.SetBitmaps(E:图标1.ico, E:图标2.ico) Set ToolbarItem = acToolbar.AddToolbarButton(0, 杨彪124, help2, -vbarun showpic2 ) Set acToolbar = ThisDrawing.Application.

53、MenuGroups(0).Toolbars.Add(杨彪1111) Set ToolbarItem = acToolbar.AddToolbarButton(0, 放大, help3, .Z 1.5XP ) Call ToolbarItem.SetBitmaps(E:图标3.ico, E:图标3.ico) Set ToolbarItem = acToolbar.AddToolbarButton(1, 缩小, help4, .Z 0.7XP ) Call ToolbarItem.SetBitmaps(E:图标4.bmp, E:图标4.bmp) Set ToolbarItem = acToolb

54、ar.AddToolbarButton(2, 全景显示, help5, .Z A ) Set ToolbarItem = acToolbar.AddToolbarButton(3, 最大显示, help6, .layer ) Call ToolbarItem.SetBitmaps(E:图标5.ico, E:图标5.ico) acToolbar.Visible = True acApp.MenuGroups(0).SaveAs d:mymenu.mnu, 1 End Sub,11、加载线型 加载线型的子程序 Sub MLoadLineTypes() Dim BL0 As Boolean, I A

55、s Integer, ILen As Integer, Str1 As String, StrLine As String DIM StrLin As String StrLin = ThisDrawing.Application.Path + Support + DZBL.lin If Dir(StrLin) = Then MsgBox 没有找到线型文件 + StrLin + 不能进行操作, vbInformation, 错误 End End If Open StrLin For Input As #1 Do While Not EOF(1) Line Input #1, StrLine S

56、trLine = 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) = , Then Exit For Next StrLine = Mid(StrLine, 2, I - 2) BL0 = False Call LineTypeExist(StrLine, BL0) If Not BL0 Then ThisDrawing.Linetypes.Load StrLine, St

57、rLin线型不存在则加载 End If: End If Loop Close #1 End Sub,12、文件File * File * Sub Myfile() Dim StrFilename As String StrFilename = C:Documents and Settingsyb.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.Ap