Оптимизация работы с Flatshot

Оптимизация работы с Flatshot · 25.02.2007, 03:32

Введение: После создания модели конструкции в 3D, для получения какого-либо вида жму на Flatshot, в настройках которого указываю Foreground lines (Color: By Layer; Linetype: Continuous) и Obscured lines (Color: By Layer; Linetype: ISO Dash). Слои "Сплошная толстая основная" и "Штриховая" уже существуют.

Здесь есть следующие проблемы:
1. Типы линий указаны явно;
2. Толщины всех линий то же явно - 0.00 mm.
3. Каким образом Flatshot выбирает базовую точку непонятно.

Что нужно: Нужна кнопка (макрос, ЛИСП или ещё что-то, но для пользователя - это одна кнопка), пользователь выполняет следующую последовательность действий:
1. Жмёт Кнопку;
2. Выбирает блок созданный при помощи Flatshot;
3. Выбирает базовую точка;
4. Без дополнительного подтверждения команда завершается.

Что происходит: В выбранном блоке все линии со свойством Linetype: Continuous попадают в слой "Сплошная толстая основная", а со свойством Linetype: ISO Dash в слой "Штриховая". Причём свойство Linetype и Lineweight автоматически изменяется на By Layer. В блоке начало координат 0.0 становится там, где пользователь указал базовую точку.

Заранее спасибо.

Profan · 25.02.2007, 08:57

Что такое Flatshot?

Чигинский Дмитрий · 26.02.2007, 19:45

Flatshot - это новая команда (инструмент), появившийся в AutoCAD 2007. Суть его заключается в том, что рядом с 3D-моделью создаётся блок, включающий как видимые, так и скрытые контуры модели. То есть этот инструмент, я использую для создания видов, разрезов и сечений с 3D-модели.

Не смотря на то, что Autodesk рекомендует использовать для выше описанных целей SOLPROF (см. help), я остаюсь при своём мнении.

По сути задача (тема), как таковая, не связана с Flatshot. По прежнему жду помощи...

Чигинский Дмитрий · 03.03.2007, 11:46

Подскажите пожалуйста, что я непонятно объясняю или в чём сложность в вопросе?

Если просто описать проблему, то имеем следующее:
Есть блок с "примитивными" примитивами - простые линии, окружности, дуги, нет полилиний. Свойства объектов в блоке следующие: Цвет - По слою, толщина линий - 0.01 мм, типы линий - сплошная и штриховая. Требуется команда по которой все объекты в блоке станут толщиной По слою, объекты с типом линий сплошная попадут в слой «Сплошная толстая основная» и с типом линий штриховая в слой «Штриховая», после этого тип линий тоже станет По слою. Слои на момент использования команды уже есть.

Как пожелание - возможность изменения в блоке базовой точки (точки в блоке с координатами 0, 0).

Заранее спасибо.

Чигинский Дмитрий · 03.03.2007, 14:55

Прилагаю файл сохранен в версии 2004. Команда должна работать в 2007, т.к. Flatshot появился только в 2007. Слева 2 box'a (3D-паралелипипеда), справа блок, созданный с помощью Flatshot. Нужные слои есть.
[ATTACH]1172922945.dwg[/ATTACH]

den001 · 03.03.2007, 16:14

Есть одно тонкое место: этот самый Flatshot предлагает выбрать тип линий для основных и для скрытых линий. Можно пойти двумя путями: жестко привязаться к типу линии "ACAD_ISO02W100" или считать скрытыми все линии, тип корорых не ПоСлою, ПоБлоку или Continuous. Второй вариант предпочтительнее.

vadim_evg1 · 03.03.2007, 17:10

Цитата:

Сообщение от Чигинский Дмитрий

Прилагаю файл сохранен в версии 2004. Команда должна работать в 2007, т.к. Flatshot появился только в 2007. Слева 2 box'a (3D-паралелипипеда), справа блок, созданный с помощью Flatshot. Нужные слои есть.
[ATTACH]1172922945.dwg[/ATTACH]

