水利人的网上家园，www.shuigong.com


本例创建 MText 对象。接着使用 MText 对象作为其注释来创建引线。

Sub Ch5_AddAnnotation()

Dim leaderObj As AcadLeader

Dim mtextObj As AcadMText

Dim points(0 To 8) As Double

Dim insertionPoint(0 To 2) As Double

Dim width As Double

Dim leaderType As Integer

Dim annotationObject As Object

Dim textString As String, msg As String

' 在模型空间中创建 MText 对象

textString = "Hello, World."

insertionPoint(0) = 5

insertionPoint(1) = 5

insertionPoint(2) = 0

width = 2

Set mtextObj = ThisDrawing.ModelSpace. _

AddMText(insertionPoint, width, textString)

' 引线的数据

points(0) = 0: points(1) = 0: points(2) = 0

points(3) = 4: points(4) = 4: points(5) = 0

points(6) = 4: points(7) = 5: points(8) = 0

leaderType = acLineWithArrow

' 在模型空间中创建 Leader 对象并关联

' MText 对象和引线

Set annotationObject = mtextObj

Set leaderObj = ThisDrawing.ModelSpace. _

AddLeader(points, annotationObject, leaderType)

ZoomAll

End Sub


本例在模型空间中创建半径标注。

Sub Ch5_CreateRadialDimension()

Dim dimObj As AcadDimRadial

Dim center(0 To 2) As Double

Dim chordPoint(0 To 2) As Double

Dim leaderLen As Integer

' 定义标注

center(0) = 0

center(1) = 0

center(2) = 0

chordPoint(0) = 5

chordPoint(1) = 5

chordPoint(2) = 0

leaderLen = 5

' 在模型空间中创建半径标注

Set dimObj = ThisDrawing.ModelSpace. _

AddDimRadial(center, chordPoint, leaderLen)

ZoomAll

End Sub

注意 只有当标注设置为使用默认的文字位置值时，才会在创建标注时使用 LeaderLength 设置。在第一次关闭标注之后，修改 LeaderLength 的值不会影响标注的显示，但是新的设置会被存储并在 DXF、LISP 和 ADSRX 应用程序中表现出来。


本例在模型空间中创建角度标注。

Sub Ch5_CreateAngularDimension()

Dim dimObj As AcadDimAngular

Dim angVert(0 To 2) As Double

Dim FirstPoint(0 To 2) As Double

Dim SecondPoint(0 To 2) As Double

Dim TextPoint(0 To 2) As Double

' 定义标注

angVert(0) = 0

angVert(1) = 5

angVert(2) = 0

FirstPoint(0) = 1

FirstPoint(1) = 7

FirstPoint(2) = 0

SecondPoint(0) = 1

SecondPoint(1) = 3

SecondPoint(2) = 0

TextPoint(0) = 3

TextPoint(1) = 5

TextPoint(2) = 0

' 在模型空间中创建角度标注

Set dimObj = ThisDrawing.ModelSpace. _

AddDimAngular(angVert, FirstPoint, SecondPoint, TextPoint)

ZoomAll


本例在模型空间中创建坐标标注。

Sub Ch5_CreatingOrdinateDimension()

Dim dimObj As AcadDimOrdinate

Dim definingPoint(0 To 2) As Double

Dim leaderEndPoint(0 To 2) As Double

Dim useXAxis As Long

' 定义标注

definingPoint(0) = 5

definingPoint(1) = 5

definingPoint(2) = 0

leaderEndPoint(0) = 10

leaderEndPoint(1) = 5

leaderEndPoint(2) = 0

useXAxis = 5

' 在模型空间中创建坐标标注

Set dimObj = ThisDrawing.ModelSpace. _

AddDimOrdinate(definingPoint, _

leaderEndPoint, useXAxis)

ZoomAll


本例向标注值附加了文字，所以既显示字符串，又显示标注值。

Sub Ch5_OverrideDimensionText()

Dim dimObj As AcadDimAligned

Dim point1(0 To 2) As Double

Dim point2(0 To 2) As Double

Dim location(0 To 2) As Double

' 定义标注

point1(0) = 5#: point1(1) = 3#: point1(2) = 0#

point2(0) = 10#: point2(1) = 3#: point2(2) = 0#

location(0) = 7.5: location(1) = 5#: location(2) = 0#

' 在模型空间中创建对齐标注对象

Set dimObj = ThisDrawing.ModelSpace. _

AddDimAligned(point1, point2, location)

' 修改标注的字符串

dimObj.TextOverride = "The value is <>"

dimObj.Update


本样例创建三个新的标注样式，并将文档、给定标注样式和给定标注的当前设置分别复制到各个新的标注样式中。如果在运行此样例之前进行适当的设置，将发现创建的是不同的标注样式。

  1. 创建新的图形并使其成为活动的图形。
  2. 在新的图形中创建线性标注。此标注应该是图形中仅有的对象。
  3. 使用 OPM，将尺寸线的颜色改为黄色。
  4. 将 DIMCLRD 系统变量改为 5（蓝色）。
  5. 运行以下样例：

Sub Ch5_CopyDimStyles()

Dim newStyle1 As AcadDimStyle

Dim newStyle2 As AcadDimStyle

Dim newStyle3 As AcadDimStyle

Set newStyle1 = ThisDrawing.DimStyles.Add _

("Style 1 copied from a dim")

Call newStyle1.CopyFrom(ThisDrawing.ModelSpace(0))

Set newStyle2 = ThisDrawing.DimStyles.Add _

("Style 2 copied from Style 1")

Call newStyle2.CopyFrom(ThisDrawing.DimStyles.Item _

("Style 1 copied from a dim"))

Set newStyle2 = ThisDrawing.DimStyles.Add _

("Style 3 copied from the running drawing values")

Call newStyle2.CopyFrom(ThisDrawing)

End Sub

打开 DIMSTYLE 对话框。现在应该列出了 3 种标注样式。样式 1 应该具有黄色的尺寸线，样式 2 应该与样式 1 相同，而样式 3 应该具有蓝色的尺寸线。


本例在模型空间中创建引线。引线没有关联的注释。

Sub Ch5_CreateLeader()

Dim leaderObj As AcadLeader

Dim points(0 To 8) As Double

Dim leaderType As Integer

Dim annotationObject As AcadObject

points(0) = 0: points(1) = 0: points(2) = 0

points(3) = 4: points(4) = 4: points(5) = 0

points(6) = 4: points(7) = 5: points(8) = 0

leaderType = acLineWithArrow

Set annotationObject = Nothing

' 在模型空间中创建引线对象

Set leaderObj = ThisDrawing.ModelSpace. _

AddLeader(points, annotationObject, leaderType)

ZoomAll


本例在模型空间中创建对齐标注，并使用 TextSuffix 特性让用户来修改标注的文字后缀。

Sub Ch5_AddTextSuffix()

Dim dimObj As AcadDimAligned

Dim point1(0 To 2) As Double

Dim point2(0 To 2) As Double

Dim location(0 To 2) As Double

Dim suffix As String

' 定义标注

point1(0) = 0: point1(1) = 5: point1(2) = 0

point2(0) = 5: point2(1) = 5: point2(2) = 0

location(0) = 5: location(1) = 7: location(2) = 0

' 在模型空间中创建对齐标注对象

Set dimObj = ThisDrawing.ModelSpace. _

AddDimAligned(point1, point2, location)

ThisDrawing.Application.ZoomAll

' 允许用户修改标注的文字后缀

suffix = InputBox("Enter a new text suffix for the dimension" _

, "Set Dimension Suffix", ":SUFFIX")

' 将修改应用到标注

dimObj.TextSuffix = suffix

ThisDrawing.Regen acAllViewports


本例创建新的菜单 TestMenu，并在其中插入一个菜单项。向该菜单项指定 OPEN 命令，然后在菜单栏上显示该菜单。

Sub Ch6_InsertMenu()

' 定义当前菜单组的变量

Dim currMenuGroup As AcadMenuGroup

Set currMenuGroup = ThisDrawing.Application. _

MenuGroups.Item(0)

' 创建新菜单

Dim newMenu As AcadPopupMenu

Set newMenu = currMenuGroup.Menus.Add("TestMenu")

' 声明表示菜单项的变量

Dim newMenuItem As AcadPopupMenuItem

Dim openMacro As String

' 指定宏字符串“ESC ESC _open”的 VB 等价值

' 并创建菜单项

openMacro = Chr(vbKeyEscape) + Chr(vbKeyEscape) + "_open "

Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, _

"Open", openMacro)

' 在菜单栏上显示菜单

currMenuGroup.Menus.InsertMenuInMenuBar "TestMenu", ""


本例删除菜单栏上的第一个菜单，然后将其作为最后一个菜单插入到菜单栏中。

Sub Ch6_MoveMenu()

' 定义一个变量来保存要移动的菜单

Dim moveMenu As AcadPopupMenu

Dim MyMenuBar As AcadMenuBar

Set MyMenuBar = ThisDrawing.Application.menuBar

' 将 moveMenu 设置为等于菜单栏上

' 显示的第一个菜单

Set moveMenu = MyMenuBar.Item(0)

' 从菜单栏中删除第一个菜单

MyMenuBar.Item(0).RemoveFromMenuBar

' 将菜单添加回菜单栏上的

' 最后一个位置

moveMenu.InsertInMenuBar (MyMenuBar.count)


本例在 MenuGroups 集合的第一个菜单组中创建新的弹出式菜单 TestMenu。

Sub Ch6_CreateMenu()

Dim currMenuGroup As AcadMenuGroup

Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

' 创建新菜单

Dim newMenu As AcadPopupMenu

Set newMenu = currMenuGroup.Menus.Add("TestMenu")


本例创建一个新的菜单 TestMenu，并向其中插入菜单项。菜单项的名称为“Open”，而指定给该菜单项的宏是 OPEN 命令。

Sub Ch6_AddAMenuItem()

Dim currMenuGroup As AcadMenuGroup

Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

' 创建新菜单

Dim newMenu As AcadPopupMenu

Set newMenu = currMenuGroup.Menus.Add("TestMenu")

' 向新菜单添加菜单项

Dim newMenuItem As AcadPopupMenuItem

Dim openMacro As String

' 给宏指定“ESC ESC _open”的 VBA 等价值

openMacro = Chr(vbKeyEscape) + Chr(vbKeyEscape) + "_open "

Set newMenuItem = newMenu.AddMenuItem _

(newMenu.count + 1, "Open", openMacro)

' 在菜单栏上显示菜单

newMenu.InsertInMenuBar _

(ThisDrawing.Application.menuBar.count + 1)


本例重复使用 向弹出式菜单添加菜单项中的样例，向 TestMenu 和 Open 菜单添加加速键。“s”用作 TestMenu 菜单的加速键，“O”用作 Open 菜单的加速键。

Sub Ch6_AddAMenuItem()

Dim currMenuGroup As AcadMenuGroup

Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

' 创建新菜单

Dim newMenu As AcadPopupMenu

Set newMenu = currMenuGroup.Menus.Add _

("Te" + Chr(Asc("&")) + "stMenu")

' 向新菜单添加菜单项

Dim newMenuItem As AcadPopupMenuItem

Dim openMacro As String

' 给宏指定“ESC ESC _open”的 VBA 等价值

openMacro = Chr(vbKeyEscape) + Chr(vbKeyEscape) + "_open "

Set newMenuItem = newMenu.AddMenuItem _

(newMenu.count + 1, Chr(Asc("&")) _

+ "Open", openMacro)

' 在菜单栏上显示菜单

newMenu.InsertInMenuBar _

(ThisDrawing.Application.menuBar.count + 1)


本例创建一个新的菜单 TestMenu，并将其添加到子菜单 OpenFile。然后，子菜单中会填充一个名为 Open 的菜单项，执行该菜单项就打开图形。最后，将菜单显示在菜单栏上。

Sub Ch6_AddASubMenu()

Dim currMenuGroup As AcadMenuGroup

Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

' 创建新菜单

Dim newMenu As AcadPopupMenu

Set newMenu = currMenuGroup.Menus.Add("TestMenu")

' 添加子菜单

Dim FileSubMenu As AcadPopupMenu

Set FileSubMenu = newMenu.AddSubMenu("", "OpenFile")

' 向子菜单添加菜单项

Dim newMenuItem As AcadPopupMenuItem

Dim openMacro As String

' 给宏指定“ESC ESC _open”的 VB 等价值

openMacro = Chr(vbKeyEscape) + Chr(vbKeyEscape) + "_open "

Set newMenuItem = FileSubMenu.AddMenuItem _

(newMenu.count + 1, "Open", openMacro)

' 在菜单栏上显示菜单

newMenu.InsertInMenuBar _

(ThisDrawing.Application.menuBar.count + 1)


本例向菜单栏上的最后一个菜单中添加菜单项，然后再删除该菜单项。

Sub Ch6_DeleteMenuItem()

Dim LastMenu As AcadPopupMenu

Set LastMenu = ThisDrawing.Application.menuBar. _

Item(ThisDrawing.Application.menuBar.count - 1)

' 添加菜单项

Dim newMenuItem As AcadPopupMenuItem

Dim openMacro As String

' 给宏指定“ESC ESC _open”的 VB 等价值

