您的位置：360文档中心› AutoCAD二次开发(VBA)测绘篇

AutoCAD二次开发(VBA)测绘篇

合集下载

VBA的二次开发在工程测绘中的应用

VBA的二次开发在工程测绘中的应用

ＶＢＡ的二次开发在工程测绘中的应用［摘要］本文主要阐述了利用WORD VBA(Visual Basic for Applications)开发应用于工程测绘软件的思路和方法。

［关键字］VBA AUTOCAD 动态链接库一、前言在工程测绘内业处理过程中常需对WORD表格数据、AUTOCAD图形数据进行交换处理，原手工编辑方法不仅工作效率低，且易出现人为错误。

结合日常工作需要，笔者对WORD、AUTOCAD自身编程语言VBA的功能进行了二次开发，利用VBA编写的宏自动地实现了WORD表格数据与CAD图形数据的转换，既提高了工作效率，减轻了技术人员的劳动强度，又提升了工程测绘的数字化作业水平。

二、利用word的VBA进行二次开发用WORD VBA编写宏自动实现控制点坐标（表格数据）在CAD中展点、转换成.coo（.cor）文件等功能。

然后再利用WORD的新建工具栏，将相关功能加入到工具栏中。

（一）基本功能1、在CAD中展点将表格数据直接转换成CAD图形数据2、将word表格数据转换成测量常用文件（*.COO、*.COR）（二）实现步骤1、引用ACAD2000动态链接库（acad.tlb）。

2、在程序中定义对象Dim acadObj As AcadApplication …定义对象Dim jzpoint As AcadPoint …定义点对象Dim mylayer As AcadLayer …定义图层对象3、利用GetObject（）或CreateObject（）命令直接调用CAD4、在cad中增加图层（Layers.Add）5、读入表格中数据6、展点---三维点坐标转换成.cor文件演示程序如下：Sub 三维点转cor()‟Dim i As IntegerDim xyz(2) As Double …用于存放点的X、Y、Z坐标Dim mystr As String …用于图层名Dim fso As FileSystemObjectDim fl As TextStreami = 0z = 0mystr = InputBox(“请输入文件名”, “提示”)mystr = “c:\” & mystr + “.cor”Set f so = CreateObject(“Scripting.FileSystemObject”)Set fl = fso.OpenTextFile(mystr, ForAppending, True)For Each c In Selection.CellsIf i = 0 Thentextstr = Trim(c.Range)‟读入点号textstr = Left(textstr, Len(textstr) - 2)ElseIf i = 1 Thenxyz(1) = Val(c.Range) …读入X坐标ElseIf i = 2 Thenxyz(0) = Val(c.Range)‟读入Y坐标ElseIf i = 3 Thenxyz(2) = Val(c.Range)‟读入Z坐标…z = z + 1fl.WriteLine z & “,” & textstr & “,” & “ “ & “,” & xyz(1) & “,” & xyz(0) & “,” & xyz(2)i = -1End Ifi = i + 1Next cSet fl = NothingSet fso = NothingEnd Sub三、利用AUTOCAD的VBA进行二次开发用AUTOCAD VBA编写宏命令实现图形数据文件自动生成WORD表格文档。

VBA在AutoCAD中的二次开发

VBA在AutoCAD中的二次开发

VBA在AutoCAD中的二次开发
吴利明;李金勇
【期刊名称】《湘南学院学报》
【年(卷),期】2010(031)002
【摘要】利用VBA强大的编程功能,测量AutoCAD图形中线段的长度,并输出至Excel.
【总页数】3页(P77-79)
【作者】吴利明;李金勇
【作者单位】中国联合工程公司,能源与环境工程公司,浙江,杭州,310022;中国联合工程公司,能源与环境工程公司,浙江,杭州,310022
【正文语种】中文
【中图分类】TP311.52
【相关文献】
1.基于VBA的AutoCAD二次开发在图纸明细表中的应用 [J], 任中海
2.AutoCAD的二次开发软件VBA在数控铣一体化教学中的应用 [J], 罗萍;罗惠
3.AutoCAD中用VBA进行二次开发在工程测量中的应用 [J], 王怀球;蒋月姣
4.AutoCAD中用VBA进行二次开发在工程测量中的应用 [J], 王怀球;蒋月姣
5.VBA对AutoCAD二次开发在巷道断面设计中的研究与应用 [J], 李明栋
因版权原因，仅展示原文概要，查看原文内容请购买。

利用VBA对AutoCAD二次开发在矿山测量中的应用

利用VBA对AutoCAD二次开发在矿山测量中的应用

利用VBA对AutoCAD二次开发在矿山测量中的应用摘要：本文通过对AutoCAD绘图软件、二次开发语言VBA的介绍，以及分析矿山测量在制图时对AutoCAD的需求，阐述利用VBA对AutoCAD二次开发在矿山测量中的应用。

关键词：AutoCAD；VBA；二次开发；矿山测量1关于AutoCAD、VBA1.1介绍AutoCAD、VBAAutoCAD（Auto Computer Aided Design）是美国Autodesk公司首次于1982年研究开发的计算机辅助设计软件，是目前国际上应用最流行的绘图工具，功能全面，操作稳定，普适性强，广泛用于二维绘图、详细绘制，深受各行各业设计者和工程技术人员的喜爱。

与此同时，高普适性也对应着AutoCAD另一大特点：开放的结构体系。

这种开放体系，使得不同行业、专业根据自身的特点能够对其进行Autodesk二次开发，可以说AutoCAD的普适性为其二次开发提供了必要条件，从而也弥补了其专业针对性能不强的弱点。

从AutoCAD R14.01版开始，Autodesk在AutoCAD中加入了VBA（Visual Basic for Applications），作为AutoCAD的一种二次开发工具。

VBA是一种完全面向对象体系结构的编程语言，是Visual Basic的一种宏语言，与VB有着相似的语言结构和开发环境。

在VBA中，AutoCAD通过AetiveX提供了一个沟通外部世界的机制，使得AutoCAD通过不同的编程语言和环境进行二次开发。

可见，VBA是通过ActiveX接口建立与AutoCAD对象之间的联系，在AutoCAD和Visual Basic之间搭建起起了一座桥梁，将其完美的融合在一起，创造出符合用户要求的程序，形成新的功能性强、灵活性高的软件。

1.2利用VBA对AutoCAD进行二次开发的优点VBA与其他AutoCAD二次开发技术相比，优点有很多：VB语言基础广泛。

AutoCAD二次开发技术在工程测绘制图中的应用

AutoCAD二次开发技术在工程测绘制图中的应用

AutoCAD二次开发技术在工程测绘制图中的应用摘要:简要介绍了进行AutoCAD二次开发的常用方法和技术特点,并以实例说明了利用VBA实现AutoCAD二次开发的实际价值和意义。

关键词: AutoCAD二次开发VBA 工程测绘制图坐标标注随着现代科学技术的迅猛发展，测绘科学也发生了翻天覆地的变化，测绘仪器和测绘技术都有了很大的发展，测绘仪器由原来的光学仪器、机械仪器发展到了电子仪器，图形绘制由铅笔平板仪绘制发展到计算机软件绘制。

电子仪器可通过专用传输线与计算机直接连接，把野外所采集的数据传输进计算机，在计算机中进行数字化成图。

以手工作业为主的测量内业计算与绘图工作已经可以通过电子仪器、计算机绘图仪完成。

数字化成图已经成为测图发展的主流方向。

目前市场上的数字成图软件有很多，测绘行业普遍使用的有南方测绘公司的CASS 系列、广州开思公司的SCS 系列，还有北京微远图公司的SV300 系列等软件,这些软件多是以AutoCAD为平台开发的, 它们主要针对的是测绘行业的通用性需求,在大体框架上基本满足了地形图、地籍图等测绘工作的成图要求。

但测绘性质的多样性，决定了不可能有适合所有测绘性质的数字成图软件，在实际工作中,一些制图工作在许多细节上的操作具有特殊性，并且随测绘性质和目的的不同而有所不同。

而且每个测绘员又各有各的工作方式和习惯.这些通用软件对一些特殊性质的处理控制和专业性强的特殊要求就不能满足了，怎样解决这个问题和要求,使数字化成图软件更符合自己工作要求呢?下面针对本单位经常进行的工程测量成图工作中遇到的问题,介绍解决基本方法与过程。

