Autocad例子.doc

1、本例使用 Open 方法打开一个现有图形，并使用 VBA 中的 Dir 函数在打开文件之前检查该文件是否存在。用户应当更改图形文件的名称或路径，以指定自己系统中的现有 AutoCAD 图形文件。
Sub Ch3_OpenDrawing()
Dim dwgName As String
dwgName = "c:\campus.dwg"
If Dir(dwgName) <> "" Then
ThisDrawing.Application.Documents.Open dwgName
Else
MsgBox "File " & dwgName & " does not exist."
End If
End Sub
2、本例使用 Add 方法根据默认模板创建新图形。
Sub Ch3_NewDrawing()
Dim docObj As AcadDocument
Set docObj = ThisDrawing.Application.Documents.Add
End Sub
3、本样例首先用其当前名称保存活动图形，然后再用新名称保存该图形。
Sub Ch3_SaveActiveDrawing()
    ThisDrawing.Save
    ThisDrawing.SaveAs "MyDrawing.dwg"
End Sub
4、本例检查是否存在未保存的更改，并验证用户是否选择“确定”以保存图形（如果没有选择“确定”，跳至结尾处）。如果用户选择“确定”，将使用 Save 方法保存当前图形，如下所示：
Sub Ch3_TestIfSaved()
If Not (ThisDrawing.Saved) Then
If MsgBox("Do you wish to save this drawing?", _
vbYesNo) = vbYes Then
ThisDrawing.Save
End If
End If
End Sub
5、将十字光标设置为全屏
Sub Ch2_PrefsSetCursor()
    Dim acadPref As AcadPreferences
Set acadPref = ThisDrawing.Application.Preferences
    acadPref.Display.CursorSize = 100
End Sub
6、显示屏幕菜单和滚动条
Sub Ch2_PrefsSetDisplay()
    Dim acadPref As AcadPreferences
Set acadPref = ThisDrawing.Application.Preferences
    acadPref.Display.DisplayScreenMenu = True
acadPref.Display.DisplayScrollBars = False
End Sub
7、找出“应用程序”窗口的当前状态
Sub Ch3_CurrentWindowState()
Dim CurrWindowState As Integer
Dim msg As String
CurrWindowState = ThisDrawing.Application.WindowState
msg = Choose(CurrWindowState, "normal", _
"minimized", "maximized")
MsgBox "The application window is " + msg
End Sub

8、查看活动“文档”窗口的当前状态
Sub Ch3_CurrentWindowState()
Dim CurrWindowState As Integer
Dim msg As String
CurrWindowState = ThisDrawing.WindowState
msg = Choose(CurrWindowState, "normal", _
"minimized", "maximized")
MsgBox "The document window is " + msg
End Sub
窗口以及检查窗口的当前状态。
9、更改“应用程序”窗口的位置和大小
本例使用 WindowTop、WindowLeft、Width 和 Height 特性将 AutoCAD“应用程序”窗口放在屏幕的左上角，并将其大小调整为宽 400 像素、高 400 像素。
Sub Ch3_PositionApplicationWindow()
ThisDrawing.Application.WindowTop = 0
ThisDrawing.Application.WindowLeft = 0
ThisDrawing.Application.width = 400
ThisDrawing.Application.height = 400
End Sub
10、最大化“应用程序”窗口
Sub Ch3_MaximizeApplicationWindow()
ThisDrawing.Application.WindowState = acMax
End Sub
11、最小化“应用程序”窗口
Sub Ch3_MinimizeApplicationWindow()
ThisDrawing.Application.WindowState = acMin
End Sub
12、本例查询“应用程序”窗口的状态，并将该状态以消息框的形式显示给用户。
Sub Ch3_CurrentWindowState()
Dim CurrWindowState As Integer
Dim msg As String
CurrWindowState = ThisDrawing.Application.WindowState
msg = Choose(CurrWindowState, "normal", _
"minimized", "maximized")
MsgBox "The application window is " + msg
End Sub

本例使用 GetDistance 方法获取点的坐标，并使用 MsgBox 函数显示计算出的距离。
Sub Ch3_GetDistanceBetweenTwoPoints()
Dim returnDist As Double
    returnDist = ThisDrawing.Utility.GetDistance _
(, "Pick two points.")
MsgBox "The distance between the two points is:" & returnDist
End Sub
13、查看活动“文档”窗口的当前状态
Sub Ch3_CurrentWindowState()
Dim CurrWindowState As Integer
Dim msg As String
CurrWindowState = ThisDrawing.WindowState
msg = Choose(CurrWindowState, "normal", _
"minimized", "maximized")
MsgBox "The document window is " + msg
End Sub
14、本例使用 GetDistance 方法获取点的坐标，并使用 MsgBox 函数显示计算出的距离。
Sub Ch3_GetDistanceBetweenTwoPoints()
Dim returnDist As Double
    returnDist = ThisDrawing.Utility.GetDistance _