openMacro = Chr(vbKeyEscape) + Chr(vbKeyEscape) + "_open "

Set newMenuItem = LastMenu.AddMenuItem _

(LastMenu.count + 1, "Open", openMacro)

' 从菜单中删除菜单项

newMenuItem.Delete


本例创建一个新菜单 TestMenu，并在其中插入两个菜单项。然后使用 Enable 特性禁用第二个菜单项，最后将菜单显示在菜单栏上。

Sub Ch6_DisableMenuItem()

Dim currMenuGroup As AcadMenuGroup

Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

' 创建新菜单

Dim newMenu As AcadPopupMenu

Set newMenu = currMenuGroup.Menus.Add("TestMenu")

' 向新菜单添加两个菜单项和一个菜单分隔符

Dim MenuEnable As AcadPopupMenuItem

Dim MenuDisable As AcadPopupMenuItem

Dim MenuSeparator As AcadPopupMenuItem

Dim openMacro As String

' 给宏指定“ESC ESC _open”的 VB 等价值

openMacro = Chr(vbKeyEscape) + Chr(vbKeyEscape) + "_open "

Set MenuEnable = newMenu.AddMenuItem _

(newMenu.count + 1, "OpenEnabled", openMacro)

Set MenuSeparator = newMenu.AddSeparator("")

Set MenuDisable = newMenu.AddMenuItem _

(newMenu.count + 1, "OpenDisabled", openMacro)

' 禁用第二个菜单项

MenuDisable.Enable = False

' 在菜单栏上显示菜单

newMenu.InsertInMenuBar _

(ThisDrawing.Application.menuBar.count + 1)


本样例说明如何将 AutoCAD 切换到图纸空间、创建浮动视口、设置视图以及启用视口。

Sub Ch9_SwitchToPaperSpace()

' 将活动空间设置为图纸空间

ThisDrawing.ActiveSpace = acPaperSpace

' 创建图纸空间视口

Dim newVport As AcadPViewport

Dim center(0 To 2) As Double

center(0) = 3.25

center(1) = 3

center(2) = 0

Set newVport = ThisDrawing.PaperSpace. _

AddPViewport(center, 6, 5)

' 修改视口的观察方向

Dim viewDir(0 To 2) As Double

viewDir(0) = 1

viewDir(1) = 1

viewDir(2) = 1

newVport.direction = viewDir

' 启用视口

newVport.Display True

' 切换到模型空间

ThisDrawing.MSpace = True

' 将 newVport 置为当前

' （并非始终需要，但建议如此）

ThisDrawing.ActivePViewport = newVport

' 在模型空间中进行范围缩放

ZoomExtents

' 关闭模型空间编辑

ThisDrawing.MSpace = False

' 在图纸空间中进行范围缩放

ZoomExtents

End Sub

上述代码中的步骤顺序非常重要。一般来讲，步骤的顺序必须与它们在 AutoCAD 命令行中的执行顺序相同。唯一不能预期的操作是定义视图和启用视口。

注意 要设置或修改视图的特性（观察方向、镜头长度等），必须将 Viewport 对象的 Display 方法设置为关闭 (FALSE)；并且，在将某个视口设置为当前视口之前，必须将 Display 方法设置为打开 (TRUE)。


本样例使用了 创建并启用浮动视口中的例子，并以之为基础继续创建了四个浮动视口，同时分别将每个视口的视图设置为俯视图、主视图、右视图和等轴测视图。每个视图按图纸空间比例的一半进行缩放。为确保在这些视口中能够看到一些内容，可以在进行本样例之前创建一个三维实体球体。

Sub Ch9_FourPViewports()

Dim topVport, frontVport As AcadPViewport

Dim rightVport, isoVport As AcadPViewport

Dim pt(0 To 2) As Double

Dim viewDir(0 To 2) As Double

ThisDrawing.ActiveSpace = acPaperSpace

ThisDrawing.MSpace = True

' 获取现有的 PViewport 并使其成为 topVport

pt(0) = 2.5: pt(1) = 5.5: pt(2) = 0

Set topVport = ThisDrawing.ActivePViewport

'对俯视图不需要设置 Direction

topVport.center = pt

topVport.width = 2.5

topVport.height = 2.5

topVport.Display True

ThisDrawing.MSpace = True

ThisDrawing.ActivePViewport = topVport

ZoomExtents

ZoomScaled 0.5, acZoomScaledRelativePSpace

'创建并设置 frontVport

pt(0) = 2.5: pt(1) = 2.5: pt(2) = 0

Set frontVport = ThisDrawing.PaperSpace. _

AddPViewport(pt, 2.5, 2.5)

viewDir(0) = 0: viewDir(1) = 1: viewDir(2) = 0

frontVport.direction = viewDir

frontVport.Display acOn

ThisDrawing.MSpace = True

ThisDrawing.ActivePViewport = frontVport

ZoomExtents

ZoomScaled 0.5, acZoomScaledRelativePSpace

'创建并设置 rightVport

pt(0) = 5.5: pt(1) = 5.5: pt(2) = 0

Set rightVport = ThisDrawing.PaperSpace. _

AddPViewport(pt, 2.5, 2.5)

viewDir(0) = 1: viewDir(1) = 0: viewDir(2) = 0

rightVport.direction = viewDir

rightVport.Display acOn

ThisDrawing.MSpace = True

ThisDrawing.ActivePViewport = rightVport

ZoomExtents

ZoomScaled 0.5, acZoomScaledRelativePSpace

'创建并设置 isoVport

pt(0) = 5.5: pt(1) = 2.5: pt(2) = 0

Set isoVport = ThisDrawing.PaperSpace. _

AddPViewport(pt, 2.5, 2.5)

viewDir(0) = 1: viewDir(1) = 1: viewDir(2) = 1

isoVport.direction = viewDir

isoVport.Display acOn

ThisDrawing.MSpace = True

ThisDrawing.ActivePViewport = isoVport

ZoomExtents

ZoomScaled 0.5, acZoomScaledRelativePSpace

'完成：在所有视口中执行重生成 (regen)

ThisDrawing.Regen True


本例从 Views 集合中删除命名视图。

Sub Ch3_DeleteViewFromCollection()

ThisDrawing.Views("View1").Delete


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


将活动“文档”窗口最大化

Sub Ch3_MaximizeDocumentWindow()

ThisDrawing.WindowState = acMax

End Sub

将活动“文档”窗口最小化

Sub Ch3_MinimizeDocumentWindow()

ThisDrawing.WindowState = acMin


本例将视口拆分为四个窗口，然后遍历图形中的所有视口并显示视口名称以及每个视口的左下角点和右上角点。

Sub Ch3_IteratingViewportWindows()

' 创建新视口并将其置为活动视口

Dim vportObj As AcadViewport

Set vportObj = ThisDrawing.Viewports.Add("TEST_VIEWPORT")

ThisDrawing.ActiveViewport = vportObj

' 将 vport 拆分为 4 个窗口

vportObj.Split acViewport4

' 遍历视口，

' 亮显每个视口并显示

' 每个视口的右上角点和

' 左下角点。

Dim vport As AcadViewport

Dim LLCorner As Variant

Dim URCorner As Variant

For Each vport In ThisDrawing.Viewports

ThisDrawing.ActiveViewport = vport

LLCorner = vport.LowerLeftCorner

URCorner = vport.UpperRightCorner

MsgBox "Viewport: " & vport.Name & " is now active." & _

vbCrLf & "Lower left corner: " & _

LLCorner(0) & ", " & LLCorner(1) & vbCrLf & _

"Upper right corner: " & _

URCorner(0) & ", " & URCorner(1)

Next vport


最大化“应用程序”窗口

Sub Ch3_MaximizeApplicationWindow()

ThisDrawing.Application.WindowState = acMax

End Sub

最小化“应用程序”窗口

Sub Ch3_MinimizeApplicationWindow()

ThisDrawing.Application.WindowState = acMin


下面的样例创建一个新视口，然后将视口拆分为两个水平窗口。

Sub SplitAViewport()

' 创建新视口

Dim vportObj As AcadViewport

Set vportObj = ThisDrawing.Viewports.Add("TEST_VIEWPORT")

' 将 vportObj 拆分为 2 个水平窗口

vportObj.Split acViewport2Horizontal

' 现在将 vportObj 设置为活动视口

ThisDrawing.ActiveViewport = vportObj


下面的代码使用 Visible 特性使 AutoCAD 应用程序对最终用户不可见。

Sub Ch3_HideWindowState()

ThisDrawing.Application.Visible = False


Sub Ch3_ZoomWindow()

' ZoomWindow

MsgBox "Perform a ZoomWindow with:" & vbCrLf & _

"1.3, 7.8, 0" & vbCrLf & _

"13.7, -2.6, 0", , "ZoomWindow"

Dim point1(0 To 2) As Double

Dim point2(0 To 2) As Double

point1(0) = 1.3: point1(1) = 7.8: point1(2) = 0

point2(0) = 13.7: point2(1) = -2.6: point2(2) = 0

ThisDrawing.Application.ZoomWindow point1, point2

' ZoomPickWindow

MsgBox "Perform a ZoomPickWindow", , "ZoomPickWindow"

ThisDrawing.Application.ZoomPickWindow


本例使用 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


本例使用 Width 和 Height 特性将活动“文档”窗口设置为宽 400 像素、高 400 像素。

Sub Ch3_SizeDocumentWindow()

ThisDrawing.Width = 400

ThisDrawing.Height = 400


本例查询“应用程序”窗口的状态，并将该状态以消息框的形式显示给用户。

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


