• На форуме с 12 апреля 2007г.
  • Сообщений: 47
  • Спасибо: 0

Тема: DXF-код для угла наклона элемента TEXT

Добрый день.

Задача: выбрать на чертеже все элементы ТЕКСТ, у которых угол наклона не равен нулю.

Пишу:

FilterType3(0) = 0
FilterData3(0) = "TEXT"
FilterType3(1) = 7
FilterData3(1) = "SN"
FilterType3(2) = 51
FilterData3(2) = <значение угла>
...
TextSet.Select acSelectionSetAll, , , FilterType3, FilterData3

Выбирает все элементы (не только текст) на чертеже. А по идее должен выбрать только текст с заданным углом наклона. Подскажите пожалуйста DXF-код угла наклона.

  • На форуме с 5 февраля 2008г.
  • Сообщений: 37
  • Спасибо: 1

Re: DXF-код для угла наклона элемента TEXT

Option Explicit

Public Sub SelectNotHorText()
'Процедура выбора примитивов TEXT стиль SN с углом поворота не равным нулю
Dim FilterType(0 To 3) As Integer
Dim FilterData(0 To 3) As Variant
Dim ss As AcadSelectionSet

'Тип объекта
FilterType(0) = 0
FilterData(0) = "TEXT"
'Текстовый стиль
FilterType(1) = 7
FilterData(1) = "SN"
'Поворот <> 0
FilterType(2) = -4
FilterData(2) = "/="
FilterType(3) = 50
FilterData(3) = 0#
'Создаем 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
'Число выбранных объектов
Debug.Print "Найдено примитивов: " & ss.count
MsgBox "Найдено примитивов: " & ss.count, vbInformation, "SelectNotHorText"

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

  • На форуме с 12 апреля 2007г.
  • Сообщений: 47
  • Спасибо: 0

Re: DXF-код для угла наклона элемента TEXT

Большое спасибо, работает.

Задача несколько изменилась, теперь нужно, чтобы выбирал элементы текста с углами в заданном интервале. Например, 30<угол<45.

Пишу:

FilterType3(0) = 0
FilterData3(0) = "TEXT"
FilterType3(1) = 7
FilterData3(1) = "SN"
FilterType3(2) = -4
FilterData3(2) = "<"
FilterType3(3) = 50
FilterData3(3) = angle1
FilterType3(4) = -4
FilterData3(4) = ">"
FilterType3(5) = 50
FilterData3(5) = angle2

Снова выводит все элементы (не только текстовые). Если задаю фильтр с целью выводить только больше заданного угла, выбирает все текстовые элементы.

  • На форуме с 12 апреля 2007г.
  • Сообщений: 47
  • Спасибо: 0

Re: DXF-код для угла наклона элемента TEXT

Разобралась, все работает как нужно.
Все таки нужно ставить 51 - угол наклона. 50 - угол поворота.

Еще раз большое спасибо!

  • На форуме с 5 февраля 2008г.
  • Сообщений: 37
  • Спасибо: 1

Re: DXF-код для угла наклона элемента TEXT

> airiz
Прошу прощения, невнимательно прочитал ваш первый пост и перепутал угол поворота с углом наклона

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