一.AutoCAD及二次开发简介1. AutoCADAutoCAD是美国Autodesk 公司开发的一个交互式绘图软件，具有开放的极其灵活的体系结构，它允许用户和开发者采用各种方法对其进行定制、扩充和修改，即用户自己可以对进行二次开发,能最大限度地满足用户的特殊要求。

AutoCAD2000VBA二次开发方法

AutoCAD2000VBA二次开发方法

A u toCAD 2000VBA 二次开发方法白海清Κ彭玉海;陕西工学院机电系Κ陕西汉中723003ΓD evelopm en t of A u toCAD U sed VBABA I Ha i q i ng ΚPENG Y u ha i;D epartm en t of M echan ical &E lectrical ΚShanx i In stitu te of T echno logy ΚH anzhong 723003ΚCh ina Γ 摘要Π介绍了在A u toCAD 2000下利用VBA 二次开发的方法、技巧和关键技术Κ并通过联轴器的参数化绘图详细阐述了利用VBA 实现参数化设计的步骤及关键技术Λ关键词ΠA u toCAD Μ二次开发ΜVBA中图分类号ΠT P 311.52文献标识码ΠB文章编号Π1001-2257;2002Γ02-0065-03Abstract ΠT h is p ap er in troduces a ob ject o ri 2en ted developm en t too l of A u toCAD 2000based on VBA Κand exp atiates the key techno logy and step of developm en t u sed VBA by an app licati on exam 2p le to draw the w o rk ing draw ing of coup ling .Key words ΠA u toCAD Μdevelopm en t ΜVBA收稿日期Π2001-11-190　引言对A u toCAD 的二次开发可以通过A ctiveX 来实现ΚA ctiveX 是微软公司提出的一个基于COM ;com ponen t ob ject m odel Γ的技术标准Λ应用A u to 2CAD A ctiveX 技术Κ用户可以利用VB 、VBA 等外部或内部程序来操作A u toCAD 暴露的对象Λ在A u toCAD 2000中Κ几乎对外暴露了所有对象Κ包括图形实体对象;如直线、圆ΓΚ样式设置对象;如线型、文本样式ΓΚ组织结构对象;如层、块ΓΚ图形显示对象;如视图、视图区Γ以及菜单、工具栏等Κ也就是说用户可以操作几乎所有的A u toCAD 对象ΛVBA ;visual basic fo r app licati on Γ由V isualB asic 派生而来Κ现在已经成为M icro soft 产品的标准语言Λ与VB 一样ΚVBA 是面向对象的程序设计语言Κ它继承了VB 语法简单、功能强大的特点Κ同时Κ由于VBA 可与主程序在同一内存空间内运行Κ大大提高了运行速度Κ并具有一定的:智能Φ功能Λ在A u toCAD 2000中Κ已经集成功能强大、易学易用的VBA 5.0程序开发环境Κ且提供了高质量的用户化编程能力Λ1　VBA 开发方法及关键技术1.1　AutoCAD ActiveX 对象的使用任何一个具有明确内涵的事物均可以称之为对象Κ如A u toCAD 应用程序Κ图形文件以及图形内的任何实体都是一种对象Κ对象是用类定义的Λ1.1.1　A u toCAD 2000对象模型A u toCAD 2000应用程序公开的对象很多Κ每个对象都代表了A u toCAD 应用程序的一部分Λ图形实体对象Π如直线;line ΓΚ圆;circle Γ等Μ样式设置对象Π如线型;linetyp e Γ等Μ组织结构对象Π如层;layer ΓΚ块;b lock Γ等Μ图形显示对象Π如视图;view ΓΚ视图区;view po rt Γ等Λ这些对象按照从属关系Κ有层次地组织在一起Κ就形成了A u toCAD 2000对象模型Λ1.1.2　对象的访问;引用ΓVBA 访问A u toCAD 2000对象的原则是按照对象模型进行访问ΛVBA 提供了一个特殊的对象—T h is D raw ing Κ它是A u toCAD VBA 的一个术语Κ代表当前打开的A u toCAD 图形文件Λ例ΠD i m M yline A s A cadL ine 9定义应用直线的变量Set M yline =T h is D raw ing .M odelSp ace .Item ;0Γ9应用这个直线;假设该直线是第1个实体Γ1.2　实体对象的创建与编辑在创建实体对象之前Κ要确定实体将放于何处Κ即是模型空间、图纸空间Κ还是存放在块中Λ不论在哪个对象中创建实体Κ都要先引用这个对象Λ・56・=机械与电子Ι2002;2Γ1.2.1　创建基本实体用A ddEn titynam e形式的方法Κ即:创建;A ddΓΦ+:实体名字;En tityN am eΓΦΛ例如下面语句在模型空间创建一个圆Κ圆心为;0Κ0Κ0ΓΚ半径为10ΛD i m cp;0To2ΓA s Doub lecp;0Γ=0Πcp;1Γ=0Πcp;2Γ=0Call T h is D raw ing.M odelSp ace.A ddC ircle;cpΚ10#Γ1.2.2　实体对象的编辑实体编辑是VBA编辑中最常用的操作Κ这些编辑操作包括复制、移动、删除等Λ同样Κ在编辑对象前必须对其引用Λ例Π将模型空间的第一个实体进行复制ΛD i m M yO b ject A s O b jectD i m retO b ject A s V arian tSet M yO b ject=T h is D raw ing.M odelSp ace;0ΓretO b ject=T h is D raw ing.Cop yO b jects;M y2 O b jectΓ1.3　工具栏和菜单的定制1.3.1　创建和编辑菜单A u toCAD A ctiveX可以定制两种类型的菜单Π下拉菜单和快捷菜单Λ创建一个下拉菜单是用A dd 方法将一个新的菜单对象添加到菜单集合中Λ例ΠD i m cu rr M enuGroup A s A cad M enuGroup　9定义菜单组对象变量Set cu rr M enuGroup=T h is D raw ing.A pp lica2 ti on.M enuGroup s.Item;0Γ　9对变量赋值D i m newM enu A s A cadPop upM enuSet newM enu=cu rr M enuGroup.M enu s.A dd ;:联轴器ΦΓ　9创建新菜单:联轴器Φ1.3.2　工具栏的创建与编辑通过A u toCAD A ctiveX技术Κ用户同样可以创建和编辑工具栏Λ用A dd方法可以向工具栏集合中添加新的工具栏Λ例Π创建一个名为:Coup lingΦ的工具栏ΠD i m cu rr M enuGroup A s A cad M enuGroupSet cu rr M enuGroup=T h is D raw ing.A pp lica2 ti on.M enuGroup s.Item;0ΓD i m new Too l B ar A s A cadToo l B arSet new Too l B ar=cu rr M enuGroup.Too l B ars.A dd;:Coup lingΦΓ以上是A u toCAD二次开发时用到的主要方法和技术Λ2　应用实例使用A u toCAD2000VBA二次开发技术Κ实现通用机械零件联轴器的参数化绘制Λ绘制时先创建一个块Κ在块中绘制联轴器Κ并使其可以随意拖动和定位Λ加载后在A u toCAD:绘制Φ菜单下增加一下拉菜单项:联轴器ΦΚ快捷菜单中增加菜单项:联轴器ΦΚ工具栏上增加一工具栏Λ2.1　设计窗体界面在A u toCAD命令行键入:VBA I D EΦ进入VBA 综合开发环境Κ在:插入Φ菜单下选择:添加用户窗体ΦΚ系统将显示一个空白窗体和控件工具箱Λ用户根据自己的愿望进行窗体设计Λ笔者开发的联轴器绘制窗体如图1所示Λ图1　联轴器绘制窗体2.2　编写程序代码按照VBA的编程方法为每一个对象编写相应代码Κ实现所要求的界面和联轴器的参数化绘制Λ这里仅介绍在A u toCAD的:绘图Φ菜单添加下拉菜单项:联轴器Φ的程序代码ΛPub lic Sub addm enu;O p ti onal a A s B yteΓ O n E rro r R esum e N ex t D i m oA cad A s A cadA pp licati on Set oA cad=T h is D raw ing.A pp licati on D i m oPop up A s A cadPop upM enu D i m oSubPop up A s A cadPop upM enu Item Fo r Each oPop up In oA cad.M enuB ar ‘tagstring is no t localized so u se it to locate the m enu D i m op enm acro A s String op enm acro=Ch r;3Γ+Ch r;3Γ+Ch r ;95Γ+:-vbarunΦ+Ch r;32Γ+:coup lingΦ+Ch r ;32Γ・66・=机械与电子Ι2002;2Γ If oPop up.T agString="I D M nD raw" T hen Set oSubPop up=oPop up.A dd M enu2 Item;0Κ"联轴器;&ZΓ"Κop enm acroΓ End IfN ex tEnd Sub3　结束语用内嵌VBA二次开发A u toCAD2000的方法简单、编程容易Κ并且运行速度较快ΛVBA具有如下特点Πa.VBA能够使A u toCAD与其它应用程序直接共享数据Λb.在VBA综合开发环境中Κ可以通过拖动图标的方法Κ简单而可视化地建立用户界面Λ用户可以使用A u toCAD工具栏Κ也可以使用标准VBA界面工具创建新的工具栏Λc.VBA的语言代码完全继承了VB的特征Κ编程语言简单Λd.具有开放式的对象模型Κ用户可以按照自己的愿望编程或定制A u toCAD2000软件Λe.具有良好的运行速度ΛVBA是一个内嵌式的控制器Κ共享A u toCAD的内存空间Κ其运行速度比其它开发方式;如AD S、L ispΓ要提高许多Λ利用VBA二次开发的技术Κ工程设计人员可以定制A u toCADΚ把用到的标准件象联轴器的参数化绘制一样Κ全部实现自动选取Κ因而大大地提高了设计效率Λ参考文献Π[1]　李晓明Κ等.A u toCAD2000使用与开发指南[M].北京Π国防工业出版社Κ2000.[2]　张国宝.A u toCAD2000VBA开发技术[M].北京Π清华大学出版社Κ2000.[3]　徐　灏.机械设计手册4;第二版Γ[M].北京Π机械工业出版社Κ2000.[4]　D ietm ar R udo lph.A u toCAD2000对象开发从入门到精通[M].曾　琦Κ等译.北京Π电子工业出版社Κ2000.作者简介Π白海清　;1970—ΓΚ男Κ陕西省榆林市人Κ机械设计制造及其自动化教研室主任Κ主要从事先进制造技术及机电一体化技术的研究ΛM A ST ER K系列可编程控制器在牧草打捆机上的应用 牧草打捆机一般是由液压系统来实现作业的Κ即先将料槽里已经称量好重量的牧草推入打捆机压缩箱内Κ封箱;上盖油缸前进ΓΜ然后主压油缸推动活塞在压缩箱内前进挤压牧草Κ达到设定位置挤压动作停止Μ再由推出油缸将草捆横向推出压缩箱Μ接下来3个油缸按前进顺序的逆顺序退回原位Κ即完成了一个工作循环Λ国内绝大多数打捆机的电气控制为手工控制Κ即由操作工人按工作顺序点动一系列按扭来完成打捆机的基本动作Λ这种操作不仅浪费人力、动作精度不好保证Κ而且极易出错Κ工作效率低Λ为使打捆机在正常工作时能够实现全自动化Κ提高工作效率和精度Κ我们在设计打捆机时Κ考虑到产品的造价和实际工作需要Κ把装料进压缩箱这一动作设计由人工来完成Κ从封箱开始到回位共6个动作为自动循环Λ电气控制部分Κ将M K系列可编程控制器;PL CΓ作为控制核心Κ使打捆机可实现全自动控制、点动控制、手动顺序控制以及行程开关调整控制ΛM K系列可编程控制器;PL CΓ是L G公司的产品Κ该产品除具备PL C共有的可靠性高、柔性好、功能强大、使用方便、体积小、能耗低等特点外Κ还可识别梯形图程序Κ编程简便Κ可直接在个人计算机上用其附带软件进行编程、编好的程序可用232电缆由计算机的通信口直接传送进PL CΚ可用一些简单的触发开关代替实际的触发信号在计算机上模拟运行程序Κ调试、修改程序非常方便Λ由于PL C内部设有若干:软继电器ΦΚ因此Κ在输出电路里不需要给每个液压系统的电磁阀设置一个继电器Κ这样也大大简化了外电路的结构Κ给电气系统的检修带来了极大的方便Κ使整个电气系统的可靠性大大提高Λ经实际使用证明Κ将PL C用于国产打捆机控制系统效果良好Κ是一种方便可行的方法Λ;黑龙江八一农垦大学食品学院　李大鹏Γ・76・=机械与电子Ι2002;2Γ。