下例在模型空间中创建坐标为 (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


创建和删除多段线

本例创建一条优化多段线，然后将其删除。

Sub Ch4_DeletePolyline()

' 创建多段线

Dim lwpolyObj As AcadLWPolyline

Dim vertices(0 To 5) As Double

vertices(0) = 2: vertices(1) = 4

vertices(2) = 4: vertices(3) = 2

vertices(4) = 6: vertices(5) = 4

Set lwpolyObj = ThisDrawing.ModelSpace. _

AddLightWeightPolyline(vertices)

ZoomAll

' 删除多段线

lwpolyObj.Delete

ThisDrawing.Regen acActiveViewport

End Sub

缩放多段线

本例创建一条闭合的优化多段线，然后以 0.5 的缩放比例调整该多段线。

Sub Ch4_ScalePolyline()

' 创建多段线

Dim plineObj As AcadLWPolyline

Dim points(0 To 11) As Double

points(0) = 1: points(1) = 2

points(2) = 1: points(3) = 3

points(4) = 2: points(5) = 3

points(6) = 3: points(7) = 3

points(8) = 4: points(9) = 4

points(10) = 4: points(11) = 2

Set plineObj = ThisDrawing.ModelSpace. _

AddLightWeightPolyline(points)

plineObj.Closed = True

ZoomAll

' 定义缩放

Dim basePoint(0 To 2) As Double

Dim scalefactor As Double

basePoint(0) = 4: basePoint(1) = 4.25: basePoint(2) = 0

scalefactor = 0.5

' 缩放多段线

plineObj.ScaleEntity basePoint, scalefactor

plineObj.Update


本样例在模型空间中创建一个多面网格对象。然后更新活动视口的观察方向，以便于查看网格的三维情况。

Sub Ch8_CreatePolyfaceMesh()

'定义网格顶点

Dim vertex(0 To 17) As Double

vertex(0) = 4: vertex(1) = 7: vertex(2) = 0

vertex(3) = 5: vertex(4) = 7: vertex(5) = 0

vertex(6) = 6: vertex(7) = 7: vertex(8) = 0

vertex(9) = 4: vertex(10) = 6: vertex(11) = 0

vertex(12) = 5: vertex(13) = 6: vertex(14) = 0

vertex(15) = 6: vertex(16) = 6: vertex(17) = 1

' 定义面列表

Dim FaceList(0 To 7) As Integer

FaceList(0) = 1

FaceList(1) = 2

FaceList(2) = 5

FaceList(3) = 4

FaceList(4) = 2

FaceList(5) = 3

FaceList(6) = 6

FaceList(7) = 5

' 创建多面网格

Dim polyfaceMeshObj As AcadPolyfaceMesh

Set polyfaceMeshObj = ThisDrawing.ModelSpace.AddPolyfaceMesh _

(vertex, FaceList)

' 更改视口的观察方向

' 以便于查看多面网格

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


本样例创建一个 4 × 4 的多边形网格。然后调整活动视口的方向，以便于查看网格的三维情况。

Sub Ch8_Create3DMesh()

Dim meshObj As AcadPolygonMesh

Dim mSize, nSize, Count As Integer

Dim points(0 To 47) As Double

' 创建点的矩阵

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

' 在模型空间中创建三维网格

Set meshObj = ThisDrawing.ModelSpace. _

Add3DMesh(mSize, nSize, points)

' 更改视口的观察方向

' 以更好地查看圆柱体

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


本例使用 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


本例创建一个圆，然后对圆执行环形阵列操作。这个过程将围绕基点 (4,4,0)，在 180 度内创建四个圆。

Sub Ch4_ArrayingACircle()

' 创建圆

Dim circleObj As AcadCircle

Dim center(0 To 2) As Double

Dim radius As Double

center(0) = 2#: center(1) = 2#: center(2) = 0#

radius = 1

Set circleObj = ThisDrawing.ModelSpace. _

AddCircle(center, radius)

ZoomAll

' 定义环形阵列

Dim noOfObjects As Integer

Dim angleToFill As Double

Dim basePnt(0 To 2) As Double

noOfObjects = 4

angleToFill = 3.14 ' 180 度

basePnt(0) = 4#: basePnt(1) = 4#: basePnt(2) = 0#

' 下例通过绕点 (3,3,0) 旋转和

' 复制对象而创建四个

' 对象副本。

Dim retObj As Variant

retObj = circleObj.ArrayPolar _

(noOfObjects, angleToFill, basePnt)

ZoomAll


下例从一个圆创建面域。

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


本例创建一个圆，然后对该圆执行矩形阵列操作，创建 5 行 5 列的圆。

Sub Ch4_ArrayRectangularExample()

' 创建圆

Dim circleObj As AcadCircle

Dim center(0 To 2) As Double

Dim radius As Double

center(0) = 2#: center(1) = 2#: center(2) = 0#

radius = 0.5

Set circleObj = ThisDrawing.ModelSpace. _

AddCircle(center, radius)

ZoomAll

' 定义矩形阵列

Dim numberOfRows As Long

Dim numberOfColumns As Long

Dim numberOfLevels As Long

Dim distanceBwtnRows As Double

Dim distanceBwtnColumns As Double

Dim distanceBwtnLevels As Double

numberOfRows = 5

numberOfColumns = 5

numberOfLevels = 2

distanceBwtnRows = 1

distanceBwtnColumns = 1

distanceBwtnLevels = 1

' 创建对象的阵列

Dim retObj As Variant

retObj = circleObj.ArrayRectangular _

(numberOfRows, numberOfColumns, numberOfLevels, _

distanceBwtnRows, distanceBwtnColumns, distanceBwtnLevels)

ZoomAll


本样例创建一个圆，然后用该圆创建 4 行、4 列、3 层的圆的矩形阵列。

Sub Ch8_CreateRectangularArray()

' 创建圆

Dim circleObj As AcadCircle

Dim center(0 To 2) As Double

Dim radius As Double

center(0) = 2: center(1) = 2: center(2) = 0

radius = 0.5

Set circleObj = ThisDrawing.ModelSpace. _

AddCircle(center, radius)

' 定义矩形阵列

Dim numberOfRows As Long

Dim numberOfColumns As Long

Dim numberOfLevels As Long

Dim distanceBwtnRows As Double

Dim distanceBwtnColumns As Double

Dim distanceBwtnLevels As Double

numberOfRows = 4

numberOfColumns = 4

numberOfLevels = 3

distanceBwtnRows = 1

distanceBwtnColumns = 1

distanceBwtnLevels = 4

' 创建对象的阵列

Dim retObj As Variant

retObj = circleObj.ArrayRectangular _

(numberOfRows, numberOfColumns, _

numberOfLevels, distanceBwtnRows, _

distanceBwtnColumns, distanceBwtnLevels)

ZoomAll


本样例创建一个三维长方体，然后定义旋转轴，将长方体绕该轴旋转 30 度。

Sub Ch8_Rotate_3DBox()

Dim boxObj As Acad3DSolid

Dim length As Double

Dim width As Double

Dim height As Double

Dim center(0 To 2) As Double

' 定义长方体

center(0) = 5: center(1) = 5: center(2) = 0

length = 5

width = 7

height = 10

' 在模型空间中创建长方体对象

Set boxObj = ThisDrawing.ModelSpace. _

AddBox(center, length, width, height)

' 用两点定义旋转轴

Dim rotatePt1(0 To 2) As Double

Dim rotatePt2(0 To 2) As Double

Dim rotateAngle As Double

rotatePt1(0) = -3: rotatePt1(1) = 4: rotatePt1(2) = 0

rotatePt2(0) = -3: rotatePt2(1) = -4: rotatePt2(2) = 0

rotateAngle = 30

rotateAngle = rotateAngle * 3.141592 / 180#

' 旋转长方体

boxObj.Rotate3D rotatePt1, rotatePt2, rotateAngle

ZoomAll


下例使用坐标 (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


本样例在模型空间中创建一个楔形实体。然后更新活动视口的观察方向，以便于查看楔体的三维情况。

Sub Ch8_CreateWedge()

Dim wedgeObj As Acad3DSolid

Dim center(0 To 2) As Double

Dim length As Double

Dim width As Double

Dim height As Double

' 定义楔体

center(0) = 5#: center(1) = 5#: center(2) = 0

length = 10#: width = 15#: height = 20#

' 在模型空间中创建楔体

Set wedgeObj = ThisDrawing.ModelSpace. _

AddWedge(center, length, width, height)

' 更改视口的观察方向

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


本样例在模型空间中创建一个长方体和一个圆柱体，然后找出这两个实体之间的干涉，并由干涉创建一个新的实体。为便于查看，将长方体着色为白色，圆柱体着色为青色，得到的干涉实体为红色。

Sub Ch8_FindInterferenceBetweenSolids()

' 定义长方体

Dim boxObj As Acad3DSolid

Dim length As Double

Dim width As Double

Dim height As Double

Dim center(0 To 2) As Double

center(0) = 5: center(1) = 5: center(2) = 0

length = 5

width = 7

height = 10

' 在模型空间中创建长方体对象

' 并着色为白色

Set boxObj = ThisDrawing.ModelSpace. _

AddBox(center, length, width, height)

boxObj.Color = acWhite

' 定义圆柱体

Dim cylinderObj As Acad3DSolid

Dim cylinderRadius As Double

Dim cylinderHeight As Double

center(0) = 0: center(1) = 0: center(2) = 0

cylinderRadius = 5

cylinderHeight = 20

' 创建圆柱体并

' 着色为青色

Set cylinderObj = ThisDrawing.ModelSpace.AddCylinder _

(center, cylinderRadius, cylinderHeight)

cylinderObj.Color = acCyan

' 找出两个实体之间的干涉

' 并由干涉创建新的实体。新实体

' 着色为红色。

Dim solidObj As Acad3DSolid

Set solidObj = boxObj.CheckInterference(cylinderObj, True)

solidObj.Color = acRed

ZoomAll


本例在模型空间中创建简单的形位公差。

Sub Ch5_CreateTolerance()

Dim toleranceObj As AcadTolerance

Dim textString As String

Dim insertionPoint(0 To 2) As Double

Dim direction(0 To 2) As Double

' 定义公差对象

textString = "Here is the Feature Control Frame"

insertionPoint(0) = 5

insertionPoint(1) = 5

insertionPoint(2) = 0

direction(0) = 1

direction(1) = 1

direction(2) = 0

' 在模型空间中创建公差对象

Set toleranceObj = ThisDrawing.ModelSpace. _

AddTolerance(textString, insertionPoint, direction)

ZoomAll


Sub Ch4_CreateCompositeRegions()

' 创建两个圆，一个代表房间，

' 另一个代表房间中的柱子

Dim RoomObjects(0 To 1) As AcadCircle

Dim center(0 To 2) As Double

Dim radius As Double

center(0) = 4

center(1) = 4

center(2) = 0

radius = 2#

Set RoomObjects(0) = ThisDrawing.ModelSpace. _

AddCircle(center, radius)

radius = 1#

Set RoomObjects(1) = ThisDrawing.ModelSpace. _

AddCircle(center, radius)

' 从这两个圆创建一个面域

Dim regions As Variant

regions = ThisDrawing.ModelSpace.AddRegion(RoomObjects)

' 将面域复制到面域变量中以便使用

Dim RoundRoomObj As AcadRegion

Dim PillarObj As AcadRegion

If regions(0).Area > regions(1).Area Then

' 第一个面域是房间

Set RoundRoomObj = regions(0)

Set PillarObj = regions(1)

Else

' 第一个面域是柱子

Set PillarObj = regions(0)

Set RoundRoomObj = regions(1)

End If

' 从地板空间减去柱子空间，

' 以获得表示地毯总面积的面域。

RoundRoomObj.Boolean acSubtraction, PillarObj

' 使用 Area 特性确定出地毯的总面积

MsgBox "The carpet area is: " & RoundRoomObj.Area

End Sub

使用 Area 特性查找结果面域的面积。


本例使用三点 (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

关于样条曲线的详细信息，请参见 AutoCAD ActiveX and VBA Reference Guide中的 Spline 对象和 AddSpline 方法的说明。


本样例在模型空间中创建一个长方体，然后基于由三个点定义的平面剖切该长方体。剖切后的结果作为 3DSolid 返回。

Sub Ch8_SliceABox()

' 创建长方体对象

Dim boxObj As Acad3DSolid

Dim length As Double

Dim width As Double

Dim height As Double

Dim center(0 To 2) As Double

center(0) = 5#: center(1) = 5#: center(2) = 0

length = 5#: width = 7: height = 10#

' 在模型空间中创建长方体 (3DSolid) 对象

Set boxObj = ThisDrawing.ModelSpace. _

AddBox(center, length, width, height)

boxObj.Color = acWhite

' 用三点定义剖切平面

Dim slicePt1(0 To 2) As Double

Dim slicePt2(0 To 2) As Double

Dim slicePt3(0 To 2) As Double

slicePt1(0) = 1.5: slicePt1(1) = 7.5: slicePt1(2) = 0

slicePt2(0) = 1.5: slicePt2(1) = 7.5: slicePt2(2) = 10

slicePt3(0) = 8.5: slicePt3(1) = 2.5: slicePt3(2) = 10

' 剖切长方体并将新实体着色为红色

Dim sliceObj As Acad3DSolid

Set sliceObj = boxObj.SliceSolid _

(slicePt1, slicePt2, slicePt3, True)

sliceObj.Color = acRed

ZoomAll


本例在 MenuGroups 集合的第一个菜单组中创建一个新的工具栏 TestToolbar。

Sub Ch6_CreateToolbar()

Dim currMenuGroup As AcadMenuGroup

Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

' 创建新工具栏

Dim newToolbar As AcadToolbar

Set newToolbar = currMenuGroup.Toolbars.Add("TestToolbar")


本例创建一个新的工具栏，在其中添加按钮，然后向按钮指定在选择该按钮时执行 OPEN 命令的宏。

Sub Ch6_AddButton()

Dim currMenuGroup As AcadMenuGroup

Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

' 创建新工具栏

Dim newToolbar As AcadToolbar

Set newToolbar = currMenuGroup.Toolbars.Add("TestToolbar")

' 向新工具栏添加按钮

Dim newButton As AcadToolbarItem

Dim openMacro As String

' 给宏指定“ESC ESC _open”的 VB 等价值

openMacro = Chr(vbKeyEscape) + Chr(vbKeyEscape) + "_open "

Set newButton = newToolbar.AddToolbarButton _

("", "NewButton", "Open a file.", openMacro)


Sub Ch6_GetButtonImages()

Dim Button As AcadToolbarItem

Dim Toolbar0 As AcadToolbar

Dim MenuGroup0 As AcadMenuGroup

Dim SmallButtonName As String

Dim LargeButtonName As String

Dim msg As String

Dim ButtonType As String

' 获取第一个菜单组中的第一个工具栏

Set MenuGroup0 = ThisDrawing.Application. _

MenuGroups.Item(0)

Set Toolbar0 = MenuGroup0.Toolbars.Item(0)

' 清除字符串变量

SmallButtonName = ""

LargeButtonName = ""

' 创建消息框的标题并

' 显示要查询的工具栏

msg = "Toolbar: " + Toolbar0.Name + vbCrLf

Toolbar0.Visible = True

' 遍历工具栏并收集工具栏中

' 每个按钮的数据。如果工具栏是

' 普通按钮或弹出按钮，则收集按钮的

' 小按钮名称和大按钮名称。

For Each Button In Toolbar0

ButtonType = Choose(Button.Type + 1, "Button", _

"Separator", "Control", "Flyout")

msg = msg & ButtonType & ": "

If Button.Type = acToolbarButton Or _

Button.Type = acToolbarFlyout Then

Button.GetBitmaps SmallButtonName, _

LargeButtonName

msg = msg + SmallButtonName + ", " _

+ LargeButtonName

End If

msg = msg + vbCrLf

Next Button

' 显示结果

MsgBox msg


本例创建两个工具栏：第一个工具栏包含一个弹出按钮，第二个工具栏被附着到第一个工具栏的弹出按钮上。

Sub Ch6_AddFlyoutButton()

Dim currMenuGroup As AcadMenuGroup

Set currMenuGroup = ThisDrawing.Application. _

MenuGroups.Item(0)

' 创建第一个工具栏

Dim FirstToolbar As AcadToolbar

Set FirstToolbar = currMenuGroup.Toolbars. _

Add("FirstToolbar")

' 向菜单栏上的第一个菜单添加弹出按钮

Dim FlyoutButton As AcadToolbarItem

Set FlyoutButton = FirstToolbar.AddToolbarButton _

("", "Flyout", "Demonstrates a flyout button", _

"OPEN", True)

' 创建第二个工具栏。该工具栏将通过弹出按钮附加到

' 第一个工具栏。

Dim SecondToolbar As AcadToolbar

Set SecondToolbar = currMenuGroup.Toolbars. _

Add("SecondToolbar")

' 向下一个工具栏添加按钮

Dim newButton As AcadToolbarItem

Dim openMacro As String

' 给宏指定“ESC ESC _open”的 VB 等价值

openMacro = Chr(vbKeyEscape) + Chr(vbKeyEscape) + "_open "

Set newButton = SecondToolbar.AddToolbarButton _

("", "NewButton", "Open a file.", openMacro)

' 将第二个工具栏附着到第一个工具栏

' 的弹出按钮上

FlyoutButton.AttachToolbarToFlyout currMenuGroup.Name, _

SecondToolbar.Name

' 显示第一个工具栏，隐藏第二个工具栏

FirstToolbar.Visible = True

SecondToolbar.Visible = False


本例创建一个包含三个按钮的新工具栏，然后显示工具栏并将其固定在屏幕的左边。

Sub Ch6_DockToolbar()

Dim currMenuGroup As AcadMenuGroup

Set currMenuGroup = ThisDrawing.Application. _

MenuGroups.Item(0)

' 创建新工具栏

Dim newToolbar As AcadToolbar

Set newToolbar = currMenuGroup.Toolbars. _

Add("TestToolbar")

' 向新工具栏添加三个按钮。

' 三个按钮都将附着相同的宏。

Dim newButton1 As AcadToolbarItem

Dim newButton2 As AcadToolbarItem

Dim newButton3 As AcadToolbarItem

Dim openMacro As String

' 给宏指定“ESC ESC _open”的 VB 等价值

openMacro = Chr(vbKeyEscape) + Chr(vbKeyEscape) + "_open "

Set newButton1 = newToolbar.AddToolbarButton _

("", "NewButton1", "Open a file.", openMacro)

Set newButton2 = newToolbar.AddToolbarButton _

("", "NewButton2", "Open a file.", openMacro)

Set newButton3 = newToolbar.AddToolbarButton _

("", "NewButton3", "Open a file.", openMacro)

' 显示工具栏

newToolbar.Visible = True

' 将工具栏固定在屏幕的左边。

newToolbar.Dock acToolbarDockLeft


本例在模型空间添加光栅图像。本例使用 watch.jpg（可在 sample 目录中找到此文件）。如果没有此图像，或者此图像位于其他目录，请为 imageName 变量插入有效的路径和文件名。

Sub Ch10_AttachingARaster()

Dim insertionPoint(0 To 2) As Double

Dim scalefactor As Double

Dim rotationAngle As Double

Dim imageName As String

Dim rasterObj As AcadRasterImage

imageName = "C:/Program Files/AutoCAD 2004/sample/watch.jpg"

insertionPoint(0) = 5

insertionPoint(1) = 5

insertionPoint(2) = 0

scalefactor = 2

rotationAngle = 0

On Error GoTo ERRORHANDLER

' 在模型空间中附着光栅图像

Set rasterObj = ThisDrawing.ModelSpace.AddRaster _

(imageName, insertionPoint, _

scalefactor, rotationAngle)

ZoomAll

Exit Sub

ERRORHANDLER:

MsgBox Err.Description


  1. 使用 ClippingEnabled 特性打开图像边界。
  2. 使用 ClipBoundary 方法指定剪裁边界，进行剪裁。这个方法需要输入一个值：用于指定光栅图像剪裁边界的二维 WCS 坐标的变量数组。


本例在模型空间中添加光栅图像，然后根据剪裁边界来剪裁图像。本例使用 downtown.jpg（该文件可以在 sample 目录中找到）。如果没有此图像，或者此图像位于其他目录中，请为 imageName 变量插入有效的路径和文件名。

Sub Ch10_ClippingRasterBoundary()

Dim insertionPoint(0 To 2) As Double

Dim scalefactor As Double

Dim rotationAngle As Double

Dim imageName As String

Dim rasterObj As AcadRasterImage

imageName = "C:\AutoCAD\sample\downtown.jpg"

insertionPoint(0) = 5

insertionPoint(1) = 5

insertionPoint(2) = 0

scalefactor = 2

rotationAngle = 0

On Error GoTo ERRORHANDLER

' 在模型空间中创建光栅图像

Set rasterObj = ThisDrawing.ModelSpace.AddRaster _

(imageName, insertionPoint, _

scalefactor, rotationAngle)

ZoomAll

' 使用点数组建立剪裁边界

Dim clipPoints(0 To 9) As Double

clipPoints(0) = 6: clipPoints(1) = 6.75

clipPoints(2) = 7: clipPoints(3) = 6

clipPoints(4) = 6: clipPoints(5) = 5

clipPoints(6) = 5: clipPoints(7) = 6

clipPoints(8) = 6: clipPoints(9) = 6.75

' 剪裁图像

rasterObj.ClipBoundary clipPoints

' 启用剪裁显示

rasterObj.ClippingEnabled = True

ThisDrawing.Regen acActiveViewport

Exit Sub

ERRORHANDLER:

MsgBox Err.Description


本例附着外部参照，然后再将其拆离。本例使用 City map.dwg（该文件可以在 sample 目录中找到）。如果没有此图像，或者图像位于其他目录中，请为下面的 PathName 变量插入有效的路径和文件名。

Sub Ch10_DetachingExternalReference()

On Error GoTo ERRORHANDLER

' 定义要插入的外部参照

Dim xrefHome As AcadBlock

Dim xrefInserted As AcadExternalReference

Dim insertionPnt(0 To 2) As Double

Dim PathName As String

insertionPnt(0) = 1

insertionPnt(1) = 1

insertionPnt(2) = 0

PathName = "c:/AutoCAD/sample/City map.dwg"

' 添加外部参照

Set xrefInserted = ThisDrawing.ModelSpace. _

AttachExternalReference(PathName, "XREF_IMAGE", _

insertionPnt, 1, 1, 1, 0, False)

ZoomAll

MsgBox "The external reference is attached."

' 拆离外部参照定义

Dim name As String

name = xrefInserted.name

ThisDrawing.Blocks.Item(name).Detach

MsgBox "The external reference is detached."

Exit Sub

ERRORHANDLER:

MsgBox Err.Description


本例附着外部参照，然后重载该外部参照。本例使用 City map.dwg（该文件可以在 sample 目录中找到）。如果没有此图像，或者图像位于其他目录中，请为下面的 PathName 变量插入有效的路径和文件名。

Sub Ch10_ReloadingExternalReference()

On Error GoTo ERRORHANDLER

' 定义要插入的外部参照

Dim xrefHome As AcadBlock

Dim xrefInserted As AcadExternalReference

Dim insertionPnt(0 To 2) As Double

Dim PathName As String

insertionPnt(0) = 1

insertionPnt(1) = 1

insertionPnt(2) = 0

PathName = "c:/AutoCAD/sample/City map.dwg"

' 向块添加外部参照

Set xrefInserted = ThisDrawing.ModelSpace. _

AttachExternalReference(PathName, "XREF_IMAGE", _

insertionPnt, 1, 1, 1, 0, False)

ZoomAll

MsgBox "The external reference is attached."

' 重载外部参照定义

ThisDrawing.Blocks.Item(xrefInserted.name).Reload

MsgBox "The external reference is reloaded."

Exit Sub

ERRORHANDLER:

MsgBox Err.Description


本例附着外部参照，然后卸载外部参照。本例使用 City map.dwg（该文件可以在 sample 目录中找到）。如果没有此图像，或者图像位于其他目录中，请为下面的 PathName 变量插入有效的路径和文件名。

Sub Ch10_UnloadingExternalReference()

On Error GoTo ERRORHANDLER

' 定义要插入的外部参照

Dim xrefHome As AcadBlock

Dim xrefInserted As AcadExternalReference

Dim insertionPnt(0 To 2) As Double

Dim PathName As String

insertionPnt(0) = 1

insertionPnt(1) = 1

insertionPnt(2) = 0

PathName = "c:/AutoCAD/sample/City map.dwg"

' 添加外部参照

Set xrefInserted = ThisDrawing.ModelSpace. _

AttachExternalReference(PathName, "XREF_IMAGE", _

insertionPnt, 1, 1, 1, 0, False)

ZoomAll

MsgBox "The external reference is attached."

' 卸载外部参照定义

ThisDrawing.Blocks.Item(xrefInserted.name).Unload

MsgBox "The external reference is unloaded."

Exit Sub

ERRORHANDLER:

MsgBox Err.Description


本例附着外部参照，然后将外部参照绑定到图形。本例使用 City map.dwg（该文件可以在 sample 目录中找到）。如果没有此图像，或者图像位于其他目录中，请为下面的 PathName 变量插入有效的路径和文件名。

Sub Ch10_BindingExternalReference()

On Error GoTo ERRORHANDLER

' 定义要插入的外部参照

Dim xrefHome As AcadBlock

Dim xrefInserted As AcadExternalReference

Dim insertionPnt(0 To 2) As Double

Dim PathName As String

insertionPnt(0) = 1

insertionPnt(1) = 1

insertionPnt(2) = 0

PathName = "c:/AutoCAD/sample/City map.dwg"

' 添加外部参照

Set xrefInserted = ThisDrawing.ModelSpace. _

AttachExternalReference(PathName, "XREF_IMAGE", _

insertionPnt, 1, 1, 1, 0, False)

ZoomAll

MsgBox "The external reference is attached."

' 绑定外部参照定义

ThisDrawing.Blocks.Item(xrefInserted.name).Bind False

MsgBox "The external reference is bound."

Exit Sub

ERRORHANDLER:

MsgBox Err.Description


以下代码遍历 Layers 集合，以收集图形中所有图层的名称，然后将这些名称显示在消息框中。

Sub Ch4_IteratingLayers()

Dim layerNames As String

Dim entry As AcadLayer

layerNames = ""

For Each entry In ThisDrawing.Layers

layerNames = layerNames + entry.Name + vbCrLf

Next

MsgBox "The layers in this drawing are: " + _

vbCrLf + layerNames


关闭图层

本例创建一个新的图层并在该图层上添加一个圆，然后关闭图层使圆不可见。

Sub Ch4_LayerInvisible()

' 创建圆

Dim circleObj As AcadCircle

Dim center(0 To 2) As Double

Dim radius As Double

center(0) = 2: center(1) = 2: center(2) = 0

radius = 1

Set circleObj = ThisDrawing.ModelSpace. _

AddCircle(center, radius)

circleObj.Color = acByLayer

' 创建新图层“ABC”

Dim layerObj As AcadLayer

Set layerObj = ThisDrawing.Layers.Add("ABC")

layerObj.Color = acRed

' 将圆指定到“ABC”图层

circleObj.Layer = "ABC"

circleObj.Update

' 关闭图层“ABC”

layerObj.LayerOn = False

ThisDrawing.Regen acActiveViewport

End Sub

冻结图层

本例创建新的图层“ABC”，然后冻结该图层。

Sub Ch4_LayerFreeze()

' 创建新图层“ABC”

Dim layerObj As AcadLayer

Set layerObj = ThisDrawing.Layers.Add("ABC")

' 冻结图层“ABC”

layerObj.Freeze = True

End Sub

锁定图层

本例创建新的图层“ABC”，然后将其锁定。

Sub Ch4_LayerLock()

' 创建新图层“ABC”

Dim layerObj As AcadLayer

Set layerObj = ThisDrawing.Layers.Add("ABC")

' 锁定图层“ABC”

layerObj.Lock = True


本例引用名为 MyLayer 的图层，如果图层不存在，则发出消息：

Sub Ch2_FindLayer()

' 使用 Item 方法查找名为 MyLayer 的图层

On Error Resume Next

Dim ABCLayer As AcadLayer

Set ABCLayer = ThisDrawing.Layers("MyLayer")

If Err <> 0 Then

MsgBox "The layer 'MyLayer' does not exist."

End If


本例在活动图层上创建一个圆，然后创建新图层“ABC”，接着将圆移动到新图层上。

Sub Ch4_MoveObjectNewLayer()

' 创建圆

Dim circleObj As AcadCircle

Dim center(0 To 2) As Double

Dim radius As Double

center(0) = 2: center(1) = 2: center(2) = 0

radius = 1

Set circleObj = ThisDrawing.ModelSpace. _

AddCircle(center, radius)

' 创建新图层“ABC”

Dim layerObj As AcadLayer

Set layerObj = ThisDrawing.Layers.Add("ABC")

' 将圆指定到“ABC”图层

circleObj.Layer = "ABC"

circleObj.Update


以下代码以 ColorLinetype 的名称保存当前图层的颜色和线型。

Sub Ch4_SaveLayerColorAndLinetype()

Dim oLSM As AcadLayerStateManager

' 访问 LayerStateManager 对象

Set oLSM = ThisDrawing.Application. _ GetInterfaceObject("AutoCAD.AcadLayerStateManager.16")

' 将当前图形关联至 LayerStateManager

oLSM.SetDatabase ThisDrawing.Database

oLSM.Save "ColorLinetype", acLsColor + acLsLineType


假设当前图形的图层颜色和线型设置已保存为 ColorLineType，以下代码将把图形中每个图层的颜色和线型都重置为保存 ColorLineType 时的设置。

Sub Ch4_RestoreLayerSettings()

Dim oLSM As AcadLayerStateManager

Set oLSM = ThisDrawing.Application. _

GetInterfaceObject("AutoCAD.AcadLayerStateManager.16")

oLSM.SetDatabase ThisDrawing.Database

oLSM.Restore "ColorLinetype"


输出保存的图层设置

以下代码将保存的图层设置输出到名为 Colortype.las 的文件中。

Sub Ch4_ExportLayerSettings()

Dim oLSM As AcadLayerStateManager

Set oLSM = ThisDrawing.Application. _

GetInterfaceObject("AutoCAD.AcadLayerStateManager.16")

oLSM.SetDatabase ThisDrawing.Database

oLSM.Export "ColorLinetype", "c:\my documents\ColorLType.las"

End Sub

输入保存的图层设置

以下代码从名为 Colortype.las 文件输入图层设置。

Sub Ch4_ImportLayerSettings()

Dim oLSM As AcadLayerStateManager

Set oLSM = ThisDrawing.Application. _

GetInterfaceObject("AutoCAD.AcadLayerStateManager.16")

oLSM.SetDatabase ThisDrawing.Database

' 如果要输入的图形未包含

' 保存的设置中引用的所有线型，

' 将返回错误。虽然完成了输入，

' 但使用的是默认线型。

On Error Resume Next

oLSM.Import "c:\my documents\ColorLType.las"

If Err.Number = -2145386359 Then

' 错误指出线型没有定义

MsgBox ("One or more linetypes specified in the imported " + _

"settings is not defined in your drawing")

End If

On Error GoTo 0

End Sub

删除保存的图层设置

以下代码删除以 ColorLinetype. 名称保存的图层设置。

Sub Ch4_DeleteColorAndLinetype()

Dim oLSM As AcadLayerStateManager

Set oLSM = ThisDrawing.Application. _ GetInterfaceObject("AutoCAD.AcadLayerStateManager.16")

oLSM.SetDatabase ThisDrawing.Database

oLSM.Delete "ColorLinetype"


以下代码将 ColorLinetype 图层设置重命名为 OldColorLinetype。

Sub Ch4_RenameLayerSettings()

Dim oLSM As AcadLayerStateManager

Set oLSM = ThisDrawing.Application. _ GetInterfaceObject("AutoCAD.AcadLayerStateManager.16")

oLSM.SetDatabase ThisDrawing.Database

oLSM.Rename "ColorLinetype", "OldColorLinetype"


本例遍历集合，并显示集合中所有图层的名称：

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


以下代码创建一个圆和一个新图层。新的图层指定使用红色。圆被指定到该图层，然后其颜色也相应改变。

Sub Ch4_NewLayer()

' 创建圆

Dim circleObj As AcadCircle

Dim center(0 To 2) As Double

Dim radius As Double

center(0) = 2: center(1) = 2: center(2) = 0

radius = 1

Set circleObj = ThisDrawing.ModelSpace. _

AddCircle(center, radius)

' 将圆的颜色指定为“随层”

' 以便圆自动拾取所在图层的

' 颜色

circleObj.Color = acByLayer

' 创建新图层“ABC”

Dim layerObj As AcadLayer

Set layerObj = ThisDrawing.Layers.Add("ABC")

' 将“ABC”图层的颜色指定为红色

layerObj.Color = acRed

' 将圆指定到“ABC”图层

circleObj.Layer = "ABC"

circleObj.Update


本例创建名为“NewLayer”的图层，然后将其重命名为“MyLayer”。

Sub Ch4_RenamingLayer()

' 创建图层

Dim layerObj As AcadLayer

Set layerObj = ThisDrawing.Layers.Add("NewLayer")

' 更改图层的名称

layerObj.Name = "MyLayer"


本例创建一行文字，然后使用 TextGenerationFlag 特性将其设置为反向显示。

Sub Ch4_ChangingTextGenerationFlag()

Dim textObj As AcadText

Dim textString As String

Dim insertionPoint(0 To 2) As Double

Dim height As Double

' 创建 Text 对象

textString = "Hello, World."

insertionPoint(0) = 3

insertionPoint(1) = 3

insertionPoint(2) = 0

height = 0.5

Set textObj = ThisDrawing.ModelSpace. _

AddText(textString, insertionPoint, height)

' 修改 TextGenerationFlag 的值

textObj.TextGenerationFlag = acTextFlagBackward

textObj.Update


本例在模型空间中的 (2,2,0) 坐标处创建一行文字。

Sub Ch4_CreateText()

Dim textObj As AcadText

Dim textString As String

Dim insertionPoint(0 To 2) As Double

Dim height As Double

' 创建 Text 对象

textString = "Hello, World."

insertionPoint(0) = 2

insertionPoint(1) = 2

insertionPoint(2) = 0

height = 0.5

Set textObj = ThisDrawing.ModelSpace. _

AddText(textString, insertionPoint, height)

textObj.Update


本例创建一个 Text 对象和一个 Point 对象。Point 对象被设置为文字对齐点，并变为红色的十字光标，使其可见。文字对齐将被修改，并显示消息框以终止宏的执行，这样用户就可以查看修改文字对齐的影响。

Sub Ch4_TextAlignment()

Dim textObj As AcadText

Dim textString As String

Dim insertionPoint(0 To 2) As Double

Dim height As Double

' 定义新的 Text 对象

textString = "Hello, World."

insertionPoint(0) = 3

insertionPoint(1) = 3

insertionPoint(2) = 0

height = 0.5

' 在模型空间中创建 Text 对象

Set textObj = ThisDrawing.ModelSpace. _

AddText(textString, insertionPoint, height)

' 在文字对齐点上创建一个点，

' 以便更清楚地看到对齐过程

Dim pointObj As AcadPoint

Dim alignmentPoint(0 To 2) As Double

alignmentPoint(0) = 3

alignmentPoint(1) = 3

alignmentPoint(2) = 0

Set pointObj = ThisDrawing.ModelSpace. _

AddPoint(alignmentPoint)

pointObj.Color = acRed

' 将点样式设置为十字光标

ThisDrawing.SetVariable "PDMODE", 2

' 左对齐文字

textObj.Alignment = acAlignmentLeft

ThisDrawing.Regen acActiveViewport

MsgBox "The Text object is now aligned left"

' 居中对齐文字

textObj.Alignment = acAlignmentCenter

' 将文字对齐点（所有文字，

' 左对齐的文字除外。）

textObj.TextAlignmentPoint = alignmentPoint

ThisDrawing.Regen acActiveViewport

MsgBox "The Text object is now centered"

' 右对齐文字

textObj.Alignment = acAlignmentRight

ThisDrawing.Regen acActiveViewport

MsgBox "The Text object is now aligned right"


以下代码在模型空间中的 (2,2,0) 坐标处创建 MText 对象。

Sub Ch4_CreateMText()

Dim mtextObj As AcadMText

Dim insertPoint(0 To 2) As Double

Dim width As Double

Dim textString As String

insertPoint(0) = 2

insertPoint(1) = 2

insertPoint(2) = 0

width = 4

textString = "This is a text string for the mtext object."

' 在模型空间中创建文字对象

Set mtextObj = ThisDrawing.ModelSpace. _

AddMText(insertPoint, width, textString)

ZoomAll


本例创建并格式化 MText 对象。

Sub Ch4_FormatMText()

Dim mtextObj As AcadMText

Dim insertPoint(0 To 2) As Double

Dim width As Double

Dim textString As String

insertPoint(0) = 2

insertPoint(1) = 2

insertPoint(2) = 0

width = 4

' 定义控制字符的 ASCII 字符

Dim OB As Long ' 左括号 {

Dim CB As Long ' 右括号 }

Dim BS As Long ' 反斜杠 \

Dim FS As Long ' 正斜杠 /

Dim SC As Long ' 分号 ;

OB = Asc("{")

CB = Asc("}")

BS = Asc("\")

FS = Asc("/")

SC = Asc(";")

' 将以下控制字符和文字字符

' 指定给字符串：

' {{\H1.5x; Big text}\A2; over text\A1;/\A0; under text}

textString = Chr(OB) + Chr(OB) + Chr(BS) + "H1.5x" _

+ Chr(SC) + "Big text" + Chr(CB) + Chr(BS) + "A2" _

+ Chr(SC) + "over text" + Chr(BS) + "A1" + Chr(SC) _

+ Chr(FS) + Chr(BS) + "A0" + Chr(SC) + "under text" _

+ Chr(CB)

' 在模型空间中创建文字对象

Set mtextObj = ThisDrawing.ModelSpace. _

AddMText(insertPoint, width, textString)

ZoomAll


本例更改 FontFile 和 BigFontFile 特性。用户需要将本例中的路径信息替换为实际的系统路径和文件名。

Sub Ch4_ChangeFontFiles()

ThisDrawing.ActiveTextStyle.BigFontFile = _

"C:/AutoCAD/Fonts/bigfont.shx"

ThisDrawing.ActiveTextStyle.fontFile = _

"C:/AutoCAD/Fonts/italic.shx"


本例创建一行文字，然后修改该文字的高度。

Sub Ch4_ChangeTextHeight()

Dim textObj As AcadText

Dim textString As String

Dim insertionPoint(0 To 2) As Double

Dim height As Double

' 定义 Text 对象

textString = "Hello, World."

insertionPoint(0) = 3

insertionPoint(1) = 3

insertionPoint(2) = 0

height = 0.5

' 在模型空间中创建 Text 对象

Set textObj = ThisDrawing.ModelSpace. _

AddText(textString, insertionPoint, height)

' 将 Height 值改为 1

textObj.height = 1

textObj.Update


本例创建一个 Text 对象，然后将文字倾斜 45 度。

Sub Ch4_ObliqueText()

Dim textObj As AcadText

Dim textString As String

Dim insertionPoint(0 To 2) As Double

Dim height As Double

' 定义 Text 对象

textString = "Hello, World."

insertionPoint(0) = 3

insertionPoint(1) = 3

insertionPoint(2) = 0

height = 0.5

' 在模型空间中创建 Text 对象

Set textObj = ThisDrawing.ModelSpace. _

AddText(textString, insertionPoint, height)

' 将 ObliqueAngle 值改为

' 45 度（.707 弧度）

textObj.ObliqueAngle = 0.707

textObj.Update


本例获取活动文字样式的当前字体值，将该字体改为“PlayBill”，然后使用 SetFont 方法设置新的字体。要查看字体更改的效果，请在运行样例之前，向当前图形中添加一些多行文字或文字。请注意，如果用户系统中没有 PlayBill 字体，需要将其替换为一种已有的字体以运行本样例。

Sub Ch4_UpdateTextFont()

MsgBox ("Look at the text now...")

Dim typeFace As String

Dim SavetypeFace As String

Dim Bold As Boolean

Dim Italic As Boolean

Dim charSet As Long

Dim PitchandFamily As Long

' 获取当前设置，填充

' SetFont 方法的默认值

ThisDrawing.ActiveTextStyle.GetFont typeFace, _

Bold, Italic, charSet, PitchandFamily

' 改变字体

SavetypeFace = typeFace

typeFace = "PlayBill"

ThisDrawing.ActiveTextStyle.SetFont typeFace, _

Bold, Italic, charSet, PitchandFamily

ThisDrawing.Regen acActiveViewport

MsgBox ("Now see how it looks after changing the font...")

'恢复原始字体

ThisDrawing.ActiveTextStyle.SetFont SavetypeFace, _

Bold, Italic, charSet, PitchandFamily

ThisDrawing.Regen acActiveViewport


本例提示用户选择图形中的对象，然后将选定的对象置于选择集中，并且指定的扩展数据将附着到该选择集中的所有对象。

Sub Ch10_AttachXDataToSelectionSetObjects()

' 创建选择集

Dim sset As Object

Set sset = ThisDrawing.SelectionSets.Add("SS1")

' 提示用户选择对象

sset.SelectOnScreen

' 定义扩展数据

Dim appName As String, xdataStr As String

appName = "MY_APP"

xdataStr = "This is some xdata"

Dim xdataType(0 To 1) As Integer

Dim xdata(0 To 1) As Variant

' 为每个数组定义值

'1001 指示 appName

xdataType(0) = 1001

xdata(0) = appName

'1000 指示字符串值

xdataType(1) = 1000

xdata(1) = xdataStr

' 遍历选择集中的所有图元

' 将扩展数据设置和指定给每个图元

Dim ent As Object

For Each ent In sset

ent.SetXData xdataType, xdata

Next ent


本例显示上例所附着的扩展数据。如果附着的扩展数据不是字符串（类型 1000）类型，则需要修改此代码。

Sub Ch10_ViewXData()

' 查找上例中创建的选择集

Dim sset As Object

Set sset = ThisDrawing.SelectionSets.Item("SS1")

' 定义扩展数据变量以保存扩展数据信息

Dim xdataType As Variant

Dim xdata As Variant

Dim xd As Variant

'定义索引计数器

Dim xdi As Integer

xdi = 0

' 遍历选择集中的对象

' 并检索对象的扩展数据

Dim msgstr As String

Dim appName As String

Dim ent As AcadEntity

appName = "MY_APP"

For Each ent In sset

msgstr = ""

xdi = 0

' 检索 appName 扩展数据类型和值

ent.GetXData appName, xdataType, xdata

' 如果未初始化 xdataType 变量，

' 则没有可供该图元检索的 appName 扩展数据

If VarType(xdataType) <> vbEmpty Then

For Each xd In xdata

msgstr = msgstr & vbCrLf & xdataType(xdi) _

& ": " & xd

xdi = xdi + 1

Next xd

End If

' 如果 msgstr 变量为 NULL，则没有扩展数据

If msgstr = "" Then msgstr = vbCrLf & "NONE"

MsgBox appName & " xdata on " & ent.ObjectName & _

":" & vbCrLf & msgstr

Next ent


以下代码提示用户选择要包含在选择集中的对象，但仅当选择的对象是 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


本例提示用户选择对象，然后将这些对象添加到选择集中。

Sub Ch4_AddToASelectionSet()

' 创建新的选择集

Dim sset As AcadSelectionSet

Set sset = ThisDrawing.SelectionSets.Add("SS1")

' 提示用户选择对象，

' 并将其添加到选择集中。

' 要完成选择，请按回车键。

sset.SelectOnScreen


本例创建一个新的选择集。

Sub Ch4_CreateSelectionSet()

Dim selectionSet1 As AcadSelectionSet

Set selectionSet1 = ThisDrawing.SelectionSets. _

Add("NewSelectionSet")


本例示范在 VBA 和 VB 中创建直线。

使用 VBA 创建直线：

Sub Ch2_AddLineVBA()

' 本例在模型空间中

' 添加一条直线

Dim lineObj As AcadLine

Dim startPoint(0 To 2) As Double

Dim endPoint(0 To 2) As Double

' 定义直线的起点

' 和端点

startPoint(0) = 1

startPoint(1) = 1

startPoint(2) = 0

endPoint(0) = 5

endPoint(1) = 5

endPoint(2) = 0

' 在模型空间中创建直线

Set lineObj = ThisDrawing. _

ModelSpace.AddLine _

(startPoint, endPoint)

' 放大新创建的直线

ZoomAll

End Sub

使用 VB 创建直线：

Sub Ch2_AddLineVB()

On Error Resume Next

' 连接至 AutoCAD 应用程序

Dim acadApp As AcadApplication

Set acadApp = GetObject _

(, "AutoCAD.Application.16")

If Err Then

Err.Clear

Set acadApp = CreateObject _

("AutoCAD.Application.16")

If Err Then

MsgBox Err.Description

Exit Sub

End If

End If

' 连接至 AutoCAD 图形

Dim acadDoc As AcadDocument

Set acadDoc = acadApp.ActiveDocument

' 创建直线的端点

Dim lineObj As AcadLine

Dim startPoint(0 To 2) As Double

Dim endPoint(0 To 2) As Double

startPoint(0) = 1

startPoint(1) = 1

startPoint(2) = 0

endPoint(0) = 5

endPoint(1) = 5

endPoint(2) = 0

' 在模型空间中创建 Line 对象

Set lineObj = acadDoc.ModelSpace.AddLine _

(startPoint, endPoint)

ZoomAll

acadApp.visible = True


下面的样例将 InitializeUserInput 的第一个参数设置为 1 以强制用户输入关键字，但不接受 NULL 输入（即按 ENTER 键）。第二个参数将建立有效关键字列表。

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

更为友好的关键字提示是当用户按 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"


下面的样例提示用户输入正数、非负整数值或关键字：

Sub Ch3_UserInput()

' InitializeUserInput (6) 的第一个参数

' 将输入限制为正数和非负数

' 值，第二个参数是有效

' 关键字的列表。

ThisDrawing.Utility.InitializeUserInput 6, "Big Small Regular"

' 设置提示字符串变量

Dim promptStr As String

promptStr = vbCrLf & "Enter the size or (Big/Small/<Regular>):"

' 在 GetInteger 提示下，输入关键字

' 或按 ENTER 键而没有输入值将产生错误。为允许

' 应用程序继续并且检查错误

' 信息，必须将错误处理程序设置为在错误发生后恢复执行。

On Error Resume Next

' 获取用户输入的值

Dim returnInteger As Integer

returnInteger = ThisDrawing.Utility.GetInteger(promptStr)

' 检查错误。如果错误编号与下面显示的

' 编号之一匹配，则使用 GetInput 获取返回的

' 字符串；否则，使用 returnInteger 的值。

If Err.Number = -2145320928 Then

Dim returnString As String

Debug.Print Err.Description

returnString = ThisDrawing.Utility.GetInput()

If returnString = "" Then '按 ENTER 键返回空字符串

returnString = "Regular" '设置为默认

End If

Err.Clear

Else '否则，

returnString = returnInteger '使用输入的值

End If

' 显示结果

MsgBox returnString, , "InitializeUserInput Example"


下面的样例显示提示“Enter Your Name”，并要求用户按 ENTER 键终止输入（输入字符串中可以包含空格）。输入字符串值被存储在 retVal 变量中，并通过一个消息框显示出来。

Sub Ch3_GetStringFromUser()

Dim retVal As String

retVal = ThisDrawing.Utility.GetString _

(1, vbCrLf & "Enter your name: ")

MsgBox "The name entered was: " & retVal

End Sub

GetString 方法不会认可之前对 InitializeUserInput 方法的调用


->

本例使用 Err 的 Clear 和 Description 特性。如果用户编码环境不支持这些特性，则需要适当修改样例：

Sub Ch2_ConnectToAcad()

Dim acadApp As AcadApplication

On Error Resume Next

Set acadApp = GetObject(, "AutoCAD.Application.16")

If Err Then

Err.Clear

Set acadApp = CreateObject("AutoCAD.Application.16")

If Err Then

MsgBox Err.Description

Exit Sub

End If

End If

MsgBox "Now running " + acadApp.Name + _

" version " + acadApp.Version

End Sub

接着，将文档变量设置为 AutoCAD 应用程序中的 Document 对象。Document 对象由 Application 对象的 ActiveDocument 特性返回。

Dim acadDoc as AcadDocument

Set acadDoc = acadApp.ActiveDocument

从现在开始，使用 acadDoc 变量引用当前的 AutoCAD 图形。
VB模式-->"工程"-->"引用"-->选中"AutoCAD 2004 Type Library"项-->确定
选择【项目】/【添加引用】/【COM】，选择“AutoCAD2004
Type Library”，按下【选择】/【确定】即可。


本样例创建两条多段线，每条都有三个坐标。第一条是二维多段线，第二条是三维多段线。注意，创建三维多段线时，包含顶点的数组的长度会扩充以包含 Z 坐标。然后，样例查询多段线的坐标，并将坐标显示在消息框中。

Sub Ch8_Polyline_2D_3D()

Dim pline2DObj As AcadLWPolyline

Dim pline3DObj As AcadPolyline

Dim points2D(0 To 5) As Double

Dim points3D(0 To 8) As Double

' 定义三个二维多段线点

points2D(0) = 1: points2D(1) = 1

points2D(2) = 1: points2D(3) = 2

points2D(4) = 2: points2D(5) = 2

' 定义三个三维多段线点

points3D(0) = 1: points3D(1) = 1: points3D(2) = 0

points3D(3) = 2: points3D(4) = 1: points3D(5) = 0

points3D(6) = 2: points3D(7) = 2: points3D(8) = 0

' 创建二维优化多段线

Set pline2DObj = ThisDrawing.ModelSpace. _

AddLightWeightPolyline(points2D)

pline2DObj.Color = acRed

pline2DObj.Update

' 创建三维多段线

Set pline3DObj = ThisDrawing.ModelSpace. _

AddPolyline(points3D)

pline3DObj.Color = acBlue

pline3DObj.Update

' 查询多段线的坐标

Dim get2Dpts As Variant

Dim get3Dpts As Variant

get2Dpts = pline2DObj.Coordinates

get3Dpts = pline3DObj.Coordinates

' 显示坐标

MsgBox ("2D polyline (red): " & vbCrLf & _

get2Dpts(0) & ", " & get2Dpts(1) & vbCrLf & _

get2Dpts(2) & ", " & get2Dpts(3) & vbCrLf & _

get2Dpts(4) & ", " & get2Dpts(5))

MsgBox ("3D polyline (blue): " & vbCrLf & _

get3Dpts(0) & ", " & get3Dpts(1) & ", " & _

get3Dpts(2) & vbCrLf & _

get3Dpts(3) & ", " & get3Dpts(4) & ", " & _

get3Dpts(5) & vbCrLf & _

get3Dpts(6) & ", " & get3Dpts(7) & ", " & _

get3Dpts(8))


分解多段线

本例创建一个优化多段线对象，然后将多段线分解成多个对象。接着遍历产生的对象，显示含有每个对象名称的消息框，并显示分解对象在列表中的索引。

Sub Ch4_ExplodePolyline()

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.SetBulge 3, -0.5

plineObj.Update

' 分解多段线

Dim explodedObjects As Variant

explodedObjects = plineObj.Explode

' 遍历分解的对象

' 并以消息框来显示

' 每个对象的类型

Dim I As Integer

For I = 0 To UBound(explodedObjects)

explodedObjects(I).Color = acRed

explodedObjects(I).Update

MsgBox "Exploded Object " & I & ": " & _

explodedObjects(I).ObjectName

explodedObjects(I).Color = acByLayer

explodedObjects(I).Update

Next

End Sub

编辑多段线

本例创建一条优化多段线，然后向多段线的第三段添加凸度，向多段线附加顶点，修改最后一段的宽度，最后闭合多段线。

Sub Ch4_EditPolyline()

Dim plineObj As AcadLWPolyline

Dim points(0 To 9) 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

' 创建优化多段线对象

Set plineObj = ThisDrawing.ModelSpace. _

AddLightWeightPolyline(points)

' 向线段 3 添加凸度

plineObj.SetBulge 3, -0.5

' 定义新的顶点

Dim newVertex(0 To 1) As Double

newVertex(0) = 4: newVertex(1) = 1

' 向多段线添加顶点

plineObj.AddVertex 5, newVertex

' 设置新线段的宽度

plineObj.SetWidth 4, 0.1, 0.5

' 闭合多段线

plineObj.Closed = True

plineObj.Update


本例创建两个 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

' 定义 Circle 对象

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

' 将要复制的对象设置成

' 与 CopyObjects 兼容的形式

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


本例将捕捉基点更改为 (1,1)，并将捕捉旋转角更改为 30 度，同时打开栅格以显示这些更改。

Sub Ch3_ChangeSnapBasePoint()

' 打开活动视口的栅格

ThisDrawing.ActiveViewport.GridOn = True

' 将捕捉基点更改为 1, 1

Dim newBasePoint(0 To 1) As Double

newBasePoint(0) = 1: newBasePoint(1) = 1

ThisDrawing.ActiveViewport.SnapBasePoint = newBasePoint

' 将捕捉旋转角更改为 30 度（0.575 弧度）

Dim rotationAngle As Double

rotationAngle = 0.575

ThisDrawing.ActiveViewport.SnapRotationAngle = rotationAngle

' 重置视口

ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport


本例创建一个图案填充，然后将该图案填充的当前图案间距增加 2。

Sub Ch4_ChangeHatchPatternSpace()

Dim hatchObj As AcadHatch

Dim patternName As String

Dim PatternType As Long

Dim bAssociativity As Boolean

' 定义图案填充

patternName = "ANSI31"

PatternType = 0

bAssociativity = True

' 创建关联的 Hatch 对象

Set hatchObj = ThisDrawing.ModelSpace. _

AddHatch(PatternType, patternName, bAssociativity)

' 创建图案填充的外部环

Dim outerLoop(0 To 0) As AcadEntity

Dim center(0 To 2) As Double

Dim radius As Double

center(0) = 5

center(1) = 3

center(2) = 0

radius = 3

Set outerLoop(0) = ThisDrawing.ModelSpace. _

AddCircle(center, radius)

hatchObj.AppendOuterLoop (outerLoop)

hatchObj.Evaluate

' 向当前间距加 2，以更改填充图案

' 的间距

hatchObj.patternSpace = hatchObj.patternSpace + 2

hatchObj.Evaluate

ThisDrawing.Regen True


本例创建一条样条曲线，然后更改该样条曲线的第一个控制点。

Sub Ch4_ChangeSplineControlPoint()

' 创建样条曲线

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)

splineObj.Update

' 更改第一个拟合点的坐标

Dim controlPoint(0 To 2) As Double

controlPoint(0) = 0

controlPoint(1) = 3

controlPoint(2) = 0

splineObj.SetControlPoint 0, controlPoint

splineObj.Update


Sub Ch4_ChangeLinetypeScale()

' 保存当前的线型

Set currLineType = ThisDrawing.ActiveLinetype

' 将活动线型更改为 Border，使比例的更改

' 可见。

' 首先查看 Border 线型是否已加载

On Error Resume Next '打开错误捕获

ThisDrawing.ActiveLinetype = ThisDrawing.Linetypes.Item("BORDER")

If Err.Number = -2145386476 Then

' 错误指出尚未加载线型，因此加载它。

ThisDrawing.Linetypes.Load "BORDER", "acad.lin"

ThisDrawing.ActiveLinetype = _

ThisDrawing.Linetypes.Item("BORDER")

End If

On Error GoTo 0 '关闭错误捕获

' 在模型空间中创建 Circle 对象

Dim center(0 To 2) As Double

Dim radius As Double

Dim circleObj As AcadCircle

center(0) = 2

center(1) = 2

center(2) = 0

radius = 4

Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)

circleObj.Update

MsgBox ("Here is the circle with the original linetype")

' 将圆的线型比例设为 3

circleObj.LinetypeScale = 3#

circleObj.Update

MsgBox ("Here is the circle with the new linetype")

' 恢复原始活动线型

ThisDrawing.ActiveLinetype = currLineType


更改圆的颜色

本例创建一个圆，然后将其着色为蓝色。

Sub Ch4_ColorCircle()

Dim color As AcadAcCmColor

Set color = _

AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")

Call color.SetRGB(80, 100, 244)

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)

circleObj.TrueColor = color

ZoomAll

End Sub

更改圆的线型

本例创建一个圆，然后从 acad.lin 文件加载“CENTER”线型。如果该线型已存在或者文件不存在，则显示相关消息。最后，将圆的线型设置为“CENTER”。

Sub Ch4_ChangeCircleLinetype()

On Error Resume Next

' 创建圆

Dim circleObj As AcadCircle

Dim center(0 To 2) As Double

Dim radius As Double

center(0) = 2: center(1) = 2: center(2) = 0

radius = 1

Set circleObj = ThisDrawing.ModelSpace. _

AddCircle(center, radius)

Dim linetypeName As String

linetypeName = "CENTER"

' 从 acad.lin 文件加载“CENTER”线型

ThisDrawing.Linetypes.Load linetypeName, "acad.lin"

If Err.Description <> "" Then MsgBox Err.Description

' 指定圆的线型为“CENTER”

circleObj.Linetype = "CENTER"

circleObj.Update


本例创建一个圆并将其设置为红色，然后使用 Update 方法更新该圆，并使其在 AutoCAD 中可见。

Sub Ch3_UpdateDisplay()

Dim circleObj As AcadCircle

Dim center(0 To 2) As Double

Dim radius As Double

center(0) = 1: center(1) = 1: center(2) = 0

radius = 1

' 创建圆并将其设置为红色

Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)

