Логотип сайта поддержки пользователей САПРО сайте поддержки пользователей САПР Translate to:

Объекты AutoCAD

Меню и панели инструментов

Пример процедуры, добавляющей к AutoCAD новое меню

Эта процедура добавляет к основным меню AutoCAD выпадающее меню "VBA Tools", в котором четыре пункта: "VBA Editor", "Macros List", "VBA Manager" и "Aec VBA".

Option Explicit

 Public Sub AddVBAMenu()
    Dim objMenuGroup As AcadMenuGroup
    Dim objVBAMenu As AcadPopupMenu
    Dim objVBAIDE As AcadPopupMenuItem
    Dim objVBARUN As AcadPopupMenuItem
    Dim objVBAMAN As AcadPopupMenuItem
    Dim objAECVBA As AcadPopupMenuItem
    Dim strMacro As String
    
    'Bind to the first group of menus
    Set objMenuGroup = Application.MenuGroups.Item(0)
    'Bind our menu as a new popup in that group. The
    'Item will be captioned with 'VBA' - so if you would
    'Rather it had a different name, this is the place
    'To change it.
    Set objVBAMenu = objMenuGroup.Menus.Add("VBA Tools")
    'Assign the macro Esc Esc _VBAIDE
    'We will be re-using strMacro for each item
    strMacro = Chr(3) & Chr(3) & Chr(95) & "VBAIDE" & Chr(32)
    Set objVBAIDE = objVBAMenu.AddMenuItem(objVBAMenu.Count + 1, _
    "VBA Editor", strMacro)
    'Now for the Macro dialog
    strMacro = Chr(3) & Chr(3) & Chr(95) & "VBARUN" & Chr(32)
    Set objVBARUN = objVBAMenu.AddMenuItem(objVBAMenu.Count + 1, _
    "Macros List", strMacro)
    'Now the VBA Manager dialog
    strMacro = Chr(3) & Chr(3) & Chr(95) & "VBAMAN" & Chr(32)
    Set objVBAMAN = objVBAMenu.AddMenuItem(objVBAMenu.Count + 1, _
    "VBA Manager", strMacro)
    
    
    'Now for our special project command. Skip this one if you don't
    'Want to have an item to add the AEC references to all open VBA
    'Projects
    
    strMacro = Chr(3) & Chr(3) & Chr(95) & _
    "-VBARUN AecProject.dvb!modRunOnce.AddRefs" & Chr(32) _
    & "_VBAUNLOAD AecProject.dvb" & Chr(32)
    
    
    Set objAECVBA = objVBAMenu.AddMenuItem(objVBAMenu.Count + 1, _
    "Aec VBA", strMacro)
    
    'Insert it second to last
    objVBAMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count)
    'IMPORTANT -IF YOU ARE JUST EXPERIMENTING
    'And you do not want to apply these changes to the menu beyond the
    'Current session of AutoCAD, Comment out the next line so that the
    'Changes are NOT saved to file.
    objMenuGroup.Save (acMenuFileCompiled)
 End Sub

Отображение экранного меню

Процедура не только отображает меню, если оно не видно, но и скрывает его, если оно отображено.

Option Explicit 

Public Sub WaxOnWaxOff()
    Dim blnScreen As Boolean
    Dim objPref As AcadPreferences
    Set objPref = Application.Preferences
    blnScreen = objPref.Display.DisplayScreenMenu
    objPref.Display.DisplayScreenMenu = Not blnScreen
End Sub

Загрузка меню из файла mnc с помощью VBA

Option Explicit 