Не совсем понял что ты хочешь
Я использую команды solview и soldraw и не парюсь
Работаю в листе,модель использую ТОЛЬКО для 3D
[ATTACH]1172931052.dwg[/ATTACH]

den001 · 03.03.2007, 17:26

Вобщем, вот такая получилась вещь. Что касаемо изменения точки вставки - работает везде, кроме прилагаемого файла

. Вобщем, отлично работает, когда блок создан при идеальлных условиях: вид сверху и мировая СК. Если нет - глючит. От текущей ПСК не зависит. Почему такое дело - пока не понял.

Код:

[Выделить все]

Sub FlatshotTransform()
Dim Blk As AcadBlockReference, BlkSpace As AcadBlock, Entry As AcadEntity
Dim InsPnt As ACAD_POINT, NewInsPnt As ACAD_POINT

  LayName1 = "Сплошная толстая основная": LayName2 = "Штриховая"
  LineType1 = "CONTINUOUS": LineType2 = "ACAD_ISO02W100"
  
  On Error Resume Next
  Do
    Err.Clear:  GetAsyncKeyState vbKeyEscape:  ThisDrawing.RightClick = False
    ThisDrawing.Utility.GetEntity Blk, pnt, vbCrLf & "Выберите объект:"
    If Err.Number = 13 Then ThisDrawing.Utility.Prompt vbCrLf & "Требуется вхождение блока"
  Loop Until Err = 0 Or GetAsyncKeyState(vbKeyEscape) Or ThisDrawing.RightClick
  If Not Err = 0 Then Exit Sub
  
  Do
    Err.Clear: GetAsyncKeyState vbKeyEscape: ThisDrawing.RightClick = False
    NewInsPnt = ThisDrawing.Utility.GetPoint(, "Укажите новую точку вставки:")
  Loop Until Err = 0 Or GetAsyncKeyState(vbKeyEscape) Or ThisDrawing.RightClick
  If Not Err = 0 Then Exit Sub
'  NewInsPnt = ThisDrawing.Utility.TranslateCoordinates(NewInsPnt, acUCS, acWorld, 0)
  InsPnt = Blk.InsertionPoint
  Set BlkSpace = ThisDrawing.Blocks(Blk.Name)
  
  For Each Entry In BlkSpace
    Select Case UCase(Entry.Linetype)
    Case "BYLAYER", "BYBLOCK", LineType1
      Entry.Layer = LayName1
'    Case LineType2
    Case Else
      Entry.Layer = LayName2
    End Select
    Entry.Linetype = "BYLAYER"
    Entry.Lineweight = acLnWtByLayer
    Entry.Move NewInsPnt, InsPnt
  Next
  Blk.Move InsPnt, NewInsPnt
  Blk.Update
End Sub

P.S. Чтобы работала, поместите эту процедуру в модуль, где BlockReplace, там уже все, что нужно, прописано.

Никита В. · 03.03.2007, 18:32

>den001
А это че? Типа ВБА... :?

Чигинский Дмитрий · 03.03.2007, 19:11

den001, спасибо, действительно всё идеально, кроме установки базовой точки при виде кроме сверху. Интересно то, что при виде спереди перемещение базовой точки по горизонтали происходит правильно, а по вертикали перемещается весь блок.

По поводу:

Цитата:

Сообщение от den001

Есть одно тонкое место: этот самый Flatshot предлагает выбрать тип линий для основных и для скрытых линий. Можно пойти двумя путями: жестко привязаться к типу линии "ACAD_ISO02W100" или считать скрытыми все линии, тип которых не ПоСлою, ПоБлоку или Continuous. Второй вариант предпочтительнее.

Не смотря на то, что второй вариант действительно более общий, но в задаче этого не требуется и при желании в целях упрощения кода данное обобщение можно исключить.

Ещё у меня вопрос: Зачем в коде две закомментированные строки? При их включение программа работает совсем неправильно, но Вы их оставили, почему?

Спасибо за помощь, жду ответа…

vadim_evg1, это всё понятно, спасибо за участие.

