发布时间 : 星期三 文章CAD - VBA更新完毕开始阅读
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