cad平台上测绘中VBA展野外点点号和方位角

cad平台上测绘中VBA展野外点点号和方位角

下面就是自动在AutoCAD中画点的Visual Basic程序代码(部分),最后将其制作成可执行文件(e: \展点.exe)供AutoCAD菜单宏调用。

假若数据采集格式为:点号,X坐标,Y坐标, Z(高程)Open数据文件名For Input As #1set Points = yers.Add(/点0)-增加/点0图层Points.Color = acBlueSet Heights = yers.Add(/高程0)-增加/高程0图层Heights.Color = acGreenSet nos = yers.Add(/点号0)-增加/点号0图层nos.Color = acRedDo While Not EOF(1)Input #1, NO, x, y, z -将文件中数据分别附值给这几个变量Pt(0) = y: Pt(1) = x: Pt(2) = 0 -测量坐标系与AutoCAD坐标系的区别Set AdPoint = modelobj.AddPoint(Pt) -在模型空间中画点yer =/点0SetAdNO = modelobj.AddText(Str(NO), Pt, 1#)-在模型空间中绘制点号yer =/点号0Ht(0) = y + 0.9: Ht(1) = x: Ht(2) = 0Set AdHeight = modelobj.AddText(Str(z), Ht, 2#) yer =/高程0LoopClose #1acapp1.Application.ZoomExtentsForm1.Visible = FalseEnd Sub将展成的点连线的VBA代码为:Set PtLine = yers.Add(/点连线0) PtLine.color = acCyanDim kDim Coord As VariantFor Each entry In ThisDrawing.ModelSpaceIf entry.EntityType = acPoint Theni = i + 1End IfNext -获取模型空间中的点数目ReDim entrycopys(i -1, 2) -根据获得的点数目重新定义数组维数k = 0For Each entry In ThisDrawing.ModelSpaceIf entry.EntityType = acPoint ThenCoord = entry.Coordinates -获取实体坐标entrycopys(k, 0) = Coord (0)entrycopys(k, 1) = Coord (1)entrycopys(k, 2) = Coord (2)k = k + 1End IfNextDim StPt(0 To 2) As DoubleDim EtPt(0 To 2) As DoubleFor j = 1 To i -1StPt(0) = entrycopys(j -1, 0)StPt(1) = entrycopys(j -1, 1)StPt(2) = entrycopys(j -1, 2)EtPt(0) = entrycopys(j, 0)EtPt(1) = entrycopys(j, 1)EtPt(2) = entrycopys(j, 2)Set Lines = ThisDrawing.ModelSpace.AddLine(StPt, EtPt)-将当前点与前一个点连线yer =/点连线0Next jThisDrawing.Application.ZoomExtents如果要在Visual Basic环境中写入程序,则只要将VBA中的ThisDrawing对象改为AutoCAD对象的活动文件对象,就可以执行相同的操作,但由于是外部程序,执行速度将会慢一些。

基于AutoLisp的AutoCAD二次开发在测绘图形处理中的应用

基于AutoLisp的AutoCAD二次开发在测绘图形处理中的应用

基于AutoLisp的AutoCAD二次开发在测绘图形处理中的应用摘要：本文介绍了如何利用Autolisp语言对AutoCAD进行二次开发，并实现了根据断面图来半自动化生成高程点，其结果大大提高了根据断面图绘制平面图的质量和速度。

关键词：AutoCAD Autolisp 自动化程序断面1引言在实际的测绘生产工作中，我们经常会遇到利用已有的断面图来绘制平面图进而复原地形的情况，想要绘制平面图高程点元素是必不可少的，那么我们就必须根据已有的断面图来生成相应的高程点。

本文介绍了如何利用Autolisp语言在AutoCAD中实现根据设计断面图半自动化生成高程点，简化了原来利用AutoCAD测距量取距离，计算桩号、偏距、高程，再用Cass交互展点画出高程点的生成办法，在提高了准确率的同时也提高了工作效率。

2 Autolisp简介Autolisp是由Autodesk公司开发的一种LISP程序语言，LISP是List Processor（表处理程序）的缩写。

LISP语言具有语法简单，通俗易懂等特点，通过autolisp编程，可以节省工程师很多时间。