Public Sub SetUpDP()
  Dim objBar As AcadMenuBar
  Dim objItem As AcadPopupMenuItem
  Dim strMacro As String
  Dim strPath As String
  Dim intItemCnt As Integer
  Set objBar = Application.MenuBar
  intItemCnt = objBar.Item(2).Count
  strMacro = Chr(3) & Chr(3) & Chr(95) & "MENULOAD DP.mnc" & Chr(32)
  Set objItem = objBar.Item(2).AddSeparator(intItemCnt)
  Set objItem = objBar.Item(2).AddMenuItem(intItemCnt + 1, "DP", strMacro)
  strPath = Application.Preferences.Files.SupportPath
  If Len(strPath) > 0 Then
    If InStr(1, strPath, "O:\Lib\Acad\Survey\DP\", vbTextCompare) = 0 Then
      strPath = strPath & ";" & "O:\Lib\Acad\Survey\DP\"
    End If
  Else
    strPath = "O:\Lib\Acad\Survey\DP\"
  End If
    Application.Preferences.Files.SupportPath = strPath
End Sub

Создание кнопки панели инструментов с закрепленной процедурой VBA

После запуска процедуры CreateIfMissing к последней загруженной группе меню будет дабавлена панель инструментов "Sample" с одной кнопкой, при нажатии на которую будет запускаться макрос SampleStuff

Option Explicit

Public Sub CreateIfMissing()
  Dim objMenuGrp As AcadMenuGroup
  Dim objTbarCol As AcadToolbars
  Dim objTbar As AcadToolbar
  Dim objItem As AcadToolbarItem
  Dim blnExist As Boolean
  Dim strMacro As String
  strMacro = "_-vbarun SampleStuff "
  Set objMenuGrp = ThisDrawing.Application.MenuGroups(0)
  Set objTbarCol = objMenuGrp.Toolbars
  For Each objTbar In objTbarCol
    If objTbar.Name = "Sample" Then
      blnExist = True
    End If
  Next objTbar
  If Not blnExist Then
    Set objTbar = objTbarCol.Add("Sample")
    Set objItem = objTbar.AddToolbarButton("", "Sample", _
    "MsgBox", strMacro)
    objTbar.Visible = True 'view it!
    objTbar.Dock acToolbarDockTop 'Dock it!
  End If
End Sub

Public Sub SampleStuff()
  MsgBox "This procedure was initiated from a toolbar."
End Sub

Создание панели инструментов для заморозки слоя по объекту и для разморозки всех слоев

Для работы этого примера Вам понадобятся два значька кнопок

LAYFRZ16.bmp - (layfrz16.bmp)
LAYFRZ24.bmp - (layfrz24.bmp)

Option Explicit

Private oLayers As Collection
Public Sub CreateIfMissing()
  Dim objMenuGrp As AcadMenuGroup
  Dim objTbarCol As AcadToolbars
  Dim objTbar As AcadToolbar
  Dim objItem As AcadToolbarItem
  Dim blnExist As Boolean
  Dim strMacro As String
  On Error GoTo Err_Control
  strMacro = "_-vbarun Winter "
  Set objMenuGrp = ThisDrawing.Application.MenuGroups(0)
  Set objTbarCol = objMenuGrp.Toolbars
  For Each objTbar In objTbarCol
    If objTbar.Name = "Winter_Summer" Then
      blnExist = True
    End If
  Next objTbar
  If Not blnExist Then
    Set objTbar = objTbarCol.Add("Winter_Summer")
    Set objItem = objTbar.AddToolbarButton("", "Winter", _
    "Pick Freeze", strMacro)
    objItem.SetBitmaps "LAYFRZ16.bmp", "LAYFRZ24.bmp"
    'Next Button, you get to pick the icon!
    strMacro = "_-vbarun Summer "
    Set objItem = objTbar.AddToolbarButton("", "Summer", _
    "Thaw Picks", strMacro)
    'See it and dock it
    objTbar.Visible = True
    objTbar.Dock acToolbarDockTop
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub

' Зазморозка слоя по выбранному примитиву
Public Sub Winter()
  Dim objEnt As AcadEntity
  Dim objLayer As AcadLayer
  Dim varPnt As Variant
  Dim strPrmt As String
  Dim intCnt As Integer
  On Error GoTo Err_Control
  strPrmt = vbCrLf & "Select entity: "
  ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmt
  If oLayers Is Nothing Then
    Set oLayers = New Collection
  End If
  If Not objEnt.Layer = ThisDrawing.ActiveLayer.Name Then
    Set objLayer = ThisDrawing.Layers(objEnt.Layer)
    objLayer.Freeze = True
    oLayers.Add objLayer, objLayer.Handle
  Else
    strPrmt = "Can not freeze layer " & objEnt.Layer
    ThisDrawing.Utility.Prompt strPrmt
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub

' Разморозка всех слоев
Public Sub Summer()
  Dim objLayer As AcadLayer
  Dim intCnt As Integer
  On Error GoTo Err_Control
  For Each objLayer In oLayers
    objLayer.Freeze = Not objLayer.Freeze
    oLayers.Remove objLayer.Handle
  Next objLayer
  ThisDrawing.Regen acAllViewports
  Set oLayers = Nothing
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub

Скрытие и отображение всех панелей инструментов

Option Explicit
 
Public TbarCol As Collection
 
Public Sub HideTbars()
' Скрытие всех видимых панелей инструментов
  Dim objMenuGrp As AcadMenuGroup
  Dim objAllMenus As AcadMenuGroups
  Dim objTbarCol As AcadToolbars
  Dim objTbar As AcadToolbar
  Dim strMacro As String
  On Error GoTo Err_Control
  Set TbarCol = New Collection
  Set objAllMenus = ThisDrawing.Application.MenuGroups
  For Each objMenuGrp In objAllMenus
  Set objTbarCol = objMenuGrp.Toolbars
  For Each objTbar In objTbarCol
    If objTbar.Visible = True Then
      TbarCol.Add objTbar, objTbar.Name
      objTbar.Visible = False
    End If
  Next objTbar
  Next objMenuGrp
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
Public Sub RestoreAll()
' Отображение всех панелей инструментов
  Dim objTbar As AcadToolbar
  For Each objTbar In TbarCol
    objTbar.Visible = True
  Next objTbar
End Sub

Слои

Сохранение и восстановление состояния слоев (информация о слоях сохраняется в текстовом файлее

Приведенный ниже пример позволяет сохранить информацию о состоянии всех слоев текущего чертежа в текстовом файле с расширенимем *.lay (процедура SaveSnapShot), и, при необходимости, восстановить состояние слоев открыв этот файл (процедура RestoreSnapShot).

Для начала обеспечим отображение окон сохранения и открытия файлов с помощью Windows API функций. Поместите следующий код в стандартный модуль:

Option Explicit
 
Public Declare Function GetSaveFileName Lib _
"comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
 
Public Declare Function GetOpenFileName Lib _
"comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
 
Public Const OFN_HIDEREADONLY = &H4
 
Public Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type
 
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Display and use the File open dialog
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function ShowOpen() As String
  Dim strTemp As String
  Dim VertName As OPENFILENAME
  VertName.lStructSize = Len(VertName)
  VertName.hwndOwner = ThisDrawing.HWND
  VertName.lpstrFilter = "Layer Files (*.lay)" + _
  Chr$(0) + "*.lay" + Chr$(0)
  VertName.lpstrFile = Space$(254)
  VertName.nMaxFile = 255
  VertName.lpstrFileTitle = Space$(254)
  VertName.nMaxFileTitle = 255
  VertName.lpstrInitialDir = CurDir
  VertName.lpstrTitle = "Llamas Are Supreme"
  VertName.flags = 0
  If GetOpenFileName(VertName) Then
    strTemp = (Trim(VertName.lpstrFile))
    ShowOpen = Mid(strTemp, 1, Len(strTemp) - 1)
  End If
End Function
 
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Display and use the File Save dialog
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function ShowSave() As String
  Dim strTemp As String
  Dim VertName As OPENFILENAME
  VertName.lStructSize = Len(VertName)
  VertName.hwndOwner = ThisDrawing.HWND
  VertName.lpstrFilter = "Layer Files (*.lay)" + _
  Chr$(0) + "*.lay" + Chr$(0)
  VertName.lpstrFile = Space$(254)
  VertName.nMaxFile = 255
  VertName.lpstrFileTitle = Space$(254)
  VertName.nMaxFileTitle = 255
  VertName.lpstrInitialDir = CurDir
  VertName.lpstrTitle = "Llamas Are Supreme"
  VertName.lpstrDefExt = ".lay"
  VertName.flags = OFN_HIDEREADONLY
  If GetSaveFileName(VertName) Then
    strTemp = (Trim(VertName.lpstrFile))
    ShowSave = Mid(strTemp, 1, Len(strTemp) - 1)
  End If
End Function

Теперь получение информации о слоях, ее сохранение и восстановление. Создайте еще один стандартный модуль и поместите в него следующий код:

Option Explicit
Public Sub SaveSnapShot()
  Dim objLayers As AcadLayers
  Dim objLayer As AcadLayer
  Dim strFile As String
  Dim intFile As Integer
  strFile = ShowSave ' Отображение окна диалога "Сохранить файл"
  
    ' Открытие файла и запись в него информации о состоянии слоев
  If Len(strFile) > 0 Then
    intFile = FreeFile
    Set objLayers = ThisDrawing.Layers
    Open strFile For Output As intFile
    For Each objLayer In objLayers
      Print #intFile, objLayer.Name & ","; objLayer.Color _
      & ","; objLayer.Freeze & ","; objLayer.Lock & ","; _
      objLayer.LayerOn & ","; objLayer.Linetype
    Next objLayer
  End If
  Close intFile
End Sub
 
Public Sub RestoreSnapShot()
  Dim objLayers As AcadLayers
  Dim objLayer As AcadLayer
  Dim strLayerName As String
  Dim strFile As String
  Dim strActive As String
  Dim strTemp As String
  Dim strVal As String
  Dim intFile As Integer
  On Error GoTo Err_Control
  strFile = ShowOpen ' Отображение окна диалога "Открыть файл"
  If Len(strFile) > 0 Then
    intFile = FreeFile
    Set objLayers = ThisDrawing.Layers
    'Find the active layer and save its name
    'Then create a temp layer and set it active
    strActive = ThisDrawing.ActiveLayer.Name
    Set objLayer = objLayers.Add("snaphold")
    ThisDrawing.ActiveLayer = objLayer
    
    ' Открытие файла и чтение из него информации о состоянии слоев
    Open strFile For Input As intFile
    Do Until EOF(intFile)
      Line Input #intFile, strVal
      strLayerName = ParseLayer(strVal)
      Set objLayer = objLayers(strLayerName)
      objLayer.Color = CInt(ParseLayer(strTemp))
      strTemp = ""
      objLayer.Freeze = CBool(ParseLayer(strTemp))
      strTemp = ""
      objLayer.Lock = CBool(ParseLayer(strTemp))
      strTemp = ""
      objLayer.LayerOn = CBool(ParseLayer(strTemp))
      strTemp = ""
      objLayer.Linetype = ParseLayer(strTemp)
      strTemp = ""
    Loop
    'Now restore the original active layer
    'And delete the temp layer.
    Set objLayer = objLayers(strActive)
    ThisDrawing.ActiveLayer = objLayer
    objLayers("snaphold").Delete
    Set objLayers = Nothing
    Set objLayer = Nothing
    Close intFile
  End If
  Set objLayers = Nothing
  ThisDrawing.Regen acActiveViewport
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
'@~~~~~~~~~~~~~ Parse Layer Info ~~~~~~~~~~~~~~~~~~~~@
' This is a simple function the parses the delimited
' String. The first time you call it for a string,
' Pass it the complete string, for each pass after that
' Pass it an empty string.
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function ParseLayer(ByVal strLayerInfo As String) As String
Static strInitialVal As String
Dim intPos As Integer
  If Len(strLayerInfo) > 0 Then strInitialVal = strLayerInfo
  intPos = InStr(strInitialVal, ",")
  If intPos = 0 Then
    ParseLayer = strInitialVal
    strInitialVal = ""
  Else
    ParseLayer = Left$(strInitialVal, intPos - 1)
    strInitialVal = Mid$(strInitialVal, intPos + 1)
  End If
End Function

Создание базы данных с информацией о слоях

Эта процедура создает базу данных mdb в папке текущего файла и с именем текущего файла. Созданная база данных состоит из одной таблицы, в которой содержится информация обо всех слоях текущего чертежа.

Вставте процедуру CreateLayerDB в стандартный модуль и не забудьте сделать ссылку на библиотеку Microsoft DAO 3.51 Object Library

Option Explicit

Sub CreateLayerDB()
    Dim objDB As DAO.Database
    Dim objTbl As DAO.TableDef
    Dim objFld As DAO.Field
    Dim objRecSet As DAO.recordset
    Dim objLayer As AcadLayer
    Dim objLayers As AcadLayers
    Dim strDBName As String
    'This is a fast path builder for the database, you can just  hard
    'code it or
    'Use a dialog to get the path and name.
    Set objLayers = ThisDrawing.Layers
    strDBName = Mid(ThisDrawing.FullName, 1, _
    Len(ThisDrawing.FullName) - 3) & "mdb"
    Set objDB = DBEngine(0).CreateDatabase(strDBName, dbLangGeneral)
    'Now we add the table and fields
    With objDB
        Set objTbl = .CreateTableDef("Layers")
        With objTbl
            Set objFld = .CreateField("LName", dbText)
            .Fields.Append objFld
            Set objFld = .CreateField("LColor", dbText)
            .Fields.Append objFld
            Set objFld = .CreateField("LType", dbText)
            .Fields.Append objFld
        End With
        .TableDefs.Append objTbl
        'Open the table
        Set objRecSet = .OpenRecordset("Layers")
        With objRecSet
            'Add the layer info
            For Each objLayer In objLayers
                .AddNew
                !LName = objLayer.Name
                !LColor = objLayer.Color
                !LType = objLayer.Linetype
                .Update
            Next objLayer
        End With
        'Close shop
        objRecSet.Close
    End With
End Sub

Изменение имени слоев чертежа

Функция, заменяющая заданный префикс имени всех слоев чертежа на другой. Префикс должен быть отделен от основного имени знаком “-”
Создайте в чертеже несколько слоев, имя которых начинается с ADR-, например, ADR-LName (вместо LName можно использовать любое имя), и запустите процедуру TEST_ChangeLayerPrefix. При этом в имени всех слоев перфикс ADR будет заменен на HRV

Public Sub Test_ChangeLayerPrefix ()
  ChangeLayerPrefix "ADR", "HRV"
End Sub
 
Function ChangeLayerPrefix(OldPrefix As String, NewPrefix As String)
  Dim oLayer As AcadLayer
  For Each oLayer In ThisDrawing.Layers
    If UCase(Left(oLayer.Name, Len(OldPrefix))) = UCase(OldPrefix) Then
      oLayer.Name = NewPrefix & ParseString(oLayer.Name, 1, "-")
    End If
  Next
End Function
 
Private Function ParseString(strIn As String, intLoc As Integer,_
strDelimiter As String) As String
  Dim intPos As Integer
  Dim intStrt As Integer
  Dim intStop As Integer
  Dim intCnt As Integer
  intCnt = intLoc
  Do While intCnt > 0
    intStop = intPos
    intStrt = InStr(intPos + 1, strIn, Left$(strDelimiter, 1))
    If intStrt > 0 Then
      intPos = intStrt
      intCnt = intCnt - 1
    Else
      intPos = Len(strIn) + 1
      Exit Do
    End If
  Loop
  ParseString = Mid$(strIn, intStrt)
End Function 

Удаление всех объектов с заданного слоя

Option Explicit
 
Public Sub DelAllOnLayer()
  Dim obj As AcadEntity
  Dim currentlay As AcadLayer
  Dim objlayer As AcadLayer
  Dim strlayername As String
  Dim objAllSets As AcadSelectionSets
  Dim objSelSet As AcadSelectionSet
  Dim intType(0) As Integer
  Dim varData(0) As Variant

  strlayername = "bub-tx"
  For Each objlayer In ThisDrawing.Layers
    If 0 = StrComp(objlayer.Name, strlayername, vbTextCompare) Then
      Set objAllSets = ThisDrawing.SelectionSets
      For Each objSelSet In objAllSets
        If objSelSet.Name = "laydel" Then
          objSelSet.Delete
          Exit For
        End If
      Next objSelSet
      Set objSelSet = objAllSets.Add("laydel")
      strlayername = "bub-tx"
      intType(0) = 8
      varData(0) = strlayername
      objSelSet.Select acSelectionSetAll, _
      filtertype:=intType, filterdata:=varData
      objSelSet.Erase
      Exit For
    End If
  Next objlayer
  Set objlayer = ThisDrawing.Layers.Add(strlayername)
  ThisDrawing.ActiveLayer = objlayer
End Sub

Сортировка примитивов чертежа по типам линий на разные слои

После запуска TEST_LayersFromLineTypes будут просмотрена информация о типе линии всех примитивов текущего чертежа. Будут созданы слои, с именами, совпадающими с именами используемых типов линий. Все примитивы чертежа будут перемещены на соответствующие их типу линии слои.

'BEGIN CODE BLOCK
Option Explicit

Option Compare Text

'The above line means that
'Case is ignored ("A" = "a")



'The procedure that runs the show
Public Sub TEST_LayersFromLineTypes()
  If LayersFromLineTypes(ThisDrawing) Then
    MsgBox SetObjLayers & " Entities adjusted"
  End If
End Sub

 

'@~~~~~ Create the new layers ~~~~~~~~~~@
' Use all of the loaded line types to
' Create new layers using the Line type's
' Name property
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function LayersFromLineTypes(objDwg As AcadDocument) As Boolean
  Dim objLayer As AcadLayer
  Dim objLayers As AcadLayers
  Dim objLineType As AcadLineType
  Dim objLineTypes As AcadLineTypes
  Dim strLineType As String
  Dim blnExists As Boolean
  On Error GoTo Err_Control
  Set objLineTypes = objDwg.Linetypes
  Set objLayers = objDwg.Layers
  For Each objLineType In objLineTypes
    strLineType = objLineType.Name
    For Each objLayer In objLayers
      If objLayer.Name = strLineType Then
        blnExists = True
        Exit For
      End If
    Next objLayer
    If Not blnExists Then
      'Not sure what you wanted to do with
      'Bylayer and ByBlock, so I left them
      'In - this means that any entity with
      'The line type bylayer or byblock will be
      'moved to these new layers (bylayer & byblock)
      Set objLayer = objLayers.Add(strLineType)
      objLayer.Linetype = strLineType
      Select Case objLayer.Name
        Case "Hidden"
          objLayer.Color = acRed
        Case "Continuous"
          objLayer.Color = acBlue
        Case "Center"
          objLayer.Color = acCyan
        Case "Phantom"
          objLayer.Color = acYellow
        'Add the rest of your color settings here
        'Using the same format
      End Select
      Set objLayer = Nothing
    Else
      blnExists = False
    End If
  Next objLineType
  LayersFromLineTypes = True
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function
 
'@~~~~~~~~~~ move the objects ~~~~~~~~~~~@
' Check the entities line type and move it
' To the correct layer
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function SetObjLayers() As Integer
  Dim objEnt As AcadEntity
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim intCnt As Integer
  On Error GoTo Err_Control
  'Set up a new selection set of all entities
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = "objectlayers" Then
        objSelSet.Delete
        Exit For
      End If
    Next
  Set objSelSet = ThisDrawing.SelectionSets.Add("objectlayers")
  objSelSet.Select acSelectionSetAll
  'Now find everything on layer "0" and move it!
  For Each objEnt In objSelSet
    If objEnt.Layer = "0" Then
      objEnt.Layer = objEnt.Linetype
      'count how many
      intCnt = intCnt + 1
    End If
  Next objEnt
  'return count
  SetObjLayers = intCnt
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function
'END CODE BLOCK

Управление активностью слоя

После запуска TEST_CanBeActive у пользователя запрашивается имя слоя. Если такой слой в чертеже есть, и, если он может стать активным (если он не заморожен и не отключен), то функция CanBeActive делает этот слой текущим

'BEGIN CODE BLOCK
Option Explicit

Function CanBeActive(strLayer As String) As Boolean
    Dim oLayers As AcadLayers
    Dim oLayer As AcadLayer
    
    On Error GoTo Err_Control
    
    ' Проверяем состояние слоя с заданным именем
    Set oLayers = ThisDrawing.Layers
    Set oLayer = oLayers.Item(strLayer)
    If oLayer.Freeze = True Or oLayer.Lock = True _
    Or oLayer.LayerOn = False Then
     CanBeActive = False
    Else
      CanBeActive = True
    End If
Exit_Here:
    Exit Function
Err_Control:
    Debug.Print Err.Description
    Resume Exit_Here
End Function

Public Sub TEST_CanBeActive()
  Dim sLayer As String
  
  sLayer = InputBox("Layer name")
  If CanBeActive(sLayer) Then
    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(sLayer)
  End If
End Sub
'END CODE BLOCK

Пример диалогового окна с информацией о слоях

Создайте диалоговое окно, в которое поместите 3 КомбоБокса и 1 метку как на рисунке:

И поместите в модуль формы следующий код:

'BEGIN CODE BLOCK
Option Explicit

Private varLayerInfo() As Variant

Private Sub UserForm_Initialize()
  Dim intCnt As Integer
  Dim oLayers As AcadLayers
  
  Set oLayers = ThisDrawing.Layers
  ReDim varLayerInfo(oLayers.Count - 1, 3)
  For intCnt = 0 To oLayers.Count - 1
    varLayerInfo(intCnt, 0) = oLayers(intCnt).Name
    varLayerInfo(intCnt, 1) = oLayers(intCnt).Color
    varLayerInfo(intCnt, 2) = oLayers(intCnt).Linetype
    varLayerInfo(intCnt, 3) = oLayers(intCnt).Freeze
  Next intCnt
  ComboBox1.BoundColumn = 2
  ComboBox2.BoundColumn = 3
  ComboBox3.BoundColumn = 4
  ComboBox1.List = varLayerInfo
  ComboBox2.List = varLayerInfo
  ComboBox3.List = varLayerInfo
  Label1.Caption = "Pick-A-Box"
End Sub

Private Sub ComboBox1_Change()
  If ComboBox1.ListIndex > -1 Then
    Label1.Caption = "Color = " & ComboBox1.Value
  End If
End Sub

Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  Label1.Caption = ""
  ComboBox1.ListIndex = -1
End Sub

Private Sub ComboBox2_Change()
  If ComboBox2.ListIndex > -1 Then
    Label1.Caption = "Line type = " & ComboBox2.Value
  End If
End Sub

Private Sub ComboBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  Label1.Caption = ""
  ComboBox2.ListIndex = -1
End Sub

Private Sub ComboBox3_Change()
  If ComboBox3.ListIndex > -1 Then
    If ComboBox3.Value = True Then
      Label1.Caption = "Layer is Frozen"
    Else
      Label1.Caption = "Layer is Thawed"
    End If
  End If
End Sub

Private Sub ComboBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  Label1.Caption = ""
  ComboBox3.ListIndex = -1
End Sub
'END CODE BLOCK

Теперь поместите в стандартный код следующую ниже процедуру. После запуска процедуры TEST_LayNfoForm будет отображено диалоговое окно, в котором при выборе имени слоя в одном из комбобоксов в нижней строке формы будет отображена соответствующая информация.

'BEGIN CODE BLOCK
Sub TEST_LayNfoForm()
    UserForm1.Show
End Sub
'END CODE BLOCK
 

Процедура для заполнения списка наименованиями слоев

 'BEGIN CODE BLOCK
Public Sub NumericLayers(objList As ListBox)
  Dim intVal As Integer
  Dim objLayer As AcadLayer
  Dim objAllLayers As AcadLayers
  Set objAllLayers = ThisDrawing.Layers
  For Each objLayer In objAllLayers
    intVal = Val(objLayer.Name)
    If intVal > 0 Then
      objList.AddItem objLayer.Name
    End If
  Next objLayer
End Sub
'END CODE BLOCK
  

Заморозка всех слоев чертежа кроме последнего

Пороцедура делает все слои чертежа, кроме того, который был добавлен последним, замороженными. Последний добавленный в чертеж слой становится текущим

'BEGIN CODE BLOCK
Public Sub FreezeCycle()
  Dim objLayer As AcadLayer
  Dim objActiveLayer As AcadLayer
  Dim objAll As AcadLayers
  Set objAll = ThisDrawing.Layers
  For Each objLayer In objAll
  Set objActiveLayer = ThisDrawing.ActiveLayer
    If Not objLayer.Name = objActiveLayer.Name Then
      If objLayer.Freeze Then
        objLayer.Freeze = False
      End If
      ThisDrawing.ActiveLayer = objLayer
      objActiveLayer.Freeze = True
    End If
  Next objLayer
End Sub
'END CODE BLOCK
   

Защита от изменений всех слоев всех вставленных в чертеж внешних ссылок

'BEGIN CODE BLOCK
Public Sub LockXrefLayers()
  Dim objlayer As AcadLayer
  Dim objLayers As AcadLayers
  Dim objXref As AcadExternalReference
  Dim objBlk As AcadBlock

  On Error GoTo Err_Control
  For Each objBlk In ThisDrawing.Blocks
  If objBlk.IsXRef Then
    Set objLayers = objBlk.XRefDatabase.Layers
    For Each objlayer In objLayers
      objlayer.Lock = True
    Next objlayer
  End If
  Next objBlk
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
'END CODE BLOCK
   

Типы линий

Примеры из других разделов:

Проверка наличия в чертеже типа линии с заданным именем

Стили текста

Создание текстового стиля на основании текстового файла

Для использования этой процедуры необходимо добавить класс FileDialog со страницы http://vbdesign.hypermart.net/cadpages/filedialog.htm

'BEGIN CODE BLOCK
Option Explicit

'@----------------------------------------------------@
'@       Создание текстового стиля на основании       @
'@     информации, сохраненной  в текстовом файле     @
'@----------------------------------------------------@
Public Sub CreateTxtStyles()
  Dim objDialog As New FileDialog
  Dim objStyles As AcadTextStyles
  Dim objStyle As AcadTextStyle
  Dim strStyleName As String
  Dim strFile As String
  Dim strFlag(1) As String
  Dim strVal As String
  Dim intFile As Integer
  Dim dblOblique As Double
  On Error GoTo Err_Control
  objDialog.Title = "AutoCAD Style Files"
  objDialog.Filter = "Text Style (*.ats)|*.ats"
  strFile = objDialog.ShowOpen
  If Len(strFile) > 0 Then
    intFile = FreeFile
    Set objStyles = ThisDrawing.TextStyles
    Open strFile For Input As intFile
    Do Until EOF(intFile)
      Line Input #intFile, strVal
      strStyleName = GetWord(strVal, 1)
      Set objStyle = objStyles.Add(strStyleName)
      objStyle.fontFile = GetWord(strVal, 2)
      objStyle.Height = CDbl(GetWord(strVal, 3))
      objStyle.Width = CDbl(GetWord(strVal, 4))
      'Convert degrees to radians..
      dblOblique = CDbl(GetWord(strVal, 5))
      dblOblique = dblOblique / 180 * (Atn(1) * 4)
      objStyle.ObliqueAngle = dblOblique
      strFlag(0) = GetWord(strVal, 6)
      strFlag(1) = GetWord(strVal, 7)
      'If you change "n" to 0 and "y" to 1
      'The structure could be like this
      'If CBool(strFlag(0)) Then
      If strFlag(0) = "n" Then
        If strFlag(1) = "y" Then
          objStyle.TextGenerationFlag = 2
        End If
      Else
        If strFlag(1) = "y" Then
          objStyle.TextGenerationFlag = 6
        Else
          objStyle.TextGenerationFlag = 4
        End If
      End If
      'Notice No Vertical...
    Loop
    Set objStyles = Nothing
    Set objStyle = Nothing
    Set objDialog = Nothing
    Close intFile
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
'@~~~~~~~~~~~~~~ GetWord ~~~~~~~~~~~~~~~~~@
' Return a Whole word from a string using
' It location in the string based on a Count
' Of spaces in the string (companion to Count
' Words)
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Function GetWord(strText, intLoc As Integer) As String
  Dim intCnt As Integer
  Dim intWordCnt As Integer
  Dim Count As Integer
  Dim intStrtPos As Integer
  Dim intEndPos As Integer
  Dim blnSpace As Integer
  Count = 0
  blnSpace = True
  For intCnt = 1 To Len(strText)
    If Mid(strText, intCnt, 1) = " " Then
      blnSpace = True
    Else
      If blnSpace Then
        blnSpace = False
        Count = Count + 1
        If Count = intLoc Then
          intStrtPos = intCnt
          Exit For
        End If
      End If
    End If
  Next intCnt
  intEndPos = InStr(intStrtPos, strText, " ") - 1
  If intEndPos <= 0 Then intEndPos = Len(strText)
  GetWord = Mid(strText, intStrtPos, _
  intEndPos - intStrtPos + 1)
End Function
'END CODE BLOCK
   

Системные переменные

Определение значения системной переменной

'BEGIN CODE BLOCK
'@----------------------------------------------------@
'@ Определение значения системной переменной  LTSCALE @
'@----------------------------------------------------@
Public Function GetLTScale() As Double
  GetLTScale = CDbl(ThisDrawing.GetVariable("LTSCALE"))
End Function
'END CODE BLOCK
   

Задание значения системной переменной

'BEGIN CODE BLOCK
'@----------------------------------------------------@
'@   Задание значения системной переменной  LTSCALE   @
'@----------------------------------------------------@
Public Function SetLTScale(dblNew As Double) As Boolean
  On Error Resume Next
  ThisDrawing.SetVariable "LTSCALE", dblNew
  SetLTScale = (Err.Number = 0)
End Function
'END CODE BLOCK

Точки

Копирование координат точки в буфер обмена

'BEGIN CODE BLOCK
'@----------------------------------------------------@
'@     Копирование координат точки в буфер обмена     @
'@----------------------------------------------------@
Public Sub PointOnClipboard()
  Dim objClip As New DataObject
  Dim objUtil As AcadUtility
  Dim varPnt As Variant
  Dim strPrmt As String
  Dim strPnt As String
  Set objUtil = ThisDrawing.Utility
  strPrmt = "Point to place on clipboard: "
  varPnt = objUtil.GetPoint(Prompt:=strPrmt)
  strPnt = varPnt(0) & "," & varPnt(1)
  'Don't want the Z? Comment next line out
  strPnt = strPnt & "," & varPnt(2)
  objClip.SetText strPnt
  objClip.PutInClipboard
End Sub

' Еще один пример с "Работой над ошибками"
Public Sub PointOnClipboard()
  Dim objClip As New DataObject
  Dim objUtil As AcadUtility
  Dim varPnt As Variant
  Dim strPrmt As String
  Dim strPnt As String
  Dim varErr As Variant
  On Error GoTo Err_Control
  Set objUtil = ThisDrawing.Utility
  strPrmt = "Point to place on clipboard: "
  varPnt = objUtil.GetPoint(Prompt:=strPrmt)
  strPnt = Format(varPnt(0), "0.00") & "," _
  & Format(varPnt(1), "0.00")
  'Don't want the Z? Comment next line out
  strPnt = strPnt & "," & Format(varPnt(2), "0.00")
  objClip.SetText strPnt
  objClip.PutInClipboard
Exit_Here:
  Exit Sub
Err_Control:
  varErr = ThisDrawing.GetVariable("LASTPROMPT")
  If InStr(1, varErr, "*Cancel*") <> 0 Then
    Err.Clear
    Resume Exit_Here
  Else
    MsgBox Err.Description
    Resume Exit_Here
  End If
End Sub
'END CODE BLOCK
   

Системы координат

Перевод координат из WCS в UCS

'BEGIN CODE BLOCK
'@----------------------------------------------------@
'@           Перевод координат из WCS в UCS           @
'@----------------------------------------------------@
Public Sub CS_Trans()
  '///NEW
  Dim varStartPntTranslated As Variant
  Dim varEndPntTranslated As Variant
  '///End
  Dim Ent As AcadEntity
  Dim myent As Variant
  Dim Start_Point As Variant
  Dim End_Point As Variant
  Dim XStartPoint As Double
  Dim XEndPoint As Double
  Dim YStartPoint As Double
  Dim YEndPoint As Double
  Dim Xcheck As Double
  Dim Ycheck As Double
  Dim doc As Object
  Dim mycount As Integer
  Dim objss As Object
  Dim objSelCol As Object
  mycount = 0
  Set objSelCol = ThisDrawing.SelectionSets
  For Each objss In objSelCol
    If objss.Name = "Mysel" Then
      objss.Delete
      Exit For
    End If
  Next
  Set objss = objSelCol.Add("Mysel")
  objss.SelectOnScreen
  mycount = 0
  If objss.Count > 0 Then
    For Each Ent In objss
      If Ent.EntityName = "AcDbLine" Then
        Start_Point = Ent.StartPoint
        End_Point = Ent.EndPoint
        '///Translations Begin
        varStartPntTranslated = _
        ThisDrawing.Utility.TranslateCoordinates(Start_Point, _
        acWorld, acUCS, False)
        varEndPntTranslated = _
        ThisDrawing.Utility.TranslateCoordinates(End_Point, _
        acWorld, acUCS, False)
        '///Translation Ends
        XStartPoint = Start_Point(0)
        Debug.Print "Old: " & XStartPoint
        '///Now switch
        XStartPoint = varStartPntTranslated(0)
        Debug.Print "New: " & XStartPoint
        YStartPoint = Start_Point(1)
        Debug.Print "Old: " & YStartPoint
        '///Now switch
        YStartPoint = varStartPntTranslated(1)
        Debug.Print "New: " & YStartPoint
        XEndPoint = End_Point(0)
        Debug.Print "Old: " & XEndPoint
        '///Now switch
        XEndPoint = varEndPntTranslated(0)
        Debug.Print "New: " & XEndPoint
        YEndPoint = End_Point(1)
        Debug.Print "Old: " & YEndPoint
        '///Now switch
        YEndPoint = varEndPntTranslated(1)
        Debug.Print "New: " & XEndPoint
      End If
    Next Ent
  End If
End Sub
'END CODE BLOCK
   

Пространства Модели и Листа

Примеры из других разделов:

Определение текущего пространства

Создание копии пространства листа (Layouts)

'BEGIN CODE BLOCK
'@----------------------------------------------------@
'@    Создание копии пространства листа (Layouts)     @
'@----------------------------------------------------@
Public Sub LayOutsample(strFrom As String, strTo As String)
  Dim objLayOut As AcadLayout
  'Make sure you use AcadObject
  'So we get the VP!
  Dim objEnt As AcadObject
  Dim objNewLayOut As AcadLayout
  Dim colLayOuts As AcadLayouts
  Dim objEntArray() As Object
  Dim intCnt As Integer
  Dim blnExists As Boolean
  Set colLayOuts = ThisDrawing.Layouts
  For Each objLayOut In colLayOuts
    If objLayOut.Name = "VBD LayOut" Then
      blnExists = True
      Exit For
    End If
  Next objLayOut
  If Not blnExists Then
    Set objNewLayOut = colLayOuts.Add(strTo)
    Set objLayOut = colLayOuts.Item(strFrom)
    'The Block property is the block object
    'Associated with the layout, so get it's
    'Item count and redim the object array.
    ReDim objEntArray(objLayOut.Block.Count - 1)
    For Each objEnt In objLayOut.Block
      Set objEntArray(intCnt) = objEnt
      intCnt = intCnt + 1
    Next
    ThisDrawing.CopyObjects objEntArray, objNewLayOut.Block
    objNewLayOut.CopyFrom objLayOut
  End If
End Sub
 
Public Sub Test_LayOutsample()
  LayOutsample "Layout1", "VBA Test"
End Sub
'END CODE BLOCK
   



Copyright © Сайт поддержки пользователей САПР by Victor Tkachenko