Чигинский Дмитрий · 03.03.2007, 19:19

Никита В., хотя вопрос не мне, как автор темы позволю себе ответить. Да это VBA, а этот код надо вставлять в модуль программы Замена одного блока другим для AutoCAD 2006/2007.

den001 · 03.03.2007, 19:46

Чигинский Дмитрий
Закомментированы строки, потому что проще закомментировать, чем стирать, а потом писать заново.
Например, если снять комментарий с

Код:

[Выделить все]

Case LineType2

и закомментировать

Код:

[Выделить все]

Case Else

, то будут помещаться на слой "Штриховая" только линии "ACAD_ISO02W100", а при таком раскладе - все, что не ПоСлою, ПоБлоку, Continouos.

Что делать с точкой вставки надо еще подумать, довольно странное поведение.

Еще один момент.
Чтобы можно было запускать оную процедуру, как обычную автокадовскую команду, нужно загрузть в Акад такой код:

Код:

[Выделить все]

(defun c:FlatshotTransform()
  (command "vbarun" "FlatshotTransform")
  (while (/= (logand (getvar "cmdactive") 31) 0)
    (command pause)
  )
  (princ)
)

Добавить его можно в тот же RunBlockReplace.lsp, чтобы не плодить загружаемые файлы без нужды.

Чигинский Дмитрий · 03.03.2007, 20:03

Цитата:

Сообщение от den001

Закомментированы строки, потому что проще закомментировать, чем стирать, а потом писать заново.
Например, если снять комментарий с
Код:
Case LineType2
и закомментировать
Код:
Case Else
, то будут помещаться на слой "Штриховая" только линии "ACAD_ISO02W100", а при таком раскладе - все, что не ПоСлою, ПоБлоку, Continouos.

Цитата:

Сообщение от den001

Еще один момент. Добавить его можно в тот же RunBlockReplace.lsp, чтобы не плодить загружаемые файлы без нужды.

Именно так и сделал.

Цитата:

Сообщение от den001

Что делать с точкой вставки надо еще подумать, довольно странное поведение.

На сколько я понимаю, сейчас в программе изменение положения базовой точки в блоке происходит только по координатам X и Y глобальной системы координат, по координате Z - происходить перемещение всего блока.

Но с этим надо что-то делать...

А что происходит в другом комментарии, почему он закомментирован

Код:

[Выделить все]

NewInsPnt = ThisDrawing.Utility.TranslateCoordinates(NewInsPnt, acUCS, acWorld, 0)

den001 · 03.03.2007, 20:17

Код:

[Выделить все]

NewInsPnt = ThisDrawing.Utility.TranslateCoordinates(NewInsPnt, acUCS, acWorld, 0)

- это как раз следы попыток заставить точку вставки слушаться

Попозже вечерком проанализирую спокойно, может чего и получится. Самому интересно стало.

den001 · 03.03.2007, 23:01

Кажется, все. Проверяйте.

Код:

[Выделить все]