circleObj.Color = acRed

' 更新圆

circleObj.Update


下面的样例提示用户输入两个点，然后以这两个点为起点和端点绘制一条直线。

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


以下代码示范如何计算用户输入的两点之间的距离。在本例中，数据类型是已知的，因为所有的坐标值均为双精度数。三维坐标值是一个包含三个元素的双精度数组，而二维坐标值是一个包含两个元素的双精度数组。

Sub Ch2_CalculateDistance()

Dim point1 As Variant

Dim point2 As Variant

' 获取用户输入的点

point1 = ThisDrawing.Utility.GetPoint _

(, vbCrLf & "First point: ")

point2 = ThisDrawing.Utility.GetPoint _

(point1, vbCrLf & "Second point: ")

' 计算 point1 和 point2 之间的距离

Dim x As Double, y As Double, z As Double

Dim dist As Double

x = point1(0) - point2(0)

y = point1(1) - point2(1)

z = point1(2) - point2(2)

dist = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))

'显示计算出来的距离

MsgBox "The distance between the points is: " _

& dist, , "Calculate Distance"


本例提示用户输入五个点，然后根据输入的点创建多段线。该多段线是闭合的，所形成的面积显示在消息框中。

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"


  1. 在“VBA 管理器”中，使用“加载”选项打开“打开 VBA 工程”对话框。
  2. 在“打开 VBA 工程”对话框中，选择要打开的工程文件。“VBA 工程”对话框只能打开有效的 DVB 文件。如果用户试图打开其他类型的文件，则会收到一条错误信息。
  3. 选择“打开”。

