If UCase(StrTF) = \

MsgBox \点\：\\ Else End If

ThisDrawing.Utility.GetEntity Obj1, Pnt1, \选择一个对象：\ Obj1.color = 1 End Sub

Sub MyZoomView3()

Str1 = ThisDrawing.Utility.GetString(1, \请按回车键：\

ThisDrawing.Application.ZoomScaled 0.7, acZoomScaledRelative End Sub

6、选择集合'''**** SelectionSets ***************************

Sub MySelectionSets() Dim K As Integer

Dim ssetObj As AcadSelectionSet Dim objCollection As AcadEntity Dim ob As AcadEntity

Dim I As Integer

For I = ThisDrawing.SelectionSets.count - 1 To 0 Step -1 ThisDrawing.SelectionSets(I).Delete Next I

' ThisDrawing.Utility.GetEntity objCollection, Pnt1, \选择一个对象：\' objCollection.color = 1

Set ssetObj = ThisDrawing.SelectionSets.Add(\' Set ssetObj = ThisDrawing.ActiveSelectionSet ssetObj.Select acSelectionSetAll If ssetObj.count > 0 Then

MsgBox \选择集中对象数目: \ For Each ob In ssetObj ob.color = acMagenta Next End If End Sub

7、栅格图像Raster

Sub InsertRaster()

Dim a As AcadRasterImage Dim b(2) As Double Dim ly As AcadLayer

Dim PicFileName As String Dim factor As Double factor = 2#

Set ly = ThisDrawing.Application.ActiveDocument.Layers.Add(\底图\ PicFileName = \图片\\Bliss.jpg\ b(0) = 100 b(1) = 100 b(2) = 0

Set a = ThisDrawing.Application.ActiveDocument.ModelSpace.AddRaster(PicFileName, b, factor, 45)

a.Transparency = True a.Layer = \底图\

ThisDrawing.Application.ZoomExtents ThisDrawing.SaveAs \End Sub

8、计算面积

'''************************计算面积************************************** Sub Ch3_CalculateDefinedArea() Dim p1 As Variant Dim p2 As Variant Dim p3 As Variant Dim p4 As Variant Dim p5 As Variant

' 从用户处取得点

p1 = ThisDrawing.Utility.getpoint(, vbCrLf & \第一个点: \ p2 = ThisDrawing.Utility.getpoint(p1, vbCrLf & \第二个点: \ p3 = ThisDrawing.Utility.getpoint(p2, vbCrLf & \第三个点: \ p4 = ThisDrawing.Utility.getpoint(p3, vbCrLf & \第四个点: \ p5 = ThisDrawing.Utility.getpoint(p4, vbCrLf & \第五个点: \

' 由这些点创建二维多段线

Dim polyObj As AcadLWPolyline Dim vertices(0 To 9) As Double

vertices(0) = p1(0): vertices(1) = p1(1)

vertices(2) = p2(0): vertices(3) = p2(1) vertices(4) = p3(0): vertices(5) = p3(1) vertices(6) = p4(0): vertices(7) = p4(1) vertices(8) = p5(0): vertices(9) = p5(1)

Set polyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline _ (vertices)

polyObj.Closed = True

ThisDrawing.Application.ZoomAll

' 显示多段线的面积

MsgBox \通过定义的点形成的面积为 \ polyObj.Area, , \计算定义的面积\End Sub

9、加载菜单

‘加载菜单

Sub MenuAutocad()

Dim acMenuGroup As AcadMenuGroup

For Each acMenuGroup In ThisDrawing.Application.MenuGroups acMenuGroup.Unload Next

Set acMenuGroup = ThisDrawing.Application.MenuGroups.Load(\End Sub

10、‘增加菜单按钮和创建菜单按钮

Sub CreateMenuFirst2()

Set acApp = ThisDrawing.Application Dim acMenu As AcadPopupMenu

Dim acMenuItem As AcadPopupMenuItem Dim NewacMenu As AcadPopupMenuItem

Set acMenu = acApp.MenuGroups(0).Menus(\文件(&F)\

Set acMenuItem = acMenu.AddMenuItem(0, \杨彪\

Set acMenuItem = acMenu.AddMenuItem(0, \杨彪4\

Set acMenu = ThisDrawing.Application.MenuGroups(0).Menus.Add(\杨彪111\ Set acMenuItem = acMenu.AddMenuItem(0, \放大\ Set acMenuItem = acMenu.AddMenuItem(1, \缩小\ Set acMenuItem = acMenu.AddMenuItem(2, \全景显示\

Set acMenuItem = acMenu.AddMenuItem(3, \最大显示\

Set acMenuItem = acMenu.AddMenuItem(4, \鸟瞰\ Set acMenuItem = acMenu.AddMenuItem(5, \移动\

acMenu.InsertInMenuBar 10

acApp.MenuGroups(0).SaveAs \End Sub

‘增加工具栏按钮和创建工具栏 Sub CreateToolFirst()

Set acApp = ThisDrawing.Application Dim acToolbar As AcadToolbar

Dim acToolbarItem As AcadToolbarItem Dim ToolbarItem As AcadToolbarItem On Error Resume Next

Set acToolbar = ThisDrawing.Application.MenuGroups(0).Toolbars(\常用\

Set ToolbarItem = acToolbar.AddToolbarButton(0, \杨彪22\ Call ToolbarItem.SetBitmaps(\图标\\1.ico\图标\\2.ico\

Set ToolbarItem = acToolbar.AddToolbarButton(0, \杨彪124\\\showpic2 \

Set acToolbar = ThisDrawing.Application.MenuGroups(0).Toolbars.Add(\杨彪1111\ Set ToolbarItem = acToolbar.AddToolbarButton(0, \放大\ Call ToolbarItem.SetBitmaps(\图标\\3.ico\图标\\3.ico\

Set ToolbarItem = acToolbar.AddToolbarButton(1, \缩小\ Call ToolbarItem.SetBitmaps(\图标\\4.bmp\图标\\4.bmp\

Set ToolbarItem = acToolbar.AddToolbarButton(2, \全景显示\

Set ToolbarItem = acToolbar.AddToolbarButton(3, \最大显示\ Call ToolbarItem.SetBitmaps(\图标\\5.ico\图标\\5.ico\

acToolbar.Visible = True

acApp.MenuGroups(0).SaveAs \End Sub

11、加载线型

'加载线型的子程序 Sub MLoadLineTypes() Dim BL0 As Boolean

Dim I As Integer, ILen As Integer