Sub FlatshotTransform()
Dim Blk As AcadBlockReference, BlkSpace As AcadBlock, Entry As AcadEntity
Dim InsPnt As ACAD_POINT, NewInsPnt0 As ACAD_POINT, NewInsPnt As ACAD_POINT

  LayName1 = "Сплошная толстая основная": LayName2 = "Штриховая"
  LineType1 = "CONTINUOUS": LineType2 = "ACAD_ISO02W100"
  
  On Error Resume Next
  Do
    Err.Clear:  GetAsyncKeyState vbKeyEscape:  ThisDrawing.RightClick = False
    ThisDrawing.Utility.GetEntity Blk, pnt, vbCrLf & "Выберите объект:"
    If Err.Number = 13 Then ThisDrawing.Utility.Prompt vbCrLf & "Требуется вхождение блока"
  Loop Until Err = 0 Or GetAsyncKeyState(vbKeyEscape) Or ThisDrawing.RightClick
  If Not Err = 0 Then Exit Sub
  
  Do
    Err.Clear: GetAsyncKeyState vbKeyEscape: ThisDrawing.RightClick = False
    NewInsPnt0 = ThisDrawing.Utility.GetPoint(, "Укажите новую точку вставки:")
  Loop Until Err = 0 Or GetAsyncKeyState(vbKeyEscape) Or ThisDrawing.RightClick
  If Not Err = 0 Then Exit Sub
  
  InsPnt = ThisDrawing.Utility.TranslateCoordinates(Blk.InsertionPoint, acWorld, acOCS, 0, Blk.Normal)
  NewInsPnt = ThisDrawing.Utility.TranslateCoordinates(NewInsPnt0, acWorld, acOCS, 0, Blk.Normal)
  
  Set BlkSpace = ThisDrawing.Blocks(Blk.Name)  
  For Each Entry In BlkSpace
    Select Case UCase(Entry.Linetype)
    Case "BYLAYER", "BYBLOCK", LineType1
      Entry.Layer = LayName1
    Case Else
      Entry.Layer = LayName2
    End Select
    Entry.Linetype = "BYLAYER"
    Entry.Lineweight = acLnWtByLayer
    Entry.Move NewInsPnt, InsPnt
  Next
  Blk.Move Blk.InsertionPoint, NewInsPnt0
  Blk.Update
End Sub

Дмитрий, с Вас стакан. Можно квасу

P.S. Так как программа узконаправленная, то защиту от нюансов, вроде блокированных/замороженных слоев и т.п. не делал

Чигинский Дмитрий · 04.03.2007, 03:28

den001, спасибо, всё отлично работает, по поводу защиты - пока не требуется. Ещё раз спасибо.

den001 · 04.03.2007, 09:20

Тем не менее сделал. Теперь годится для более широкого использования.

Код:

[Выделить все]

Sub FlatshotTransform()
Dim Blk As AcadBlockReference, BlkSpace As AcadBlock, Entry As AcadEntity
Dim InsPnt As ACAD_POINT, NewInsPnt0 As ACAD_POINT, NewInsPnt As ACAD_POINT
Dim LayObj As AcadLayer, LineTypeObj As AcadLineType
Dim Fnd1 As Boolean, Fnd2 As Boolean
Const LayName1 = "Сплошная толстая основная", LayName2 = "Штриховая"
Const LineType1 = "CONTINUOUS", LineType2 = "ACAD_ISO02W100"
Const LineWeight1 = acLnWt050, LineWeight2 = acLnWt018
  
  On Error Resume Next
  With ThisDrawing
    Fnd1 = False
    For Each LineTypeObj In .Linetypes
      If StrComp(LineTypeObj.Name, LineType2, vbTextCompare) = 0 Then Fnd1 = True: Exit For
    Next
    If Not Fnd1 Then Set LineTypeObj = .Linetypes.Add(LineType2)
    
    Fnd1 = False: Fnd2 = False
    For Each LayObj In .Layers
      If StrComp(LayObj.Name, LayName1, vbTextCompare) = 0 Then Fnd1 = True
      If StrComp(LayObj.Name, LayName2, vbTextCompare) = 0 Then Fnd2 = True
    Next
    If Not Fnd1 Then Set LayObj = .Layers.Add(LayName1)
    LayObj.color = acWhite: LayObj.Linetype = LineType1: LayObj.Lineweight = LineWeight1
    If Not Fnd2 Then Set LayObj = .Layers.Add(LayName2)
    LayObj.color = acWhite: LayObj.Linetype = LineType2: LayObj.Lineweight = LineWeight2
    
    Do
      Err.Clear:  GetAsyncKeyState vbKeyEscape:  .RightClick = False
      .Utility.GetEntity Blk, pnt, vbCrLf & "Выберите объект:"
      If Err.Number = 13 Then .Utility.Prompt vbCrLf & "Требуется вхождение блока"
    Loop Until Err = 0 Or GetAsyncKeyState(vbKeyEscape) Or .RightClick
    If Not Err = 0 Then Exit Sub
    If .Layers(Blk.Layer).Lock Then .Utility.Prompt vbCrLf & "Объект на блокированном слое" & vbCrLf: Exit Sub
    
    Do
      Err.Clear: GetAsyncKeyState vbKeyEscape: .RightClick = False
      NewInsPnt0 = .Utility.GetPoint(, "Укажите новую точку вставки:")
    Loop Until Err = 0 Or GetAsyncKeyState(vbKeyEscape) Or .RightClick
    If Not Err = 0 Then Exit Sub
    
    InsPnt = .Utility.TranslateCoordinates(Blk.InsertionPoint, acWorld, acOCS, 0, Blk.Normal)
    NewInsPnt = .Utility.TranslateCoordinates(NewInsPnt0, acWorld, acOCS, 0, Blk.Normal)
    
    Set BlkSpace = .Blocks(Blk.Name)
    
    nlay = .Layers.Count - 1    '
    ReDim Lays(1, nlay) As Boolean
    For lr = 0 To nlay
      Lays(0, lr) = .Layers(lr).Lock: Lays(1, lr) = .Layers(lr).Freeze
      .Layers(lr).Lock = False
      If .ActiveLayer.Name <> .Layers(lr).Name Then .Layers(lr).Freeze = False
    Next
    
    For Each Entry In BlkSpace
      Select Case UCase(Entry.Linetype)
      Case "BYLAYER", "BYBLOCK", LineType1
        Entry.Layer = LayName1
      Case Else
        Entry.Layer = LayName2
      End Select
      Entry.Linetype = "BYLAYER"
      Entry.Lineweight = acLnWtByLayer
      Entry.Move NewInsPnt, InsPnt
    Next
    Blk.Move Blk.InsertionPoint, NewInsPnt0
    Blk.Update
    
    For lr = 0 To nlay
      .Layers(lr).Lock = Lays(0, lr)
      If .ActiveLayer.Name <> .Layers(lr).Name Then .Layers(lr).Freeze = Lays(1, lr)
    Next
  End With