用户还可以使用以下任意方法来加载工程文件：

1、输入VBALOAD 命令，打开“打开 VBA 工程”对话框。
2、将 DVB 文件从 Windows 资源管理器拖到 AutoCAD 窗口中打开的图形中。


本例返回模型空间中的第一个图元对象，类似的代码还可以用来检索图纸空间中的第一个图元：

Sub Ch2_FindFirstEntity()

' 本例返回模型空间中的第一个图元

On Error Resume Next

Dim entity As AcadEntity

If ThisDrawing.ModelSpace.count <> 0 Then

Set entity = ThisDrawing.ModelSpace.Item(0)

MsgBox entity.ObjectName + _

" is the first entity in model space."

Else

MsgBox "There are no objects in model space."

End If


  1. 创建工程 (DVB) 文件的备份并将其命名为 <project name>-backup.dvb，其中 <project name> 是工程文件的原始名称。

这可以确保在必要时以前的 AutoCAD 版本可以使用副本。

  2. 在 AutoCAD 2004 VBA 编程环境 (IDE) 中打开工程 (DVB) 文件。
  3. 如果 CreateObject 或 GetObject 函数使用的是独立于版本的 ProgID，则将函数更改为使用依赖于版本的 ProgID。对于 AutoCAD 2004，请使用依赖于版本的 ProgID。

