Sub Example_Add()
    ' Этот пример добавляет блок, словарь, стиль измерения,
    ' группу, слой, зарегистрированное приложение, набор выбора,
    ' стиль текста, вид, область просмотра и UCS, используя метод Add.
    
    GoSub ADDBLOCK
    GoSub ADDDICTIONARY
    GoSub ADDDIMSTYLE
    GoSub ADDGROUP
    GoSub ADDLAYER
    GoSub ADDREGISTEREDAPP
    GoSub ADDSELECTIONSET
    GoSub ADDTEXTSTYLE
    GoSub ADDVIEW
    GoSub ADDVIEWPORT
    GoSub ADDUCS
    Exit Sub
    
ADDBLOCK:
    ' Создайте новый блок по имени "New_Block"
    Dim blockObj As AcadBlock
    
    ' Определите блок
    Dim insertionPnt(0 To 2) As Double
    insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
    
    ' Добавьте блок к коллекции блоков
    Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "New_Block")
    MsgBox blockObj.name & " has been added." & vbCrLf & _
            "Origin: " & blockObj.origin(0) & ", " & blockObj.origin(1) _
            & ", " & blockObj.origin(2), , "Add Example"
    Return
    
ADDDICTIONARY:
    ' Создайте новый словарь по имени "New_Dictionary"
    Dim dictObj As AcadDictionary
    
    ' Добавьте словарь к коллекции словарей
    Set dictObj = ThisDrawing.Dictionaries.Add("New_Dictionary")
    MsgBox dictObj.name & " has been added.", , "Add Example"
    Return

ADDDIMSTYLE:
    ' Создайте новый стиль измерения по имени "New_Dimstyle" в текущем рисунке
    Dim DimStyleObj As AcadDimStyle
    
    ' Добавьте стиль измерения к коллекции стилей измерения
    Set DimStyleObj = ThisDrawing.DimStyles.Add("New_Dimstyle")
    MsgBox DimStyleObj.name & " has been added.", , "Add Example"
    Return
    
ADDGROUP:
    ' Создайте новую группу по имени "New_Group" в текущем рисунке
    Dim groupObj As AcadGroup
    
    ' Добавьте группу к коллекции групп
    Set groupObj = ThisDrawing.Groups.Add("New_Group")
    MsgBox groupObj.name & " has been added.", , "Add Example"
    Return
    
ADDLAYER:
    ' Этот пример создает новый слой по имени "New_Layer"
    Dim layerObj As AcadLayer
    
    ' Добавьте слой к коллекции слоев
    Set layerObj = ThisDrawing.Layers.Add("New_Layer")
    
    ' Сделайте новый слой активным слоем для рисунка
    ThisDrawing.ActiveLayer = layerObj
    
    ' Покажите состояние нового слоя
     MsgBox layerObj.name & " has been added." & vbCrLf & _
            "LayerOn Status: " & layerObj.LayerOn & vbCrLf & _
            "Freeze Status: " & layerObj.Freeze & vbCrLf & _
            "Lock Status: " & layerObj.Lock & vbCrLf & _
            "Color: " & layerObj.Color, , "Add Example"
    Return
    
ADDREGISTEREDAPP:
    ' Создайте зарегистрированное приложение по имени "New_RegApp" в текущем рисунке
    Dim RegAppObj As AcadRegisteredApplication
    
    ' Добавьте зарегистрированное приложение к зарегистрированной коллекции приложений
    Set RegAppObj = ThisDrawing.RegisteredApplications.Add("New_RegApp")
    MsgBox RegAppObj.name & " has been added.", , "Add Example"
    Return

ADDSELECTIONSET:
    ' Создайте набор выбора по имени "New_SelectionSet" в текущем рисунке
    Dim ssetObj As AcadSelectionSet
    
    ' Добавьте набор выбора в коллекцию наборов выбора
    Set ssetObj = ThisDrawing.SelectionSets.Add("New_SelectionSet")
    MsgBox ssetObj.name & " has been added." & vbCrLf & _
           "The number of items in the selection set is " & ssetObj.count _
           , , "Add Example"
    Return
    
ADDTEXTSTYLE:
    ' Создайте стиль текста по имени "New_Textstyle" в текущем рисунке
    Dim txtStyleObj As AcadTextStyle
    
    ' Добавьте стиль текста к коллекции стилей текста
    Set txtStyleObj = ThisDrawing.TextStyles.Add("New_Textstyle")
    MsgBox txtStyleObj.name & " has been added." & vbCrLf & _
           "Height: " & txtStyleObj.height & vbCrLf & _
           "Width: " & txtStyleObj.width, , "Add Example"
    Return
    
ADDVIEW:
    ' Создайте вид по имени "New_View" в текущем рисунке
    Dim viewObj As AcadView
    
    ' Добавьте вид к коллекции видов
    Set viewObj = ThisDrawing.Views.Add("New_View")
    MsgBox viewObj.name & " has been added." & vbCrLf & _
           "Height: " & viewObj.height & vbCrLf & _
           "Width: " & viewObj.width, , "Add Example"
    Return
    
ADDVIEWPORT:
    ' Создайте область просмотра по имени "New_Viewport" в текущем рисунке
    Dim vportObj As AcadViewport
    
    ' Добавьте область просмотра к коллекции областей просмотра
    Set vportObj = ThisDrawing.Viewports.Add("New_Viewport")
    MsgBox vportObj.name & " has been added." & vbCrLf & _
           "GridOn Status: " & vportObj.GridOn & vbCrLf & _
           "OrthoOn Status: " & vportObj.OrthoOn & vbCrLf & _
           "SnapOn Status: " & vportObj.SnapOn, , "Add Example"
    Return
    
ADDUCS:
    ' Создайте UCS по имени "New_UCS" в текущем рисунке
    Dim ucsObj As AcadUCS
    Dim origin(0 To 2) As Double
    Dim xAxisPnt(0 To 2) As Double
    Dim yAxisPnt(0 To 2) As Double
    
    ' Определите UCS
    origin(0) = 4#: origin(1) = 5#: origin(2) = 3#
    xAxisPnt(0) = 5#: xAxisPnt(1) = 5#: xAxisPnt(2) = 3#
    yAxisPnt(0) = 4#: yAxisPnt(1) = 6#: yAxisPnt(2) = 3#
    
    ' Добавьте UCS к коллекции UserCoordinatesSystems
    Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "New_UCS")
    MsgBox ucsObj.name & " has been added." & vbCrLf & _
            "Origin: " & ucsObj.origin(0) & ", " & ucsObj.origin(1) _
            & ", " & ucsObj.origin(2), , "Add Example"
    Return
    
End Sub

Сайт управляется системой uCoz