(, "Pick two points.")
MsgBox "The distance between the two points is:" & returnDist
End Sub
15、本例提示用户输入五个点，然后根据输入的点创建多段线。该多段线是闭合的，所形成的面积显示在消息框中。
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 & "First point: ")
p2 = ThisDrawing.Utility.GetPoint(p1, vbCrLf & "Second point: ")
p3 = ThisDrawing.Utility.GetPoint(p2, vbCrLf & "Third point: ")
p4 = ThisDrawing.Utility.GetPoint(p3, vbCrLf & "Fourth point: ")
p5 = ThisDrawing.Utility.GetPoint(p4, vbCrLf & "Fifth point: ")
    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 "The area defined by the points is " & _
polyObj.Area, , "Calculate Defined Area"
End Sub

16、GetString 方法
Sub Ch3_GetStringFromUser()
Dim retVal As String
retVal = ThisDrawing.Utility.GetString _
(1, vbCrLf & "Enter your name: ")
MsgBox "The name entered was:" & retVal
End Sub
17、GetPoint 方法
Sub Ch3_GetPointsFromUser()
Dim startPnt As Variant
Dim endPnt As Variant
Dim prompt1 As String
Dim prompt2 As String
prompt1 = vbCrLf & "Enter the start point of the line: "
prompt2 = vbCrLf & "Enter the end point of the line: "
    startPnt = ThisDrawing.Utility.GetPoint(, prompt1)
    endPnt = ThisDrawing.Utility.GetPoint(startPnt, prompt2)
    ThisDrawing.ModelSpace.AddLine startPnt, endPnt
ThisDrawing.Application.ZoomAll
End Sub
18、GetKeyword 方法
Sub Ch3_KeyWord()
Dim keyWord As String
ThisDrawing.Utility.InitializeUserInput 1, "Line Circle Arc"
keyWord = ThisDrawing.Utility.GetKeyword _
(vbCrLf & "Enter an option (Line/Circle/Arc): ")
MsgBox keyWord, , "GetKeyword Example"
End Sub
19、更为友好的关键字提示是当用户按 ENTER 键（NULL 输入）时提供默认值。请注意下面样例中的微小修改：
Sub Ch3_KeyWord2()
Dim keyWord As String
ThisDrawing.Utility.InitializeUserInput 0, "Line Circle Arc"
keyWord = ThisDrawing.Utility.GetKeyword _
(vbCrLf & "Enter an option (Line/Circle/<Arc>): ")
If keyWord = "" Then keyWord = "Arc"
MsgBox keyWord, , "GetKeyword Example"
End Sub
20、本例使用AddLine方法创建一条直线，其端点坐标值分别是 (1,1,0)、(5,5,0)。
Sub Example_AddLine()
' This example adds a line in model space
Dim lineObj As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
' Define the start and end points for the line
startPoint(0) = 1#: startPoint(1) = 1#: startPoint(2) = 0#
endPoint(0) = 5#: endPoint(1) = 5#: endPoint(2) = 0#
' Create the line in model space
Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
ZoomAll
End Sub
21、本例使用 AddLightweightPolyline 方法创建一条分为两段的简单多段线，其端点坐标值分别是 (2,4)、(4,2) 和 (6,4)。
Sub Ch4_AddLightWeightPolyline()
Dim plineObj As AcadLWPolyline
Dim points(0 To 5) As Double
    points(0) = 2:points(1) = 4
points(2) = 4:points(3) = 2
points(4) = 6:points(5) = 4
    Set plineObj = ThisDrawing.ModelSpace. _
AddLightWeightPolyline(points)
    ThisDrawing.Application.ZoomAll
End Sub
22、本例使用三点 (0,0,0)、(5,5,0) 和 (10,0,0) 在模型空间中创建样条曲线。该样条曲线的起点切向和端点切向为 (0.5,0.5,0.0)。
Sub Ch4_CreateSpline()
    Dim splineObj As AcadSpline
Dim startTan(0 To 2) As Double
Dim endTan(0 To 2) As Double
Dim fitPoints(0 To 8) As Double
    startTan(0) = 0.5:startTan(1) = 0.5:startTan(2) = 0
endTan(0) = 0.5:endTan(1) = 0.5:endTan(2) = 0
fitPoints(0) = 1:fitPoints(1) = 1:fitPoints(2) = 0
fitPoints(3) = 5:fitPoints(4) = 5:fitPoints(5) = 0
fitPoints(6) = 10:fitPoints(7) = 0:fitPoints(8) = 0
    Set splineObj = ThisDrawing.ModelSpace.AddSpline _