例如，如果在 AutoCAD 2004 中使用 CreateObject，请将 CreateObject ("AutoCAD.Application") 替换为 CreateObject ("AutoCAD.Application.16")。

此外，如果 GetInterfaceObject 方法使用的是独立于版本的 ProgID，则必须将该方法更改成使用依赖于版本的 ProgID。

注意 如果在以前版本的 AutoCAD 中使用 CreateObject、GetObject 或 GetInterfaceObject，则需要使用对应版本的 ProgID。例如，对于 AutoCAD 2002，需要将 CreateObject ("AutoCAD.Application") 替换为 CreateObject ("AutoCAD.Application.15")。

  4. 以相同的名称保存工程。


  1. 创建一个包含 Visual Basic Automation 源文件的备份文件夹。

这可以确保在必要时以前的 AutoCAD 版本可以使用源文件的副本。

  2. 在 Visual Basic 中打开工程 (VBP) 文件，然后在“工程”菜单上单击“引用”。
  3. 在“引用”对话框中，删除对名为 acad.tlb 的类型库（其默认位置是 c:\program files\autocad 2002）的引用。
  4. 在“引用”对话框中，添加对名为 acax16enu.tlb 的类型库（其默认位置是 c:\program files\common files\autodesk shared）的引用，然后单击“确定”。
  5. 如果 CreateObject 或 GetObject 函数使用的是独立于版本的 ProgID，则将函数更改为使用依赖于版本的 ProgID。对于 AutoCAD 2004，请使用依赖于版本的 ProgID。

