为了正常的体验网站,请在浏览器设置里面开启Javascript功能!

AutoCAD VBA简介及自动化介绍

2019-06-25 32页 doc 66KB 57阅读

用户头像

is_477730

暂无简介

举报
AutoCAD VBA简介及自动化介绍AutoCAD VBA 一、AutoCAD VBA简介 ?VBA(Visual Basic for Application) VBA是AutoCAD的一种开发工具,具有强大的功能。Microsoft VBA是一种面向对象的编程环境,它与VB一样具有很强的开发功能。VBA与VB之间的区别就是VBA AutoCAD在同一处理空间运行,为AutoCAD提供智能和快速的编程环境。 VBA功能: ● 创建对话框和其它界面; ● 创建工具栏; ● 建立模块级宏指令; ● 提供建立类模块的功能; ● 具有完善的数据访问和管理能力;(ADO...
AutoCAD 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应用程序本身也是对象。 对象是通过分层方式来组织的,应用程序对象为根对象。这种分层结构的视图被归结为对象模型。对象模型提供了你访问下一层对象的途径。 集合对象是预先定义的对象,它包含所有相似对象的实例(即这些对象的父对象)。集合对象有以下的对象: 文档(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、程序和文档窗口设置 '''***************************************************************************** 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, "Solid", True) 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 河海大学土木工程学院测绘工程系" 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' 已经存在!", vbCritical 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、用户输入 '''*********************************************************************** 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.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, b, factor, 45) a.Transparency = True 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, "杨彪", "._OPEN ") Set acMenuItem = acMenu.AddMenuItem(0, "杨彪4", "-vbarun showpic2 ") Set acMenu = ThisDrawing.Application.MenuGroups(0).Menus.Add("杨彪111") 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.AddMenuItem(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 acToolbar = 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.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 = acToolbar.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 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 + "不能进行操作", vbInformation, "错误" 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) = "," Then 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 Variant, 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)
/
本文档为【AutoCAD VBA简介及自动化介绍】,请使用软件OFFICE或WPS软件打开。作品中的文字与图均可以修改和编辑, 图片更改请在作品中右键图片并更换,文字修改请直接点击文字进行修改,也可以新增和删除文档中的内容。
[版权声明] 本站所有资料为用户分享产生,若发现您的权利被侵害,请联系客服邮件isharekefu@iask.cn,我们尽快处理。 本作品所展示的图片、画像、字体、音乐的版权可能需版权方额外授权,请谨慎使用。 网站提供的党政主题相关内容(国旗、国徽、党徽..)目的在于配合国家政策宣传,仅限个人学习分享使用,禁止用于任何广告和商用目的。

历史搜索

    清空历史搜索