(fitPoints, startTan, endTan)
ZoomAll
End Sub

23、本例使用AddCircle在模型空间中创建圆对象。
Sub Example_AddCircle()
Dim circleObj As AcadCircle
Dim centerPoint(0 To 2) As Double
Dim radius As Double
centerPoint(0) = 0#: centerPoint(1) = 0#: centerPoint(2) = 0#
radius = 5#
Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)
ZoomAll

End Sub
24、下例在模型空间中创建坐标为 (5,5,0) 的 Point 对象，然后更新 PDMODE 和 PDSIZE 系统变量。
Sub Ch4_CreatePoint()
Dim pointObj As AcadPoint
Dim location(0 To 2) As Double
    location(0) = 5#:location(1) = 5#:location(2) = 0#
    Set pointObj = ThisDrawing.ModelSpace.AddPoint(location)
ThisDrawing.SetVariable "PDMODE", 34
ThisDrawing.SetVariable "PDSIZE", 1
ZoomAll
End Sub
25、下例使用坐标 (0,0,0)、(5,0,0)、(5,8,0) 和 (0,8,0) 在模型空间中创建四边形实体。
Sub Ch4_CreateSolid()
Dim solidObj As AcadSolid
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
Dim point3(0 To 2) As Double
Dim point4(0 To 2) As Double
    point1(0) = 0#:point1(1) = 0#:point1(2) = 0#
point2(0) = 5#:point2(1) = 0#:point2(2) = 0#
point3(0) = 5#:point3(1) = 8#:point3(2) = 0#
point4(0) = 0#:point4(1) = 8#:point4(2) = 0#
Set solidObj = ThisDrawing.ModelSpace.AddSolid _
(point1, point2, point3, point4)
    ZoomAll
End Sub
26、下例从一个圆创建面域。
Sub Ch4_CreateRegion()
    Dim curves(0 To 0) As AcadCircle
    Dim center(0 To 2) As Double
    Dim radius As Double
center(0) = 2
center(1) = 2
center(2) = 0
radius = 5#
Set curves(0) = ThisDrawing.ModelSpace.AddCircle _
(center, radius)
    Dim regionObj As Variant
regionObj = ThisDrawing.ModelSpace.AddRegion(curves)

ZoomAll
End Sub
27、本例创建一个新的选择集。
Sub Ch4_CreateSelectionSet()
Dim selectionSet1 As AcadSelectionSet
Set selectionSet1 = ThisDrawing.SelectionSets. _
Add("NewSelectionSet")
End Sub
28、本例提示用户选择对象，然后将这些对象添加到选择集中。
Sub Ch4_AddToASelectionSet()
    Dim sset As AcadSelectionSet
Set sset = ThisDrawing.SelectionSets.Add("SS1")
    sset.SelectOnScreen
End Sub
29、以下代码提示用户选择要包含在选择集中的对象，但仅当选择的对象是 Circle 时才将其添加到选择集中：
Sub Ch4_FilterMtext()
Dim sstext As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Set sstext = ThisDrawing.SelectionSets.Add("SS2")
FilterType(0) = 0
FilterData(0) = "Circle"
sstext.SelectOnScreen FilterType, FilterData
End Sub
30、以下代码指定两个条件：对象必须是圆，并且必须在图层 0 上。代码将 FilterType 和 FilterData 声明为两个元素的数组，并将每个条件指定给一个元素：
Sub Ch4_FilterBlueCircleOnLayer0()
Dim sstext As AcadSelectionSet
Dim FilterType(1) As Integer
Dim FilterData(1) As Variant
Set sstext = ThisDrawing.SelectionSets.Add("SS4")
FilterType(0) = 0
FilterData(0) = "Circle"
FilterType(1) = 8
FilterData(1) = "0"
sstext.SelectOnScreen FilterType, FilterDate
End Sub
31、本例创建两个 Circle 对象并使用 CopyObjects 方法创建圆的副本。
Sub Ch4_CopyCircleObjects()
Dim DOC1 As AcadDocument
Dim circleObj1 As AcadCircle
Dim circleObj2 As AcadCircle
Dim circleObj1Copy As AcadCircle
Dim circleObj2Copy As AcadCircle
Dim centerPoint(0 To 2) As Double
Dim radius1 As Double
Dim radius2 As Double
Dim radius1Copy As Double
Dim radius2Copy As Double
Dim objCollection(0 To 1) As Object
Dim retObjects As Variant
    centerPoint(0) = 0:centerPoint(1) = 0:centerPoint(2) = 0