例如，如果在 AutoCAD 2004 中使用 CreateObject，请将 CreateObject ("AutoCAD.Application") 替换为 CreateObject ("AutoCAD.Application.16")。

此外，如果 GetInterfaceObject 方法使用的是独立于版本的 ProgID，则必须将该方法更改成使用依赖于版本的 ProgID。

注意 如果在以前的 AutoCAD 版本中使用 CreateObject、GetObject 或 GetInterfaceObject，则需要使用对应版本的 ProgID。例如，对于 AutoCAD 2002，需要将 CreateObject ("AutoCAD.Application") 替换为 CreateObject ("AutoCAD.Application.15")。

保存工程文件并重新编译。


  1. 打开 VBA 管理器，并选择要嵌入的工程。
  2. 选择“嵌入”。


Sub Ch3_ZoomAll()

' ZoomAll

MsgBox "Perform a ZoomAll", , "ZoomAll"

ThisDrawing.Application.ZoomAll

' ZoomExtents

MsgBox "Perform a ZoomExtents", , "ZoomExtents"

ThisDrawing.Application.ZoomExtents


本例创建一个关联的图案填充，然后创建一个圆并将该圆作为内部环附加到图案填充。

Sub Ch4_AppendInnerLoopToHatch()

Dim hatchObj As AcadHatch

Dim patternName As String

Dim PatternType As Long

Dim bAssociativity As Boolean

' 定义和创建图案填充

patternName = "ANSI31"

PatternType = 0

bAssociativity = True

Set hatchObj = ThisDrawing.ModelSpace. _

AddHatch(PatternType, patternName, bAssociativity)

' 创建图案填充的外部环

Dim outerLoop(0 To 1) As AcadEntity

Dim center(0 To 2) As Double

Dim radius As Double

Dim startAngle As Double

Dim endAngle As Double

center(0) = 5: center(1) = 3: center(2) = 0

radius = 3

startAngle = 0

endAngle = 3.141592

Set outerLoop(0) = ThisDrawing.ModelSpace. _

AddArc(center, radius, startAngle, endAngle)

Set outerLoop(1) = ThisDrawing.ModelSpace. _

AddLine(outerLoop(0).startPoint, outerLoop(0).endPoint)

' 将外部环附加到 Hatch 对象

hatchObj.AppendOuterLoop (outerLoop)

' 创建一个圆作为图案填充的内部环

Dim innerLoop(0) As AcadEntity

center(0) = 5: center(1) = 4.5: center(2) = 0

radius = 1

Set innerLoop(0) = ThisDrawing.ModelSpace. _

AddCircle(center, radius)

' 将圆作为内部环附加到图案填充

hatchObj.AppendInnerLoop (innerLoop)

' 计算并显示图案填充

hatchObj.Evaluate

ThisDrawing.Regen True


本例从 acad.lin 文件加载“CENTER”线型。如果该线型已经存在或者文件不存在，则显示相关消息。

Sub Ch4_LoadLinetype()

On Error GoTo ERRORHANDLER

Dim linetypeName As String

linetypeName = "CENTER"

' 从 acad.lin 文件加载“CENTER”线型

ThisDrawing.Linetypes.Load linetypeName, "acad.lin"

Exit Sub

ERRORHANDLER:

MsgBox Err.Description


本例创建一条直线，然后修改其端点拉长这条直线。

Sub Ch4_LengthenLine()

' 定义和创建直线

Dim lineObj As AcadLine

Dim startPoint(0 To 2) As Double

Dim endPoint(0 To 2) As Double

startPoint(0) = 0

startPoint(1) = 0

startPoint(2) = 0

endPoint(0) = 1

endPoint(1) = 1

endPoint(2) = 1

Set lineObj = ThisDrawing.ModelSpace. _

AddLine(startPoint, endPoint)

lineObj.Update

' 将端点更改为 4,4,4

' 拉长直线

endPoint(0) = 4

endPoint(1) = 4

endPoint(2) = 4

lineObj.endPoint = endPoint

lineObj.Update


如果图层设置已经保存在当前的图形中，则下面的代码列出所有已经保存的图层设置名称：

Sub Ch4_ListStates()

On Error Resume Next

Dim oLSMDict As AcadDictionary

Dim XRec As Object

Dim layerstateNames As String

layerstateNames = ""

' 获取 ACAD_LAYERSTATES 词典，它保存在

' Layers 对象的扩展词典中

Set oLSMDict = ThisDrawing.Layers. _

GetExtensionDictionary.Item("ACAD_LAYERSTATES")

' 列出每个己保存的图层设置的名称。设置

' 保存为词典中的 XRecord。

For Each XRec In oLSMDict

layerstateNames = layerstateNames + XRec.Name + vbCrLf

Next XRec

MsgBox "The saved layer settings in this drawing are: " + _

vbCrLf + layerstateNames


本例创建一条优化多段线，然后偏移该多段线。

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


本例创建一条闭合的优化多段线，然后将该多段线绕基点 (4,4.25,0) 旋转 45 度。

Sub Ch4_RotatePolyline()

' 创建多段线

Dim plineObj As AcadLWPolyline

Dim points(0 To 11) As Double

points(0) = 1: points(1) = 2

points(2) = 1: points(3) = 3

points(4) = 2: points(5) = 3

points(6) = 3: points(7) = 3

points(8) = 4: points(9) = 4

points(10) = 4: points(11) = 2

Set plineObj = ThisDrawing.ModelSpace. _

AddLightWeightPolyline(points)

plineObj.Closed = True

ZoomAll

' 定义绕点 (4,4.25,0) 旋转

' 45 度

Dim basePoint(0 To 2) As Double

Dim rotationAngle As Double

basePoint(0) = 4: basePoint(1) = 4.25: basePoint(2) = 0

rotationAngle = 0.7853981 ' 45 度

' 旋转多段线

plineObj.Rotate basePoint, rotationAngle

plineObj.Update


本例创建一条优化多段线，然后绕一个轴镜像该多段线。新创建的多段线会着上蓝色。

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


以下代码使用 CreateTypedArray 转换三个数组：样条曲线拟合点的坐标及其起点和端点切向。然后将变量传递给 AddSpline 方法，创建样条曲线。

Sub Ch2_CreateSplineUsingTypedArray()

' 本例使用 CreateTypedArray 方法

' 在模型空间中创建样条曲线对象。

Dim splineObj As AcadSpline

Dim startTan As Variant

Dim endTan As Variant

Dim fitPoints As Variant

Dim utilObj As Object ' 后期绑定 Utility 对象