AutoLISP语言作为嵌入在AutoCAD内部的具有智能特点的编程语言，是开发应用AutoCAD不可缺少的工具[[1]]。

在工程测量领域中，AutoCAD得到了普遍应用，在日常工作中有许多人在研究使用AutoCAD，并画出了很多工程图纸。

然而，人们经常会感觉到作图效率还是不够高，这是因为AutoCAD是一个通用的绘图软件，并不具备专业特色。

AutoCAD开放的结构为不同的使用者留出了广阔的空间，提供了许多二次开发工具，AutoLISP是其中最强大的一个，Autolisp是AutoCAD自带的一门编程语言，无需安装，是为扩展和自定义AutoCAD功能而设计的编程语言，Autolisp易于使用，并且非常灵活，多年来一直是自定义AutoCAD的标准。

Autolisp嵌入AutoCAD内部，它不仅具有一般高级语言的基本结构和功能，而且还具有强大的图形处理和数据交换功能。

AutoCAD二次开发(VBA)测绘篇

AutoCAD二次开发(VBA)测绘篇

VBAutoCAD AutoCADCASSVBAutoCAD…QQ QQAutoCAD 36768105 BLOG(VBA)GPS GIS surveynet@2008121Hello World......................................................................................................1 AutoCAD ...............................................................................3 ..........................................................................5 ..........................................................................................................8 ........................................................................................................10 ....................................................................................................................13 ....................................................................................................16 ....................................................................................................21 ........................................................................................................24 ............................................................................................27 ............................................................................................28 VBA .........................................................................31 VBA VBA VB AutoCAD .............................................................32 .............................................33 ..........................................................34Hello WorldAutoCAD VBAVBA1 2 3AutoCAD vbaide alt+F11 1 Sub HelloWorld() MsgBox "Hello World!", vbInformation, " End Sub "1 4 -vbarun helloworld 215 VBA 6 appload *.dvb AutoCAD AutoCADAutoCADVBA22AutoCADAutoCAD 0 Sub DrawLine() ThisDrawing.Application.ActiveDocument.SendCommand "line" & vbCr _ & "0,0" & vbCr & "1,1" & vbCr & Chr(27) End Sub ThisDrawing.Application.ActiveDocument SendCommand Chr(27) vbCr AutoCAD CASS Sub DarwYancong() ThisDrawing.Application.ActiveDocument.SendCommand "dd" & vbCr & _ "152700" & vbCr & "0,0" & vbCr End Sub 0 0 Esc Enter 0 1 1CASS1,F3,3560.512,501.236,35.213 2,YC,3561.213,502.365,35.012 …3CASS CASSYC,152700 ST, 152620 … CASS CASS CASS AutoCAD CASS XY AutoCAD Visual Basic Visual Basic CASSAutoCAD4AutoCADAutoCAD AutoCAD Sub DrawPoint() Dim xy(2) As Double xy(0) = 100: xy(1) = 200: xy(2) = 0 ThisDrawing.Application.ActiveDocument.ModelSpace.AddPoint xy End Subzoom e ddptypeThisDrawing.Application.ZoomCenter xy, 1ZoomAllZoomExtentsThisDrawing.Application.ActiveDocument.SetVariable "PDMODE", 35 ThisDrawing.Application.ActiveDocument.SetVariable "PDSIZE", 55LwPolyline LwPolyline Sub DrawLwPolyline() Dim xy(3) As Double xy(0) = 100: xy(1) = 200 xy(2) = 300: xy(3) = 400 ThisDrawing.Application.ActiveDocument.ModelSpace. _ AddLightWeightPolyline xy End SubPolylinelist PolylineSub DrawPolyline() Dim xy(5) As Double xy(0) = 100: xy(1) = 200: xy(2) = 25 xy(3) = 300: xy(4) = 400: xy(5) = 25 ThisDrawing.Application.ActiveDocument.ModelSpace.AddPolyline xy End Sub Polyline AutoCAD 25Each vertex is represented with threeelements, with the first two being the X and Y coodinates in OCS; the third element is ignored. Sub DrawPolyline2() Dim objPL As AcadPolyline Dim xy(5) As Double xy(0) = 100: xy(1) = 200: xy(2) = 0 xy(3) = 300: xy(4) = 400: xy(5) = 0 Set objPL = ThisDrawing.Application.ActiveDocument.ModelSpace _ .AddPolyline(xy)6objPL.Elevation = 25 End Sub 25Sub DrawCircle() Dim xy(2) As Double xy(0) = 100: xy(1) = 200: xy(2) = 300 ThisDrawing.Application.ActiveDocument.ModelSpace.AddCircle xy, 20 End Sub 20Sub DrawText() Dim xy(2) As Double xy(0) = 100: xy(1) = 200: xy(2) = 300 ThisDrawing.Application.ActiveDocument.ModelSpace.AddText _ "Hello World!", xy, 30 End SubCASS 0 0Point+TextLwPolyline+Text CASS Polyline7Sub CreateLayer()Dim objLyr As AcadLayerSet objLyr = yers.Add("hello")objLyr.Color = acRedyerOn = TrueobjLyr.Freeze = FalseobjLyr.Lock = FalseThisDrawing.Application.ActiveDocument.ActiveLayer = objLyr End Subhello objLyr.DeleteSub SearchLayer()Dim objlyr As AcadLayerDim blnExist As BooleanFor Each objlyr In yersIf = "hello" ThenMsgBox " "blnExist = TrueExit ForEnd IfNextIf blnExist = False Then MsgBox " "End SubAutoCAD AutoCADAutoCADAutoCAD Sub EditEntity()Dim objPnt As AcadPointDim xy(2) As Double, xxyy(2) As Doublexy(0) = 100: xy(1) = 200: xy(2) = 0xxyy(0) = 101: xxyy(1) = 201: xxyy(2) = 0Set objPnt = ThisDrawing . Application . ActiveDocument ModelSpace . _AddPoint (xy)yer = "hello"objPnt.Color = acGreenobjPnt.Thickness = 123456objPnt.Move xy, xxyyMsgBox " (" & objPnt.Coordinates(0) & "," & _objPnt.Coordinates(1) & "," & objPnt.Coordinates(2) & ")"End SubRotate Copy Mirror1Sub EditLwPolyline()Dim objLwPl As AcadLWPolylineDim xy(5) As Doublexy(0) = 100: xy(1) = 200xy(2) = 300: xy(3) = 300xy(4) = 500: xy(5) = 600Set objLwPl = ThisDrawing . Application . ActiveDocument . ModelSpace . _AddLightWeightPolyline (xy)objLwPl.Closed = True 'objLwPl.ConstantWidth = 0 'objLwPl.Linetype = "10421" 'objLwPl.Highlight True 'MsgBox "ID=" & objLwPl.ObjectIDMsgBox " =" & objLwPl.ObjectNameMsgBox " =" & objLwPl.HandleMsgBox " (" & objLwPl.Coordinates(0) & "," & _objLwPl.Coordinates(1) & "),(" & objLwPl.Coordinates(2) & "," & _objLwPl.Coordinates(3) & "),(" & objLwPl.Coordinates(4) & "," & _objLwPl.Coordinates(5) & ")"End SubPolyline2Sub EditText()Dim objText As AcadTextDim xy(2) As Doublexy(0) = 100: xy(1) = 200: xy(2) = 300Set objText = ThisDrawing . Application . ActiveDocument . ModelSpace . _AddText("Hello World!", xy, 30)MsgBox " :(" & objText.InsertionPoint(0) & "," & _objText.InsertionPoint(1) & "," & objText.InsertionPoint(2) & ")"objText.Alignment = acAlignmentBottomRight 'objText.Height = 20 'objText.StyleName = "STANDARD" 'objText.TextString = "AutoCAD VBA " 'End Sub…DWG CASS …Block CASSCASS CASSSub InsertBlock()Dim xy(2) As Doublexy(0) = 100: xy(1) = 200: xy(2) = 300ThisDrawing.Application.ActiveDocument.ModelSpace.InsertBlock xy, _"C:\Documents and Settings\Administrator\ \abc.dwg", 1, 1, 1, 0 End SubCASSCASS ? 3008 VBASub BlockProperties()Dim objBlock As AcadBlockReferenceDim sSet As AcadSelectionSetDim intCnt As IntegerDim mType(2) As Integer, mData(2) As VariantDim xyz(2) As DoubleDim varAttributes As VariantintCnt = ThisDrawing.SelectionSets.CountWhile (intCnt > 0)Set sSet = ThisDrawing.SelectionSets.Item(intCnt - 1)sSet.DeleteintCnt = intCn0t - 1WendmType(0) = 0: mData(0) = "INSERT"mType(1) = 8: mData(1) = "GCD"mType(2) = 2: mData(2) = "GC200"Set sSet = ThisDrawing.SelectionSets.Add("GCD")sSet.Select acSelectionSetAll, , , mType, mDataIf sSet.Count > 0 ThenFor Each objBlock In sSetxyz(0) = objBlock.insertionPoint(0)xyz(1) = objBlock.insertionPoint(1)xyz(2) = objBlock.insertionPoint(2) + 50objBlock.insertionPoint = xyz 'varAttributes = objBlock.GetAttributes 'varAttributes(0).TextString = xyz(2) ' NextEnd IfsSet.DeleteEnd SubGCD INSERT GC200 50AutoCAD GCD INSERT GC200Sub CreateSset()Dim sSet As AcadSelectionSetSet sSet = ThisDrawing.Application.ActiveDocument.SelectionSets.Add _(" ")End SubSub CreateSset2()Dim sSet As AcadSelectionSetFor Each sSet In ThisDrawing.Application.ActiveDocument.SelectionSets If = " " Then sSet.DeleteNextSet sSet = ThisDrawing.Application.ActiveDocument.SelectionSets.Add _(" ")' ...sSet.DeleteEnd SubPublic Function AddEntToSset(objEnt As AcadEntity, sSet As AcadSelectionSet) Dim objCollection(0) As AcadEntitySet objCollection(0) = entsSet.AddItems objCollectionEnd Function1Sub GetEntity()Dim objCircle As AcadCircleDim xyz(2) As Doublexyz(0) = 0: xyz(1) = 0: xyz(2) = 0Set objCircle = _ThisDrawing.Application.ActiveDocument.ModelSpace.AddCircle(xyz, 5) End Sub2 ItemSub GetEntity2()Dim objEnt As AcadEntitySet objEnt = ThisDrawing.Application.ActiveDocument.ModelSpace.Item(5) End Sub3 HandleToObjectSub GetEntity3()Dim objEnt As AcadEntitySet objEnt = _ThisDrawing.Application.ActiveDocument.HandleToObject("3BA") End SubSelectobjSset.Select Mode [,point1][,points][,FilterType][,FilterData]objSsetModeacSelectionSetWindow ( point1,point2 )acSelectionSetCrossing acSelectSetPreviousacSelectSetLastacSelectSetAllPoint1,point2 (3D)FilterType,FilterData0 Line,Circle258AutoCAD DXFmType(0) = 0: mData(0) = "INSERT"mType(1) = 8: mData(1) = "GCD"mType(2) = 2: mData(2) = "GC200"Set sSet = ThisDrawing.SelectionSets.Add("GCD")sSet.Select acSelectionSetAll, , , mType, mDataINSERT GCD GC200POINT LINE ARC CIRCLE INSERT LWPOLYLINE POLYLINEmType(0) = 8: mData(0) = "G*"GSelectAtPoint SelectByPolygon SelectOnScreenSelectOnScreen objSset.SelectOnScreen [FilterType] [,FilterData]Sub SelectOnScreenExample()Dim sSet As AcadSelectionSetDim objEnt As AcadObjectFor Each sSet In ThisDrawing.Application.ActiveDocument.SelectionSets If = " " Then sSet.DeleteNextSet sSet = _ThisDrawing.Application.ActiveDocument.SelectionSets.Add(" ")sSet.SelectOnScreenIf sSet.Count > 0 ThenFor Each objEnt In sSetobjEnt.color = acRedNextEnd IfsSet.DeleteEnd SubSelectOnScreen objSset.Clear objSset.RemoveItemobjSset.Erase objSset.DeleteUtilityAutoCAD1 GetStringSub GetStringExample()Dim strName As StringstrName = ThisDrawing.Application.ActiveDocument.Utility.GetString _(1, vbCr & " ")If strName <> "" Then MsgBox strNameEnd Sub2 GetPointSub GetPointExample()Dim pntStart As Variant, pntEnd As VariantpntStart = ThisDrawing.Application.ActiveDocument.Utility.GetPoint _(, vbCr & " ")pntEnd = ThisDrawing.Application.ActiveDocument.Utility.GetPoint _(, vbCr & " ")ThisDrawing.Application.ActiveDocument.ModelSpace.AddLine _pntStart, pntEndEnd Sub3 GetEntitySub GetEntityExample()Dim objent As AcadObjectDim pnt As VariantThisDrawing.Application.ActiveDocument.Utility.GetEntity _objent, pnt, vbCr & " "MsgBox objent.ObjectNameEnd Sub4 PromptSub PromptExample()ThisDrawing.Application.ActiveDocument.Utility.Prompt _vbCr & " "End Sub5 InitializeUserInputPline [ (A)/ (C)/ (H)/ (L)/ (U)/ (W)] A C H L U W AutoCAD InitializeUserInput VBASub InitializeUserInputExample()Dim keyWord As StringThisDrawing.Application.ActiveDocument.Utility.InitializeUserInput _1, "A B C D"keyWord = ThisDrawing.Application.ActiveDocument.Utility.GetKeyword _ (vbCr & " (A B C D)")MsgBox keyWordEnd SubGetKeyword AutoCAD InitializeUserInputobjUtility. InitializeUserInput Bits [,Keyword]BitsBits=1Bits=2 0Bits=4Bits=8 LIMCHECK ONBits=32Bits=64 3D Z GetDistanceBits=128KeywordCASS GETP V CASS AutoCAD CASSPublic Function HasXData( ent As AcadEntity, strAppName As String) As Boolean Dim dataType As VariantDim Data As Variantent.GetXData strAppName, dataType, DataHasXData = TrueIf IsEmpty(dataType) ThenHasXData = FalseEnd IfEnd FunctionstrAppName CASS southPublic Function GetCode(objEnt As AcadEntity, strAppName As String) As Variant Dim dType As Variant, dData As Variant, i As IntegerIf HasXData(objEnt, strAppName) = False ThenGetCode = ""ElseobjEnt.GetXData strAppName, dType, dDataFor i = LBound(dType) To UBound(dType)If dType(i) = 1000 ThenGetCode = dData(i)Exit ForEnd IfNext iEnd IfEnd FunctionCASS GETPPublic Sub GETP()Dim objEnt As AcadEntityDim pnt As VariantxGoTo:On Error Resume NextThisDrawing.Application.ActiveDocument.Utility.GetEntity _objEnt, pnt, vbCr & "VBA - < >"If Err Then Exit SubMsgBox " " & GetCode(objEnt, "south"), , "AutoCAD "GoTo xGoToEnd SubCASS work.defPublic Function SetCode(ent As AcadEntity, str As String, strAppName As String) Dim dType(0 To 1) As IntegerDim mData(0 To 1) As VariantdType(0) = 1001: mData(0) = strAppNamedType(1) = 1000: mData(1) = strent.SetXData dType, mDataEnd FunctionCASS PUTPThisDrawing.Application.ActiveDocument.SetVariable "PDMODE", 35ThisDrawing.Application.ActiveDocument.SetVariable "PDSIZE", 5PDMODE PDSIZE PDMODE PDSIZE AutoCAD CASSSub GetScale() 'MsgBox ThisDrawing.Application.ActiveDocument.GetVariable("USERR1")End SubSub SetScale() ' 1:500ThisDrawing.Application.ActiveDocument.SetVariable "USERR1", 500 ThisDrawing.Application.ActiveDocument.SetVariable "LTSCALE", 0.5End SubCASS USERR1( ) LTSCALE 1:500 LTSCALE=0.5 1:1000 LTSCALE=1…AutoCAD VBA LISPSub CreateMenuExample()'Dim mnuGroup As AcadMenuGroupSet mnuGroup = ThisDrawing.Application.MenuGroups.Item(0)'Dim mnuTest As AcadPopupMenuSet mnuTest = mnuGroup.Menus.Add(" ta (&T)")' VBA GETPDim mnuGetP As AcadPopupMenuItemDim macGetP As StringmacGetP = Chr(3) & Chr(3) & Chr(95) & _"-vbarun" & Chr(32) & "GETP" & Chr(32)Set mnuGetP = mnuTest.AddMenuItem _(mnuTest.Count + 1, " (&G)", macGetP)'Dim mnuSeparator As AcadPopupMenuItemSet mnuSeparator = mnuTest.AddSeparator("")' AutoCADDim mnuCopy As AcadPopupMenuItemDim macCopy As StringmacCopy = Chr(3) & Chr(3) & Chr(95) & "copy" & Chr(32)Set mnuCopy = mnuTest.AddMenuItem _(mnuTest.Count + 1, "&Copy", macCopy)'Dim mnuFather As AcadPopupMenuSet mnuFather = mnuTest.AddSubMenu(mnuTest.Count + 1, " ")Dim mnuChild As AcadPopupMenuItemDim macChild As StringmacChild = Chr(3) & Chr(3) & Chr(95) & "export" & Chr(32)Set mnuChild = mnuFather.AddMenuItem _(mnuTest.Count + 1, " - ", macChild)'mnuTest.InsertInMenuBar ThisDrawing.Application.MenuBar.Count + 1'If MsgBox(" COPY ?", vbYesNo, "AutoCAD ") = vbYes Then mnuCopy.DeleteEnd IfEnd SubVBA Macro, AutoLISP DIESEL ActiveX Chr(3) & Chr(3) & Chr(95) & "-vbarun" & Chr(32) & "GETP" & Chr(32) GETP Chr(3) & Chr(3) & Chr(95) & "copy" & Chr(32) AutoCAD COPYSub CreateToolbarExample()Dim mnuGroup As AcadMenuGroupDim tbTest As AcadToolbarDim tbCopy As AcadToolbarItemDim tbPaste As AcadToolbarItemDim tbSeparator As AcadToolbarItemDim macCopy As StringDim macPasteclip As StringDim strPath1 As StringDim strPath2 As StringSet mnuGroup = ThisDrawing.Application.MenuGroups.Item(0)Set tbTest = mnuGroup.Toolbars.Add(" ")macCopy = Chr(3) & Chr(3) & Chr(95) & "copy" & Chr(32)macPaste = Chr(3) & Chr(3) & Chr(95) & "pasteclip" & Chr(32)Set tbCopy = tbTest.AddToolbarButton _(tbTest.Count + 1, " ", " ", macCopy, False)Set tbPaste = tbTest.AddToolbarButton _(tbTest.Count + 1, " ", " ", macPaste, False)Set tbSeparator = tbTest.AddSeparator(tbTest.Count + 1)'strPath1 = "G:\VBA\copy.bmp"strPath2 = "G:\VBA\copy.bmp"tbCopy.SetBitmaps strPath1, strPath2strPath1 = "G:\VBA\paste.bmp"strPath2 = "G:\VBA\paste.bmp"tbPaste.SetBitmaps strPath1, strPath2MsgBox " "tbTest.Dock acToolbarDockLeftMsgBox " "tbTest.Float 550, 300, 1End SubVBALISP VBALISP VBA LISPVBAPrivate Sub AcadDocument_BeginLisp(ByVal FirstLine As String) Select Case UCase(FirstLine) Case "(C:VV)" Call GETP End Select End Sub*.lsp (defun C:vv()(princ))LISP vv VBA GETP VBAVBAVBAVBAPrivate Sub AcadDocument_BeginLisp(ByVal FirstLine As String) If LCase(FirstLine) = "s::startup" ThenCall CreateToolbarExample End If End SubAutoCADVBAVBAVBA regsvr32.exe FM20.dllOK VBAVB AutoCADVB AutoCAD AutoCAD 200X Type Library AutoCAD 200XPublic Function ConnectCAD() As Boolean Dim AcadApp As AcadApplication On Error Resume Next ConnectCAD = TrueSet AcadApp = GetObject(, "AutoCAD.Application") If Err Then Err.ClearSet AcadApp = CreateObject("AutoCAD.Application") If Err Then Err.ClearConnectCAD = False End If End IfAcadApp.Visible = True End FunctionAcacApp VBA Thisdrawing VB AutoCAD VBA AutoCAD AutoCAD VB AutoCADAutoCAD Sub ConnectAutoCADx() Dim AcadApp As Object Dim AcadDoc As ObjectOn Error Resume NextSet AcadApp = GetObject(, "AutoCAD.Application")If Err ThenErr.ClearSet AcadApp = CreateObject("AutoCAD.Application")If Err ThenErr.ClearMsgBox " AutoCAD, !", vbExclamation, " "Exit SubEnd IfEnd IfAcadApp.Visible = TrueSet AcadDoc = AcadApp.ActiveDocumentEnd SubAutoCAD VB VB Object AutoCADAutoCAD2004。

  1. 1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
  2. 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
  3. 3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。