radius1 = 5#:radius2 = 7#
radius1Copy = 1#:radius2Copy = 2#
    Set DOC1 = ThisDrawing.Application.Documents.Add
    Set circleObj1 = DOC1.ModelSpace.AddCircle _
(centerPoint, radius1)
Set circleObj2 = DOC1.ModelSpace.AddCircle _
(centerPoint, radius2)
ZoomAll
    Set objCollection(0) = circleObj1
Set objCollection(1) = circleObj2
    retObjects = DOC1.CopyObjects(objCollection)
    Set circleObj1Copy = retObjects(0)
Set circleObj2Copy = retObjects(1)

circleObj1Copy.radius = radius1Copy
circleObj1Copy.Color = acRed
circleObj2Copy.radius = radius2Copy
circleObj2Copy.Color = acRed

ZoomAll
End Sub
32、本例创建 Circle 对象，然后使用 CopyObjects 方法将圆复制到新的图形中。
Sub Ch4_Copy_to_New_Drawing()
Dim DOC0 As AcadDocument
Dim circleObj1 As AcadCircle, circleObj2 As AcadCircle
Dim centerPoint(0 To 2) As Double
Dim radius1 As Double, radius2 As Double
Dim radius1Copy As Double, radius2Copy As Double
Dim objCollection(0 To 1) As Object
Dim retObjects As Variant
    centerPoint(0) = 0:centerPoint(1) = 0:centerPoint(2) = 0
radius1 = 5#:radius2 = 7#
radius1Copy = 1#:radius2Copy = 2#
    Set circleObj1 = ThisDrawing.ModelSpace.AddCircle _
(centerPoint, radius1)
Set circleObj2 = ThisDrawing.ModelSpace.AddCircle _
(centerPoint, radius2)
ThisDrawing.Application.ZoomAll
    Set DOC0 = ThisDrawing.Application.ActiveDocument
    Set objCollection(0) = circleObj1
Set objCollection(1) = circleObj2
    Dim Doc1MSpace As AcadModelSpace
Dim DOC1 As AcadDocument

Set DOC1 = Documents.Add
Set Doc1MSpace = DOC1.ModelSpace
    retObjects = DOC0.CopyObjects(objCollection, Doc1MSpace)
Dim circleObj1Copy As AcadCircle, circleObj2Copy As AcadCircle
    Set circleObj1Copy = retObjects(0)
Set circleObj2Copy = retObjects(1)
circleObj1Copy.radius = radius1Copy
circleObj1Copy.Color = acRed
circleObj2Copy.radius = radius2Copy
circleObj2Copy.Color = acRed
ThisDrawing.Application.ZoomAll
MsgBox "Circles copied."
End Sub
33、本例创建一条优化多段线，然后偏移该多段线。
Sub Ch4_OffsetPolyline()
    Dim plineObj As AcadLWPolyline
Dim points(0 To 11) As Double
points(0) = 1:points(1) = 1
points(2) = 1:points(3) = 2
points(4) = 2:points(5) = 2
points(6) = 3:points(7) = 2
points(8) = 4:points(9) = 4
points(10) = 4:points(11) = 1
Set plineObj = ThisDrawing.ModelSpace. _
AddLightWeightPolyline(points)
plineObj.Closed = True
ZoomAll
    Dim offsetObj As Variant
offsetObj = plineObj.Offset(0.25)
ZoomAll
End Sub
34、本例创建一条优化多段线，然后绕一个轴镜像该多段线。新创建的多段线会着上蓝色。
Sub Ch4_MirrorPolyline()
    Dim plineObj As AcadLWPolyline
Dim points(0 To 11) As Double
points(0) = 1:points(1) = 1
points(2) = 1:points(3) = 2
points(4) = 2:points(5) = 2
points(6) = 3:points(7) = 2
points(8) = 4:points(9) = 4
points(10) = 4:points(11) = 1
Set plineObj = ThisDrawing.ModelSpace. _
AddLightWeightPolyline(points)
plineObj.Closed = True
ZoomAll
    Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
point1(0) = 0:point1(1) = 4.25:point1(2) = 0
point2(0) = 4:point2(1) = 4.25:point2(2) = 0
    Dim mirrorObj As AcadLWPolyline
Set mirrorObj = plineObj.Mirror(point1, point2)
    Dim col As New AcadAcCmColor
Call col.SetRGB(125, 175, 235)
mirrorObj.TrueColor = col
ZoomAll
End Sub
35、本例创建一个圆，然后对圆执行环形阵列操作。这个过程将围绕基点 (4,4,0)，在 180 度内创建四个圆。
Sub Ch4_Arra