Set utilObj = ThisDrawing.Utility

' 定义 Spline 对象

utilObj.CreateTypedArray _

startTan, vbDouble, 0.5, 0.5, 0

utilObj.CreateTypedArray _

endTan, vbDouble, 0.5, 0.5, 0

utilObj.CreateTypedArray _

fitPoints, vbDouble, 0, 0, 0, 5, 5, 0, 10, 0, 0

Set splineObj = ThisDrawing.ModelSpace.AddSpline _

(fitPoints, startTan, endTan)

' 放大新创建的样条曲线

ZoomAll


本例使用 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


Sub Ch3_ZoomScaled()

MsgBox "Perform a ZoomScaled using:" & vbCrLf & _

"Scale Type: acZoomScaledRelative" & vbCrLf & _

"Scale Factor: 2", , "ZoomScaled"

Dim scalefactor As Double

Dim scaletype As Integer

scalefactor = 2

scaletype = acZoomScaledRelative

ThisDrawing.Application.ZoomScaled scalefactor, scaletype


本例创建一条直线，并使用转换矩阵将直线旋转 90 度。

Sub Ch4_TransformBy()

' 创建直线

Dim lineObj As AcadLine

Dim startPt(0 To 2) As Double

Dim endPt(0 To 2) As Double

startPt(0) = 2

startPt(1) = 1

startPt(2) = 0

endPt(0) = 5

endPt(1) = 1

endPt(2) = 0

Set lineObj = ThisDrawing.ModelSpace. _

AddLine(startPt, endPt)

ZoomAll

' 将 transMat 变量初始化为

' 转换矩阵，该矩阵将对象绕

' 点 (0,0,0) 旋转 90 度

Dim transMat(0 To 3, 0 To 3) As Double

transMat(0, 0) = 0#: transMat(0, 1) = -1#

transMat(0, 2) = 0#: transMat(0, 3) = 0#

transMat(1, 0) = 1#: transMat(1, 1) = 0#

transMat(1, 2) = 0#: transMat(1, 3) = 0#

transMat(2, 0) = 0#: transMat(2, 1) = 0#

transMat(2, 2) = 1#: transMat(2, 3) = 0#

transMat(3, 0) = 0#: transMat(3, 1) = 0#

transMat(3, 2) = 0#: transMat(3, 3) = 1#

' 使用定义的转换矩阵来变换直线

lineObj.TransformBy transMat

lineObj.Update

End Sub

下面是转换矩阵的更多样例：

旋转矩阵：绕点 (0,0,0) 旋转 90 度
0.0 | -1.0 | 0.0 | 0.0
1.0 | 0.0 | 0.0 | 0.0
0.0 | 0.0 | 1.0 | 0.0
0.0 | 0.0 | 0.0 | 1.0

旋转矩阵：绕点 (5,5,0) 旋转 45 度
0.707107 | -0.707107 | 0.0 | 5.0
0.707107 | 0.707107 | 0.0 | -2.071068
0.0 | 0.0 | 1.0 | 0.0
0.0 | 0.0 | 0.0 | 1.0

平移矩阵：将图元平移到 (10,10,0)
1.0 | 0.0 | 0.0 | 10.0
0.0 | 1.0 | 0.0 | 10.0
0.0 | 0.0 | 1.0 | 0.0
0.0 | 0.0 | 0.0 | 1.0

缩放矩阵：在点 (0,0,0) 处缩放 10,10
10.0 | 0.0 | 0.0 | 0.0
0.0 | 10.0 | 0.0 | 0.0
0.0 | 0.0 | 10.0 | 0.0
0.0 | 0.0 | 0.0 | 1.0

缩放矩阵：在点 (2,2,0) 处缩放 10,10
10.0 | 0.0 | 0.0 | -18.0
0.0 | 10.0 | 0.0 | -18.0
0.0 | 0.0 | 10.0 | 0.0
0.0 | 0.0 | 0.0 | 1.0


添加 View 对象

Sub Ch3_AddView()

' 将命名视图添加到 Views 集合

Dim viewObj As AcadView

Set viewObj = ThisDrawing.Views.Add("View1")

End Sub

删除 View 对象

下面的样例删除了 View 对象 (viewObj)。

Sub Ch3_DeleteView()

Dim viewObj As AcadView

Set viewObj = ThisDrawing.Views("View1")

' 删除视图

viewObj.Delete


添加构造线

下面的代码样例使用两个点 (5, 0, 0) 和 (1, 1, 0) 创建构造线对象。

Sub Ch3_AddXLine()

Dim xlineObj As AcadXline

Dim basePoint(0 To 2) As Double

Dim directionVec(0 To 2) As Double

' 定义构造线

basePoint(0) = 2#: basePoint(1) = 2#: basePoint(2) = 0#

directionVec(0) = 1#: directionVec(1) = 1#: directionVec(2) = 0#

' 在模型空间中创建构造线

Set xlineObj = ThisDrawing.ModelSpace.AddXLine _

(basePoint, directionVec)

ThisDrawing.Application.ZoomAll

End Sub

查询构造线

本例查找在添加构造线中创建的构造线的基点和方向矢量。

Dim BPoint As Variant

Dim Vector As Variant

BPoint = xlineObj.basePoint

Vector = xlineObj.DirectionVector


下面的代码样例使用两点 (5, 0, 0) 和 (1, 1, 0) 创建一个 Ray 对象。然后查询当前的基点和方向矢量，并将结果显示在消息框中。最后更改方向矢量，并再次查询和显示基点及新的方向矢量。

Sub Ch3_EditRay()

Dim rayObj As AcadRay

Dim basePoint(0 To 2) As Double

Dim secondPoint(0 To 2) As Double

' 定义射线

basePoint(0) = 3#: basePoint(1) = 3#: basePoint(2) = 0#

secondPoint(0) = 4#: secondPoint(1) = 4#: secondPoint(2) = 0#

' 在模型空间中创建 Ray 对象

Set rayObj = ThisDrawing.ModelSpace.AddRay _

(basePoint, secondPoint)

ThisDrawing.Application.ZoomAll

' 查找 Ray 的当前状态

MsgBox "The base point of the ray is: " & _

rayObj.basePoint(0) & ", " & _

rayObj.basePoint(1) & ", " & _

rayObj.basePoint(2) & vbCrLf & _

"The directional vector for the ray is: " & _

rayObj.DirectionVector(0) & ", " & _

rayObj.DirectionVector(1) & ", " & _

rayObj.DirectionVector(2), , "Edit Ray"

' 更改射线的方向矢量

Dim newVector(0 To 2) As Double

newVector(0) = -1

newVector(1) = 1

newVector(2) = 0

rayObj.DirectionVector = newVector

ThisDrawing.Regen False

MsgBox "The base point of the ray is: " & _

rayObj.basePoint(0) & ", " & _

rayObj.basePoint(1) & ", " & _

rayObj.basePoint(2) & vbCrLf & _

"The directional vector for the ray is: " & _

rayObj.DirectionVector(0) & ", " & _

rayObj.DirectionVector(1) & ", " & _

rayObj.DirectionVector(2), , "Edit Ray"


  1. 在 VBA 管理器中选择要卸载的工程。
  2. 选择“卸载”。
  3. 或者，使用 VBAUNLOAD 命令，该命令会提示输入要卸载的工程。


以下代码指定选择半径大于或等于 5.0 的圆：

Sub Ch4_FilterRelational()

Dim sstext As AcadSelectionSet

Dim FilterType(2) As Integer

Dim FilterData(2) As Variant

Set sstext = ThisDrawing.SelectionSets.Add("SS5")

FilterType(0) = 0

FilterData(0) = "Circle"

FilterType(1) = -4

FilterData(1) = ">="

FilterType(2) = 40

FilterData(2) = 5#

sstext.SelectOnScreen FilterType, FilterData


以下代码指定三个条件：对象必须是蓝色的，必须是 Circle，必须在图层 0 上。代码还将 FilterType 和 FilterData 声明为三个元素的数组，并将每个条件指定给一个元素：

Sub Ch4_FilterBlueCircleOnLayer0()

Dim sstext As AcadSelectionSet

Dim FilterType(2) As Integer

Dim FilterData(2) As Variant

Set sstext = ThisDrawing.SelectionSets.Add("SS4")

FilterType(0) = 0

FilterData(0) = "Circle"

FilterType(1) = 62

FilterData(1) = acBlue

FilterType(2) = 8

FilterData(2) = "0"

sstext.SelectOnScreen FilterType, FilterData


本例创建一个圆，然后将此圆沿着 X 轴移动两个单位。

Sub Ch4_MoveCircle()

' 创建圆

Dim circleObj As AcadCircle

Dim center(0 To 2) As Double

Dim radius As Double

center(0) = 2#: center(1) = 2#: center(2) = 0#

radius = 0.5

Set circleObj = ThisDrawing.ModelSpace. _

AddCircle(center, radius)

ZoomAll

' 定义组成移动矢量的点。

' 移动矢量将圆沿 x 轴移动

' 两个单位。

Dim point1(0 To 2) As Double

Dim point2(0 To 2) As Double

point1(0) = 0: point1(1) = 0: point1(2) = 0

point2(0) = 2: point2(1) = 0: point2(2) = 0

' 移动圆

circleObj.Move point1, point2

circleObj.Update


下面的样例显示了使用 ZoomCenter 以相同大小和两倍大小显示视图的效果：

Sub Ch3_ZoomCenter()

MsgBox "Perform a ZoomCenter using:" & vbCrLf & _

"Center 3, 3, 0" & vbCrLf & _

"Magnification: 10", , "ZoomCenter"

Dim Center(0 To 2) As Double

Dim magnification As Double

Center(0) = 3: Center(1) = 3: Center(2) = 0

magnification = 10

ThisDrawing.Application.ZoomCenter Center, magnification


以下子例程在当前图形中查找所有的块引用，然后查找附着到这些块引用的属性，并将它们列在 Excel 电子表格中。要运行本样例，请按以下步骤执行：

  1. 打开包含块引用的图形，这些块引用带有属性。（样例图形 sample/activeX/attrib.dwg 包含这样的块引用。）
  2. 使用 AutoCAD VBAIDE 命令打开 VBA IDE。
  3. 使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 8.0 对象模型。
  4. 将这个子例程复制到 VBA 的“代码”窗口中并运行它。

Sub Ch12_Extract()

Dim Excel As Excel.Application

Dim ExcelSheet As Object

Dim ExcelWorkbook As Object

Dim RowNum As Integer

Dim Header As Boolean

Dim elem As AcadEntity

Dim Array1 As Variant

Dim Count As Integer

' 启动 Excel。

Set Excel = New Excel.Application

' 创建新的工作簿并查找活动电子表格。

Set ExcelWorkbook = Excel.Workbooks.Add

Set ExcelSheet = Excel.ActiveSheet

ExcelWorkbook.SaveAs "Attribute.xls"

RowNum = 1

Header = False

' 遍历模型空间，查找

' 所有的块引用。

For Each elem In ThisDrawing.ModelSpace

With elem

' 找到块引用时，

' 检查其属性

If StrComp(.EntityName, "AcDbBlockReference", 1) _

= 0 Then

If .HasAttributes Then

' 获取属性

Array1 = .GetAttributes

' 将属性的标记字符串

' 复制到 Excel

For Count = LBound(Array1) To UBound(Array1)

If Header = False Then

If StrComp(Array1(Count).EntityName, _

"AcDbAttribute", 1) = 0 Then

ExcelSheet.Cells(RowNum, _

Count + 1).value = _

Array1(Count).TagString

End If

End If

Next Count

RowNum = RowNum + 1

For Count = LBound(Array1) To UBound(Array1)

ExcelSheet.Cells(RowNum, Count + 1).value _

= Array1(Count).textString

Next Count

Header = True

End If

End If

End With

Next elem

Excel.Application.Quit


本样例在模型空间中创建一个长方体，然后根据某个平面镜像该长方体，并将镜像得到的长方体着色为红色。

Sub Ch8_MirrorABox3D()

' 创建长方体对象

Dim boxObj As Acad3DSolid

Dim length As Double

Dim width As Double

Dim height As Double

Dim center(0 To 2) As Double

center(0) = 5#: center(1) = 5#: center(2) = 0

length = 5#: width = 7: height = 10#

' 在模型空间中创建长方体 (3DSolid) 对象

Set boxObj = ThisDrawing.ModelSpace. _

AddBox(center, length, width, height)

' 用三个点定义镜像平面

Dim mirrorPt1(0 To 2) As Double

Dim mirrorPt2(0 To 2) As Double

Dim mirrorPt3(0 To 2) As Double

mirrorPt1(0) = 1.25: mirrorPt1(1) = 0: mirrorPt1(2) = 0

mirrorPt2(0) = 1.25: mirrorPt2(1) = 2: mirrorPt2(2) = 0

mirrorPt3(0) = 1.25: mirrorPt3(1) = 2: mirrorPt3(2) = 2

' 镜像长方体

Dim mirrorBoxObj As Acad3DSolid

Set mirrorBoxObj = boxObj.Mirror3D _

(mirrorPt1, mirrorPt2, mirrorPt3)

mirrorBoxObj.Color = acRed

ZoomAll