Настройки поиска (Страница 1 из 2)

Public Sub SelectObliqueAngleText()
'Процедура выбора примитивов TEXT стиль SN с углом НАКЛОНА в заданном интервале (30 < ObliqueAngle  < 45)
'Важно: из-за ошибок округления (усечения) при работе с действительными числами
'для граничных значений угла результат работы функции может быть ошибочным.
'Для исключения этих ошибок введена постоянная eps
Const pi = 3.141592654
Const eps = 0.000000001
Dim FilterType(0 To 7) As Integer
Dim FilterData(0 To 7) As Variant
Dim ss As AcadSelectionSet
Dim MinAngle As Double
Dim MaxAngle As Double

'Углы в радианах
MinAngle = 30 * pi / 180 + eps
MaxAngle = 45 * pi / 180 - eps
'Тип объекта
FilterType(0) = 0
FilterData(0) = "TEXT"

'MinAngle< НАКЛОН <MaxAngle
FilterType(1) = -4
FilterData(1) = "<AND"

    FilterType(2) = -4
    FilterData(2) = ">"
    FilterType(3) = 51
    FilterData(3) = MinAngle
    
    FilterType(4) = -4
    FilterData(4) = "<"
    FilterType(5) = 51
    FilterData(5) = MaxAngle

FilterType(6) = -4
FilterData(6) = "AND>"
'Текстовый стиль
FilterType(7) = 7
FilterData(7) = "SN"
'Создаем SelectionSet
On Error Resume Next
    ThisDrawing.SelectionSets.Item("RText").Delete
    Set ss = ThisDrawing.SelectionSets.Add("RText")
    Err.Clear
On Error GoTo 0
'Выбираем объекты на экране
ss.Select acSelectionSetAll, , , FilterType, FilterData
'ss.SelectOnScreen FilterType, FilterData
'Подсвечиваем объекты
Dim obj As AcadEntity
For Each obj In ss
    obj.Highlight True
Next obj
'Число выбранных объектов
Debug.Print "Найдено примитивов: " & ss.count
MsgBox "Найдено примитивов: " & ss.count, vbInformation, "SelectNotHorText"

'Удаляем набор
On Error Resume Next
    ss.Delete
    Err.Clear
On Error GoTo 0
End Sub

acColorMethodByACI
acColorMethodByBlock
acColorMethodByLayer
acColorMethodByRGB
acColorMethodForeground

'ФУНКЦИЯ ПРОВЕРКИ, ЗАГРУЖЕНА ЛИ ОПРЕДЕЛЕННАЯ ГРУППА МЕНЮ
Private Function MenuGroupExist(MenuName As String) As Boolean
Dim MenuGroup As AcadMenuGroup
MenuGroupExist = False
MenuName = UCase(MenuName)
For Each MenuGroup In Application.MenuGroups
    If MenuGroup.Name = MenuName Then
        MenuGroupExist = True
        Exit Function
    End If
Next
End Function

'ФУНКЦИЯ ЗАГРУЗКИ ГРУППЫ МЕНЮ
Private Function AddMenuGroup(MenuName As String, MenuFileName As String) As Long
'MenuName - имя группы меню
'MenuFileName - полный путь файла группы меню (.cui файл)
'Результат:
'AddMenuGroup = -1 - не удалось загрузить файл частичной адаптации
'AddMenuGroup =  0 - файл частичной адаптации уже загружен
'AddMenuGroup =  1 - удачная загрузка файла частичной адаптации

Dim MenuGroupObject As AcadMenuGroup
If MenuGroupExist(MenuName) Then
    AddMenuGroup = 0
Else
    On Error Resume Next
    Set MenuGroupObject = Application.MenuGroups.Load(MenuFileName, False)
    If Err.Number = 0 Then AddMenuGroup = 1 Else AddMenuGroup = -1
    On Error GoTo 0
End If
End Function