End Sub

Теперь отслеживается наличие необходимых слоев и типов линий. Если их вдруг не окажется, то создаются.
Если блок на блокированном слое - работа программы прерывается.
Чтобы не было неприятностей из-за того, что объекты блока на блокированных\замороженных слоях (маловероятно, но все же) все слои разблокируются и размораживаются. По завершении программы состояние слоев восстанавливается.

Чигинский Дмитрий · 18.03.2007, 16:20

Результат теперь лежит в Downloads - FlatshotTools.

Описание и подробное объяснение - Работа в AutoCAD в 3D. Оптимизация работы с Flatshot.

25.02.2007, 03:32		#1
Оптимизация работы с Flatshot Чигинский Дмитрий ГИП Тула Регистрация: 09.09.2006 Сообщений: 112 Введение: После создания модели конструкции в 3D, для получения какого-либо вида жму на Flatshot, в настройках которого указываю Foreground lines (Color: By Layer; Linetype: Continuous) и Obscured lines (Color: By Layer; Linetype: ISO Dash). Слои "Сплошная толстая основная" и "Штриховая" уже существуют. Здесь есть следующие проблемы: 1. Типы линий указаны явно; 2. Толщины всех линий то же явно - 0.00 mm. 3. Каким образом Flatshot выбирает базовую точку непонятно. Что нужно: Нужна кнопка (макрос, ЛИСП или ещё что-то, но для пользователя - это одна кнопка), пользователь выполняет следующую последовательность действий: 1. Жмёт Кнопку; 2. Выбирает блок созданный при помощи Flatshot; 3. Выбирает базовую точка; 4. Без дополнительного подтверждения команда завершается. Что происходит: В выбранном блоке все линии со свойством Linetype: Continuous попадают в слой "Сплошная толстая основная", а со свойством Linetype: ISO Dash в слой "Штриховая". Причём свойство Linetype и Lineweight автоматически изменяется на By Layer. В блоке начало координат 0.0 становится там, где пользователь указал базовую точку. Заранее спасибо. __________________ С уважением, Чигинский Дмитрий.
Просмотров: 11409