关于VB对AutoCAD二次开发学习笔记.docx

关于VB对AutoCAD二次开发学习笔记关于VB对AutoCAD二次开发学习笔记 By OYLS 基于VB对AutoCAD的二次开发，主要是通过运用VB编程对AutoCAD软件中的基本绘图操作进行控制，了解AutoCAD软件中的常用命令。在编程过程中我们要借助AutoCAD软件中的“帮助文件”，即“AutoCAD开发人员帮助”文档。 一、 获取VB对AutoCAD的控制权： 先定义变量acadApp,acadDoc: Public acadApp As AcadApplication Public acadDoc As AcadDocument Function boot_CAD As Boolean On Error Resume Next Set acadApp = GetObject(, "AutoCAD.Application") If Err Then Err.Clear Set acadApp = CreateObject("AutoCAD.Application") If Err Then MsgBox "您没有安装 AutoCAD ，或安装版本错误！", vbOKOnly + vbInformation, "CAD简易绘图系统" boot_CAD = False BtOK = False Exit Function End If End If Set acadDoc = acadApp.ActiveDocument acadApp.Visible = True boot_CAD = True End Function 需要说明的是，我们只有先对CAD获取了控制权以后才能有效地运用VB编程方式进行CAD的基本绘图操作。不然，以后的各种对CAD的操作将无法得以实现。 二、 基本绘图思路： 先了解所绘对象的基本属性，可以说，也正是由于对象的各种属性才构成了一个特性为一而标准的实体。对象的属性特点我们可以事先通过CAD帮助文件查找得出。接下来我们就应了解创建方法，同样，我们也是通过CAD帮助文件进行查找。可以看出，在整个绘图编程过程中我们都离不开CAD帮助文件，所以我们应当对其充分利用。 三、 介绍直线画法： 先了解到直线Line的创建方法： RetVal = object.AddLine(StartPoint, EndPoint) 可以看出，创建一直线我们所需的参数有StartPoint,EndPoint也就是开始点与结束点，并且： StartPoint： Variant (three-element array of doubles); input-only The 3D WCS coordinates specifying the line start point. 因此，在定义StartPoint时应为一数组，且为double型，以后多数数组也都为这一类型； EndPoint： Variant (three-element array of doubles); input-only The 3D WCS coordinates specifying the line endpoint. 因此，在定义EndPoint时也应为一数组，且为double型；值得注意的是，这里的StartPoint，EndPoint都是三维坐标形式。 在CAD帮助文件中可以查到Line的添加形式为： Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint) 通过上面给出的添加形式我们也可以看出它的基本参数。 无论是何种对象创建，我们都事先应对该对象的属性或参数作必要的变量定义。在定义变量时，我们最好应定义比较方便我们自己代码识别的形式。下面将以创建直线的方法来说明此过程： 先定义两个参数和一个创建对象： Dim mStPt(2) As Double, mEdPt(2) As Double Dim mLine As AcadLine 获取参数数值，这里是以在窗体上添加文本Text的形式给出： mStPt(0) = Val(Text1.Text) mStPt(1) = Val(Text2.Text) mStPt(2) = Val(Text3.Text) mEdPt(0) = Val(Text4.Text) mEdPt(1) = Val(Text5.Text) mEdPt(2) = Val(Text6.Text) Set mLine = acadDoc.ModelSpace.AddLine(mStPt, mEdPt) mLine.Update ZoomAll 这样，我们只要将上述程序代码放在VB一操作事件(如Click)中，就可以实现对直线Line的创建了。创建了一个对象，这里指直线Line，我们同时也获取了对该对象的控制权，通过这，我们可以在以后方便地根据用户自己的要求来设置或改变对象的一些属性值。了解了关于Line的创建方法后，我们也就了解到了CAD绘图操作的一般创建方法和思路。 10-2 四、 介绍曲线画法： 通过对直线Line的创建，我们可以用相同的方法对曲线Arc进行创建。 同样，我们在CAD的帮助文件中查出关于Arc对象的一些属性。 先了解到曲线Arc的创建方法： RetVal = object.AddArc(Center, Radius, StartAngle, EndAngle) 可以看出，创建一曲线时我们所需的参数有Center, Radius, StartAngle, EndAngle也就是曲线所对应圆弧中心点，半径，开始角和结束角，并且： Center： Variant (three-element array of doubles); input-only The 3D WCS coordinates specifying the center point of the arc. 因此，在定义Center时，要注意它是一点坐标形式，三维的。所以，我们也要为它定义为一double型数组。 Radius：Double; input-only The radius of the arc. 因此，在定义Radius时为一double型变量即可。 StartAngle, EndAngle: Double; input-only The start and end angles, in radians, defining the arc. A start angle greater than an end angle defines a counterclockwise arc. 同上面一样，StartAngle, EndAngle为double型变量。但值得注意的是，开始角与结束角在编程时要以弧度制，而不是以角度制出现。可外面显示又最好为角度制，这样可以方便读取，因此，在编程时我们要做适当的转换。 在CAD帮助文件中可以查到Arc的添加形式为： Set arcObj = ThisDrawing.ModelSpace.AddArc(centerPoint, radius, startAngleInRadian, endAngleInRadian) 可以看出，曲线与直线的添加形式基本上一致，只是个中的参数发生变化了。这样，我们就可以编程实现对Arc的创建了： 先定义四个参数和一个创建对象： Dim mArc As AcadArc Dim mCen(2) As Double Dim mR As Double Dim mStAga As Double Dim mEnAg As Double 获取参数数值，这里同样是以在窗体上添加文本Text的形式给出： mCen(0) = Val(Text1.Text) mCen(1) = Val(Text2.Text) mCen(2) = Val(Text3.Text) mR = Val(Text4.Text) mStAg = Val(Text5.Text) * 3.1415926 / 180 mEnAg = Val(Text6.Text) * 3.1415926 / 180 Set mArc = acadDoc.ModelSpace.AddArc(mCen, mR, mStAg, mEnAg) 10-3 mArc.Update ZoomAll 同直线一样，我们只要将上述程序代码放在VB一操作事件(如Click)中，就可以实现对曲线Arc的创建了。当然，也获取了对曲线Arc的控制权。在以后的对象创建过程中就不将仔细介绍，方法基本一样。 五、 介绍圆的画法： RetVal = object.AddCircle(Center, Radius) Dim circleObj As AcadCircle Dim centerPoint(0 To 2) As Double Dim radius As Double ' Define the circle centerPoint(0) = 0#: centerPoint(1) = 0#: centerPoint(2) = 0# radius = 5# ' Create the Circle object in model space Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius) ZoomAll 六、 介绍椭圆画法： RetVal = object.AddEllipse(Center, MajorAxis, RadiusRatio) ' This example creates an ellipse in model space. Dim ellObj As AcadEllipse Dim majAxis(0 To 2) As Double Dim center(0 To 2) As Double Dim radRatio As Double ' Create an ellipse in model space center(0) = 5#: center(1) = 5#: center(2) = 0# majAxis(0) = 10: majAxis(1) = 20#: majAxis(2) = 0# radRatio = 0.3 Set ellObj = ThisDrawing.ModelSpace.AddEllipse(center, majAxis, radRatio) ZoomAll 七、 常用属性设置： 颜色设置： Dim color As AcadAcCmColor Set color = _ AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16") Call color.SetRGB(80, 100, 244) 10-4 circleObj.TrueColor = color ZoomAll 线型设置： 线型是重复的划、点和空格组成的图案。复杂线型则是重复符号的图案。要使用线型，必须先将其加载到图形中。加载之前，LIN 库文件中必须存在该线型的定义。 '线型设置 Dim mEntry As AcadLineType Dim mFound As Boolean mFound = False For Each mEntry In acadDoc.Linetypes If StrComp(mEntry.Name, "CONTINUOUS", 1) = 0 Then mFound = True Exit For End If Next If Not (mFound) Then acadDoc.Linetypes.Load "CONTINUOUS", "acadiso.lin" mLine.Linetype = "CONTINUOUS" 背景设置： Dim mPreferences As AcadPreferences Dim mCurrGraphicsWinModelBackgrndColor As OLE_COLOR '背景设置 Set mPreferences = acadDoc.Application.Preferences mCurrGraphicsWinModelBackgrndColor = mPreferences.Display.GraphicsWinModelBackgrndColor mPreferences.Display.GraphicsWinModelBackgrndColor = vbRed 缩放设置： Dim mScalefactor As Double Dim mScaletype As Integer '比例大小设置 mScalefactor = Val(Text1.Text) mScaletype = acZoomScaledAbsolute acadDoc.Application.ZoomScaled mScalefactor, mScaletype 文字设置： 10-5 RetVal = object.AddText(TextString, InsertionPoint, Height) ' This example creates a text object in model space. Dim textObj As AcadText Dim textString As String Dim insertionPoint(0 To 2) As Double Dim height As Double ' Define the text object textString = "Hello, World." insertionPoint(0) = 2: insertionPoint(1) = 2: insertionPoint(2) = 0 height = 0.5 ' Create the text object in model space Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height) ZoomAll 选择集设置： 使用以下任何一种方法向活动的选择集添加对象： Mode：acSelectionSetWindow ；acSelectionSetCrossing ；acSelectionSetPrevious； acSelectionSetLast acSelectionSetAll Window ： Selects all objects completely inside a rectangular area whose corners are defined by Point1 and Point2. Crossing ： Selects objects within and crossing a rectangular area whose corners are defined by Point1 and Point2. Previous ：Selects the most recent selection set. This mode is ignored if you switch between paper space and model space and attempt to use the selection set. Last ：Selects the most recently created visible objects. All ：Selects all objects. Select选择对象并将其放到活动的选择集中。 用户可以选择所有对象、位于矩形区域内或与其相交的对象、位于多边形区域内或与其相交的对象、与选择栏相交的所有对象、最近创建的对象、上一个选择集中的对象、窗口内的对象，以及多边形窗口内的对象。 object.Select Mode, Point1, Point2, FilterType, FilterData Dim ssetObj As AcadSelectionSet Set ssetObj = ThisDrawing.SelectionSets.Add("SSET") ssetObj.Select mode, corner1, corner2 Dim groupCode As Variant, dataCode As Variant groupCode = gpCode dataCode = dataValue 10-6 ssetObj.Select mode, corner1, corner2, groupCode, dataCode SelectAtPoint选择穿过给定点的对象并将其放到活动的选择集中。 object.SelectAtPoint Point, FilterType, FilterData ' Create the selection set Dim ssetObj As AcadSelectionSet Set ssetObj = ThisDrawing.SelectionSets.Add("TEST_SSET1") Dim groupCode As Variant, dataCode As Variant groupCode = gpCode dataCode = dataValue ssetObj.SelectAtPoint point, groupCode, dataCode SelectByPolygon选择位于选择栏内的对象并将其添加到活动的选择集中。 object.SelectByPolygon Mode, PointsList, FilterType, FilterData Dim ssetObj As AcadSelectionSet Set ssetObj = ThisDrawing.SelectionSets.Add("TEST_SSET2") ssetObj.SelectByPolygon mode, pointsArray Dim groupCode As Variant, dataCode As Variant groupCode = gpCode dataCode = dataValue ssetObj.SelectByPolygon mode, pointsArray, groupCode, dataCode SelectOnScreen提示用户在屏幕上拾取的对象并将其添加到活动的选择集中。 object.SelectOnScreen FilterType, FilterData 样式设置： ADDBLOCK: Dim blockObj As AcadBlock Dim insertionPnt(0 To 2) As Double insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0# Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "New_Block") ADDDICTIONARY: Dim dictObj As AcadDictionary Set dictObj = ThisDrawing.Dictionaries.Add("New_Dictionary") ADDDIMSTYLE: 10-7 Dim DimStyleObj As AcadDimStyle Set DimStyleObj = ThisDrawing.DimStyles.Add("New_Dimstyle") ADDGROUP: Dim groupObj As AcadGroup Set groupObj = ThisDrawing.Groups.Add("New_Group") ADDLAYER: Dim layerObj As AcadLayer Set layerObj = ThisDrawing.Layers.Add("New_Layer") ThisDrawing.ActiveLayer = layerObj ADDREGISTEREDAPP: Dim RegAppObj As AcadRegisteredApplication Set RegAppObj = ThisDrawing.RegisteredApplications.Add("New_RegApp") ADDSELECTIONSET: Dim ssetObj As AcadSelectionSet Set ssetObj = ThisDrawing.SelectionSets.Add("New_SelectionSet") ADDTEXTSTYLE: Dim txtStyleObj As AcadTextStyle Set txtStyleObj = ThisDrawing.TextStyles.Add("New_Textstyle") ADDVIEW: Dim viewObj As AcadView Set viewObj = ThisDrawing.Views.Add("New_View") ADDVIEWPORT: Dim vportObj As AcadViewport Set vportObj = ThisDrawing.Viewports.Add("New_Viewport") ADDUCS: Dim ucsObj As AcadUCS Dim origin(0 To 2) As Double Dim xAxisPnt(0 To 2) As Double Dim yAxisPnt(0 To 2) As Double Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "New_UCS") 八、 添加面域： RetVal = object.AddRegion(ObjectList) Dim curves(0 To 1) As AcadEntity 10-8 接下来需创建2个curve对象。 Dim regionObj As Variant regionObj = ThisDrawing.ModelSpace.AddRegion(curves) RoundRoomObj.Boolean acSubtraction/acadIntersection/acUnion, PillarObj ZoomAll object.Boolean(Operation, Object) Operation : acUnion: Performs a union operation. acIntersection: Performs an intersection operation. acSubtraction: Performs a subtraction operation. 有如下例子 Dim mCir(1) As AcadCircle Dim mCen(2) As Double Dim mR As Double mCen(0) = 50 mCen(1) = 80 mR = 50 Set mCir(0) = acadDoc.ModelSpace.AddCircle(mCen, mR) mCir(0).Update mR = 90 Set mCir(1) = acadDoc.ModelSpace.AddCircle(mCen, mR) mCir(1).Update Dim mRegion As Variant mRegion = acadDoc.ModelSpace.AddRegion(mCir) Dim mRegion1 As AcadRegion Dim mRegion2 As AcadRegion Set mRegion1 = mRegion(0) Set mRegion2 = mRegion(1) mRegion1.Boolean acSubtraction, mRegion2 ZoomAll 九、 添加块： ' Create the block Dim blockObj As AcadBlock Dim insertionPnt(0 To 2) As Double insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0# Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "mBlock") ' Add a circle to the block Dim circleObj As AcadCircle Dim center(0 To 2) As Double Dim radius As Double center(0) = 0: center(1) = 0: center(2) = 0 radius = 1 10-9 Set circleObj = blockObj.AddCircle(center, radius) ' Add a polyline to the block Dim plineObj As AcadLWPolyline Dim points(0 To 5) As Double points(0) = 3: points(1) = 7 points(2) = 9: points(3) = 2 points(4) = 3: points(5) = 5 Set plineObj = blockObj.AddLightWeightPolyline(points) ' Insert the block Dim blockRefObj As AcadBlockReference Dim mInPt(2) As Double mP = acadDoc.Utility.GetPoint mInPt(0) = mP(0): mInPt(1) = mP(1): mInPt(2) = mP(2) insertionPnt(0) = 2#: insertionPnt(1) = 2#: insertionPnt(2) = 0 Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(mInPt, "mBlock", 1#, 1#, 1#, 0) blockRefObj.Update Do While True 用此循环可以多次添加！ Loop 10-10