'ФУНКЦИЯ ВЫГРУЗКИ ГРУППЫ МЕНЮ
Private Function DelMenuGroup(MenuName As String) As Long
'MenuName - имя группы меню
'Результат:
'DelMenuGroup = -1 - не удалось выгрузить файл частичной адаптации
'DelMenuGroup =  0 - файл частичной адаптации незагружен
'DelMenuGroup =  1 - удачная выгрузка файла частичной адаптации
Dim MenuGroupObject As AcadMenuGroup
If MenuGroupExist(MenuName) Then
    On Error Resume Next
    Application.MenuGroups.Item(MenuName).Unload
    If Err.Number <> 0 Then
        DelMenuGroup = -1
        Exit Function
    End If
    On Error GoTo 0
    DelMenuGroup = 1
Else
    DelMenuGroup = 0
End If
End Function

'ФУНКЦИЯ ПРОВЕРКИ, ВХОДИТ ЛИ КАТАЛОГ В SupportPath
Private Function SupportPathExist(SuppPath As String) As Boolean
Dim FullSupportPath As String
Dim OnePath As String
Dim Ch As String
Dim i As Long
'Строка .SupportPath содержит пути файлов разделенных символом ";"
'в конце строки символ ";" отсутствует (см Help), поэтому добавим его сами
'и получим строку, значения в которой разделены символом ";"
FullSupportPath = Application.Preferences.Files.SupportPath + ";"

For i = 1 To Len(FullSupportPath)
    Ch = mid(FullSupportPath, i, 1)
    If Ch <> ";" Then
        OnePath = OnePath + Ch
    Else
        If OnePath = SuppPath Then
            SupportPathExist = True
            Exit Function
        End If
        OnePath = ""
    End If
Next i
SupportPathExist = False
End Function

'ФУНКЦИЯ ДОБАВЛЕНИЯ КАТАЛОГА В SupportPath
Private Function AddSupportPath(SuppPath As String) As Long
'=-1 не удалось добавить путь в SupportPath
'=1 путь добавлен в SupportPath
'=0 путь уже содержится в SupportPath

If SupportPathExist(SuppPath) Then
    AddSupportPath = 0
    Exit Function
Else
    On Error Resume Next
    Application.Preferences.Files.SupportPath = Application.Preferences.Files.SupportPath + ";" + SuppPath
    If Err.Number <> 0 Then AddSupportPath = -1 Else AddSupportPath = 1
    On Error GoTo 0
End If
End Function

'ФУНКЦИЯ УДАЛЕНИЯ КАТАЛОГА ИЗ SupportPath
Private Function DelSupportPath(SuppPath As String) As Long
'=-1 не удалось удалить путь из SupportPath
'=1 путь удален из SupportPath
'=0 путь не содержится в SupportPath
Dim FullSupportPath As String
If SupportPathExist(SuppPath) Then
    FullSupportPath = Application.Preferences.Files.SupportPath + ";"
    FullSupportPath = Replace(FullSupportPath, SuppPath + ";", "")
    On Error Resume Next
    Application.Preferences.Files.SupportPath = mid(FullSupportPath, 1, Len(FullSupportPath) - 1)
    If Err.Number <> 0 Then
        DelSupportPath = -1
        Exit Function
    End If
    On Error GoTo 0
    DelSupportPath = 1
Else
    DelSupportPath = 0
End If
End Function

Public Sub testAdd()
Dim newODwg As AcadDocument
Dim TemplatePath As String
'Путь к файлу,который будет открыт в случае SDI<>0
TemplatePath = "D:\Рабочая\NewDoc.dwg"

On Error Resume Next
    Set newODwg = Application.Documents.Add()
    If newODwg Is Nothing Then 'SDI<>0
        Set newODwg = ThisDrawing.Open(TemplatePath) '!Текущий рисунок при этом будет закрыт без предупреждения о сохранении изменений
    End If
    
    If newODwg Is Nothing Then
        MsgBox "Не удалось создать новый документ" + vbCr + "Дальнейшая работа невозможна"
        Exit Sub
    End If
On Error GoTo 0
end sub