VBAutoCAD AutoCADCASSVBAutoCAD…QQ QQAutoCAD 36768105 BLOG(VBA)GPS GIS surveynet@2008121Hello World......................................................................................................1 AutoCAD ...............................................................................3 ..........................................................................5 ..........................................................................................................8 ........................................................................................................10 ....................................................................................................................13 ....................................................................................................16 ....................................................................................................21 ........................................................................................................24 ............................................................................................27 ............................................................................................28 VBA .........................................................................31 VBA VBA VB AutoCAD .............................................................32 .............................................33 ..........................................................34Hello WorldAutoCAD VBAVBA1 2 3AutoCAD vbaide alt+F11 1 Sub HelloWorld() MsgBox "Hello World!", vbInformation, " End Sub "1 4 -vbarun helloworld 215 VBA 6 appload *.dvb AutoCAD AutoCADAutoCADVBA22Edited by Foxit Reader Copyright(C) by Foxit Software Company,2005-2008 For Evaluation Only.AutoCADAutoCAD 0 Sub DrawLine() ThisDrawing.Application.ActiveDocument.SendCommand "line" & vbCr _ & "0,0" & vbCr & "1,1" & vbCr & Chr(27) End Sub ThisDrawing.Application.ActiveDocument SendCommand Chr(27) vbCr AutoCAD CASS Sub DarwYancong() ThisDrawing.Application.ActiveDocument.SendCommand "dd" & vbCr & _ "152700" & vbCr & "0,0" & vbCr End Sub 0 0 Esc Enter 0 1 1CASS1,F3,3560.512,501.236,35.213 2,YC,3561.213,502.365,35.012 …3Edited by Foxit Reader Copyright(C) by Foxit Software Company,2005-2008 For Evaluation Only.CASS CASSYC,152700 ST, 152620 … CASS CASS CASS AutoCAD CASS XY AutoCAD Visual Basic Visual Basic CASSAutoCAD4AutoCADAutoCAD AutoCAD Sub DrawPoint() Dim xy(2) As Double xy(0) = 100: xy(1) = 200: xy(2) = 0 ThisDrawing.Application.ActiveDocument.ModelSpace.AddPoint xy End Subzoom e ddptypeThisDrawing.Application.ZoomCenter xy, 1ZoomAllZoomExtentsThisDrawing.Application.ActiveDocument.SetVariable "PDMODE", 35 ThisDrawing.Application.ActiveDocument.SetVariable "PDSIZE", 55LwPolyline LwPolyline Sub DrawLwPolyline() Dim xy(3) As Double xy(0) = 100: xy(1) = 200 xy(2) = 300: xy(3) = 400 ThisDrawing.Application.ActiveDocument.ModelSpace. _ AddLightWeightPolyline xy End SubPolylinelist PolylineSub DrawPolyline() Dim xy(5) As Double xy(0) = 100: xy(1) = 200: xy(2) = 25 xy(3) = 300: xy(4) = 400: xy(5) = 25 ThisDrawing.Application.ActiveDocument.ModelSpace.AddPolyline xy End Sub Polyline AutoCAD 25Each vertex is represented with threeelements, with the first two being the X and Y coodinates in OCS; the third element is ignored. Sub DrawPolyline2() Dim objPL As AcadPolyline Dim xy(5) As Double xy(0) = 100: xy(1) = 200: xy(2) = 0 xy(3) = 300: xy(4) = 400: xy(5) = 0 Set objPL = ThisDrawing.Application.ActiveDocument.ModelSpace _ .AddPolyline(xy)6objPL.Elevation = 25 End Sub 25Sub DrawCircle() Dim xy(2) As Double xy(0) = 100: xy(1) = 200: xy(2) = 300 ThisDrawing.Application.ActiveDocument.ModelSpace.AddCircle xy, 20 End Sub 20Sub DrawText() Dim xy(2) As Double xy(0) = 100: xy(1) = 200: xy(2) = 300 ThisDrawing.Application.ActiveDocument.ModelSpace.AddText _ "Hello World!", xy, 30 End SubCASS 0 0Point+TextLwPolyline+Text CASS Polyline7Sub CreateLayer()Dim objLyr As AcadLayerSet objLyr = yers.Add("hello")objLyr.Color = acRedyerOn = TrueobjLyr.Freeze = FalseobjLyr.Lock = FalseThisDrawing.Application.ActiveDocument.ActiveLayer = objLyr End Subhello objLyr.DeleteSub SearchLayer()Dim objlyr As AcadLayerDim blnExist As BooleanFor Each objlyr In yersIf = "hello" ThenMsgBox " "blnExist = TrueExit ForEnd IfNextIf blnExist = False Then MsgBox " "End SubAutoCAD AutoCADAutoCADAutoCAD Sub EditEntity()Dim objPnt As AcadPointDim xy(2) As Double, xxyy(2) As Doublexy(0) = 100: xy(1) = 200: xy(2) = 0xxyy(0) = 101: xxyy(1) = 201: xxyy(2) = 0Set objPnt = ThisDrawing . Application . ActiveDocument ModelSpace . _AddPoint (xy)yer = "hello"objPnt.Color = acGreenobjPnt.Thickness = 123456objPnt.Move xy, xxyyMsgBox " (" & objPnt.Coordinates(0) & "," & _objPnt.Coordinates(1) & "," & objPnt.Coordinates(2) & ")"End SubRotate Copy Mirror1Sub EditLwPolyline()Dim objLwPl As AcadLWPolylineDim xy(5) As Doublexy(0) = 100: xy(1) = 200xy(2) = 300: xy(3) = 300xy(4) = 500: xy(5) = 600Set objLwPl = ThisDrawing . Application . ActiveDocument . ModelSpace . _AddLightWeightPolyline (xy)objLwPl.Closed = True 'objLwPl.ConstantWidth = 0 'objLwPl.Linetype = "10421" 'objLwPl.Highlight True 'MsgBox "ID=" & objLwPl.ObjectIDMsgBox " =" & objLwPl.ObjectNameMsgBox " =" & objLwPl.HandleMsgBox " (" & objLwPl.Coordinates(0) & "," & _objLwPl.Coordinates(1) & "),(" & objLwPl.Coordinates(2) & "," & _objLwPl.Coordinates(3) & "),(" & objLwPl.Coordinates(4) & "," & _objLwPl.Coordinates(5) & ")"End SubPolyline2Sub EditText()Dim objText As AcadTextDim xy(2) As Doublexy(0) = 100: xy(1) = 200: xy(2) = 300Set objText = ThisDrawing . Application . ActiveDocument . ModelSpace . _AddText("Hello World!", xy, 30)MsgBox " :(" & objText.InsertionPoint(0) & "," & _objText.InsertionPoint(1) & "," & objText.InsertionPoint(2) & ")"objText.Alignment = acAlignmentBottomRight 'objText.Height = 20 'objText.StyleName = "STANDARD" 'objText.TextString = "AutoCAD VBA " 'End Sub…DWG CASS …Block CASSCASS CASSSub InsertBlock()Dim xy(2) As Doublexy(0) = 100: xy(1) = 200: xy(2) = 300ThisDrawing.Application.ActiveDocument.ModelSpace.InsertBlock xy, _"C:\Documents and Settings\Administrator\ \abc.dwg", 1, 1, 1, 0 End SubCASSCASS ? 3008 VBASub BlockProperties()Dim objBlock As AcadBlockReferenceDim sSet As AcadSelectionSetDim intCnt As IntegerDim mType(2) As Integer, mData(2) As VariantDim xyz(2) As DoubleDim varAttributes As VariantintCnt = ThisDrawing.SelectionSets.CountWhile (intCnt > 0)Set sSet = ThisDrawing.SelectionSets.Item(intCnt - 1)sSet.DeleteintCnt = intCn0t - 1WendmType(0) = 0: mData(0) = "INSERT"mType(1) = 8: mData(1) = "GCD"mType(2) = 2: mData(2) = "GC200"Set sSet = ThisDrawing.SelectionSets.Add("GCD")sSet.Select acSelectionSetAll, , , mType, mDataIf sSet.Count > 0 ThenFor Each objBlock In sSetxyz(0) = objBlock.insertionPoint(0)xyz(1) = objBlock.insertionPoint(1)xyz(2) = objBlock.insertionPoint(2) + 50objBlock.insertionPoint = xyz 'varAttributes = objBlock.GetAttributes 'varAttributes(0).TextString = xyz(2) ' NextEnd IfsSet.DeleteEnd SubGCD INSERT GC200 50AutoCAD GCD INSERT GC200Sub CreateSset()Dim sSet As AcadSelectionSetSet sSet = ThisDrawing.Application.ActiveDocument.SelectionSets.Add _(" ")End SubSub CreateSset2()Dim sSet As AcadSelectionSetFor Each sSet In ThisDrawing.Application.ActiveDocument.SelectionSets If = " " Then sSet.DeleteNextSet sSet = ThisDrawing.Application.ActiveDocument.SelectionSets.Add _(" ")' ...sSet.DeleteEnd SubPublic Function AddEntToSset(objEnt As AcadEntity, sSet As AcadSelectionSet) Dim objCollection(0) As AcadEntitySet objCollection(0) = entsSet.AddItems objCollectionEnd Function1Sub GetEntity()Dim objCircle As AcadCircleDim xyz(2) As Doublexyz(0) = 0: xyz(1) = 0: xyz(2) = 0Set objCircle = _ThisDrawing.Application.ActiveDocument.ModelSpace.AddCircle(xyz, 5) End Sub2 ItemSub GetEntity2()Dim objEnt As AcadEntitySet objEnt = ThisDrawing.Application.ActiveDocument.ModelSpace.Item(5) End Sub3 HandleToObjectSub GetEntity3()Dim objEnt As AcadEntitySet objEnt = _ThisDrawing.Application.ActiveDocument.HandleToObject("3BA") End SubSelectobjSset.Select Mode [,point1][,points][,FilterType][,FilterData]objSsetModeacSelectionSetWindow ( point1,point2 )acSelectionSetCrossing acSelectSetPreviousacSelectSetLastacSelectSetAllPoint1,point2 (3D)FilterType,FilterData0 Line,Circle258AutoCAD DXFmType(0) = 0: mData(0) = "INSERT"mType(1) = 8: mData(1) = "GCD"mType(2) = 2: mData(2) = "GC200"Set sSet = ThisDrawing.SelectionSets.Add("GCD")sSet.Select acSelectionSetAll, , , mType, mDataINSERT GCD GC200POINT LINE ARC CIRCLE INSERT LWPOLYLINE POLYLINEmType(0) = 8: mData(0) = "G*"GSelectAtPoint SelectByPolygon SelectOnScreenSelectOnScreen objSset.SelectOnScreen [FilterType] [,FilterData]Sub SelectOnScreenExample()Dim sSet As AcadSelectionSetDim objEnt As AcadObjectFor Each sSet In ThisDrawing.Application.ActiveDocument.SelectionSets If = " " Then sSet.DeleteNextSet sSet = _ThisDrawing.Application.ActiveDocument.SelectionSets.Add(" ")sSet.SelectOnScreenIf sSet.Count > 0 ThenFor Each objEnt In sSetobjEnt.color = acRedNextEnd IfsSet.DeleteEnd SubSelectOnScreen objSset.Clear objSset.RemoveItemobjSset.Erase objSset.DeleteUtilityAutoCAD1 GetStringSub GetStringExample()Dim strName As StringstrName = ThisDrawing.Application.ActiveDocument.Utility.GetString _(1, vbCr & " ")If strName <> "" Then MsgBox strNameEnd Sub2 GetPointSub GetPointExample()Dim pntStart As Variant, pntEnd As VariantpntStart = ThisDrawing.Application.ActiveDocument.Utility.GetPoint _(, vbCr & " ")pntEnd = ThisDrawing.Application.ActiveDocument.Utility.GetPoint _(, vbCr & " ")ThisDrawing.Application.ActiveDocument.ModelSpace.AddLine _pntStart, pntEndEnd Sub3 GetEntitySub GetEntityExample()Dim objent As AcadObjectDim pnt As VariantThisDrawing.Application.ActiveDocument.Utility.GetEntity _objent, pnt, vbCr & " "MsgBox objent.ObjectNameEnd Sub4 PromptSub PromptExample()ThisDrawing.Application.ActiveDocument.Utility.Prompt _vbCr & " "End Sub5 InitializeUserInputPline [ (A)/ (C)/ (H)/ (L)/ (U)/ (W)] A C H L U W AutoCAD InitializeUserInput VBASub InitializeUserInputExample()Dim keyWord As StringThisDrawing.Application.ActiveDocument.Utility.InitializeUserInput _1, "A B C D"keyWord = ThisDrawing.Application.ActiveDocument.Utility.GetKeyword _ (vbCr & " (A B C D)")MsgBox keyWordEnd SubGetKeyword AutoCAD InitializeUserInputobjUtility. InitializeUserInput Bits [,Keyword]BitsBits=1Bits=2 0Bits=4Bits=8 LIMCHECK ONBits=32Bits=64 3D Z GetDistanceBits=128KeywordCASS GETP V CASS AutoCAD CASSPublic Function HasXData( ent As AcadEntity, strAppName As String) As Boolean Dim dataType As VariantDim Data As Variantent.GetXData strAppName, dataType, DataHasXData = TrueIf IsEmpty(dataType) ThenHasXData = FalseEnd IfEnd FunctionstrAppName CASS southPublic Function GetCode(objEnt As AcadEntity, strAppName As String) As Variant Dim dType As Variant, dData As Variant, i As IntegerIf HasXData(objEnt, strAppName) = False ThenGetCode = ""ElseobjEnt.GetXData strAppName, dType, dDataFor i = LBound(dType) To UBound(dType)If dType(i) = 1000 ThenGetCode = dData(i)Exit ForEnd IfNext iEnd IfEnd FunctionCASS GETPPublic Sub GETP()Dim objEnt As AcadEntityDim pnt As VariantxGoTo:On Error Resume NextThisDrawing.Application.ActiveDocument.Utility.GetEntity _objEnt, pnt, vbCr & "VBA - < >"If Err Then Exit SubMsgBox " " & GetCode(objEnt, "south"), , "AutoCAD "GoTo xGoToEnd SubCASS work.defPublic Function SetCode(ent As AcadEntity, str As String, strAppName As String) Dim dType(0 To 1) As IntegerDim mData(0 To 1) As VariantdType(0) = 1001: mData(0) = strAppNamedType(1) = 1000: mData(1) = strent.SetXData dType, mDataEnd FunctionCASS PUTPThisDrawing.Application.ActiveDocument.SetVariable "PDMODE", 35ThisDrawing.Application.ActiveDocument.SetVariable "PDSIZE", 5PDMODE PDSIZE PDMODE PDSIZE AutoCAD CASSSub GetScale() 'MsgBox ThisDrawing.Application.ActiveDocument.GetVariable("USERR1")End SubSub SetScale() ' 1:500ThisDrawing.Application.ActiveDocument.SetVariable "USERR1", 500 ThisDrawing.Application.ActiveDocument.SetVariable "LTSCALE", 0.5End SubCASS USERR1( ) LTSCALE 1:500 LTSCALE=0.5 1:1000 LTSCALE=1…AutoCAD VBA LISPSub CreateMenuExample()'Dim mnuGroup As AcadMenuGroupSet mnuGroup = ThisDrawing.Application.MenuGroups.Item(0)'Dim mnuTest As AcadPopupMenuSet mnuTest = mnuGroup.Menus.Add(" ta (&T)")' VBA GETPDim mnuGetP As AcadPopupMenuItemDim macGetP As StringmacGetP = Chr(3) & Chr(3) & Chr(95) & _"-vbarun" & Chr(32) & "GETP" & Chr(32)Set mnuGetP = mnuTest.AddMenuItem _(mnuTest.Count + 1, " (&G)", macGetP)'Dim mnuSeparator As AcadPopupMenuItemSet mnuSeparator = mnuTest.AddSeparator("")' AutoCADDim mnuCopy As AcadPopupMenuItemDim macCopy As StringmacCopy = Chr(3) & Chr(3) & Chr(95) & "copy" & Chr(32)Set mnuCopy = mnuTest.AddMenuItem _(mnuTest.Count + 1, "&Copy", macCopy)'Dim mnuFather As AcadPopupMenuSet mnuFather = mnuTest.AddSubMenu(mnuTest.Count + 1, " ")Dim mnuChild As AcadPopupMenuItemDim macChild As StringmacChild = Chr(3) & Chr(3) & Chr(95) & "export" & Chr(32)Set mnuChild = mnuFather.AddMenuItem _(mnuTest.Count + 1, " - ", macChild)'mnuTest.InsertInMenuBar ThisDrawing.Application.MenuBar.Count + 1'If MsgBox(" COPY ?", vbYesNo, "AutoCAD ") = vbYes Then mnuCopy.DeleteEnd IfEnd SubVBA Macro, AutoLISP DIESEL ActiveX Chr(3) & Chr(3) & Chr(95) & "-vbarun" & Chr(32) & "GETP" & Chr(32) GETP Chr(3) & Chr(3) & Chr(95) & "copy" & Chr(32) AutoCAD COPYSub CreateToolbarExample()Dim mnuGroup As AcadMenuGroupDim tbTest As AcadToolbarDim tbCopy As AcadToolbarItemDim tbPaste As AcadToolbarItemDim tbSeparator As AcadToolbarItemDim macCopy As StringDim macPasteclip As StringDim strPath1 As StringDim strPath2 As StringSet mnuGroup = ThisDrawing.Application.MenuGroups.Item(0)Set tbTest = mnuGroup.Toolbars.Add(" ")macCopy = Chr(3) & Chr(3) & Chr(95) & "copy" & Chr(32)macPaste = Chr(3) & Chr(3) & Chr(95) & "pasteclip" & Chr(32)Set tbCopy = tbTest.AddToolbarButton _(tbTest.Count + 1, " ", " ", macCopy, False)Set tbPaste = tbTest.AddToolbarButton _(tbTest.Count + 1, " ", " ", macPaste, False)Set tbSeparator = tbTest.AddSeparator(tbTest.Count + 1)'strPath1 = "G:\VBA\copy.bmp"strPath2 = "G:\VBA\copy.bmp"tbCopy.SetBitmaps strPath1, strPath2strPath1 = "G:\VBA\paste.bmp"strPath2 = "G:\VBA\paste.bmp"tbPaste.SetBitmaps strPath1, strPath2MsgBox " "tbTest.Dock acToolbarDockLeftMsgBox " "tbTest.Float 550, 300, 1End SubVBALISP VBALISP VBA LISPVBAPrivate Sub AcadDocument_BeginLisp(ByVal FirstLine As String) Select Case UCase(FirstLine) Case "(C:VV)" Call GETP End Select End Sub*.lsp (defun C:vv()(princ))LISP vv VBA GETP VBAVBAVBAVBAPrivate Sub AcadDocument_BeginLisp(ByVal FirstLine As String) If LCase(FirstLine) = "s::startup" ThenCall CreateToolbarExample End If End SubAutoCADVBAVBAVBA regsvr32.exe FM20.dllOK VBAVB AutoCADVB AutoCAD AutoCAD 200X Type Library AutoCAD 200XPublic Function ConnectCAD() As Boolean Dim AcadApp As AcadApplication On Error Resume Next ConnectCAD = TrueSet AcadApp = GetObject(, "AutoCAD.Application") If Err Then Err.ClearSet AcadApp = CreateObject("AutoCAD.Application") If Err Then Err.ClearConnectCAD = False End If End IfAcadApp.Visible = True End FunctionAcacApp VBA Thisdrawing VB AutoCAD VBA AutoCAD AutoCAD VB AutoCADAutoCAD Sub ConnectAutoCADx() Dim AcadApp As Object Dim AcadDoc As ObjectEdited by Foxit ReaderCopyright(C) by Foxit Software Company,2005-2008For Evaluation Only.On Error Resume NextSet AcadApp = GetObject(, "AutoCAD.Application")If Err ThenErr.ClearSet AcadApp = CreateObject("AutoCAD.Application")If Err ThenErr.ClearMsgBox " AutoCAD, !", vbExclamation, " "Exit SubEnd IfEnd IfAcadApp.Visible = TrueSet AcadDoc = AcadApp.ActiveDocumentEnd SubAutoCAD VB VB Object AutoCADAutoCAD2004。

相关文档
最新文档