Vetcad
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Разместить текст по блоку в ПСК

Разместить текст по блоку в ПСК

Ответ
Поиск в этой теме
Непрочитано 02.12.2020, 20:15 #1
Разместить текст по блоку в ПСК
olga87
 
Регистрация: 28.05.2007
Сообщений: 142

Здравствуйте Уважаемые программисты!

Код ниже выполняет вставку текста в заданную пользователем точку относительно точки вставки блока.
Код работает правильно только в МСК, но если система координат XY повернута (относительно оси z), то текст продолжает вставляться горизонтально!
Подскажите пожалуйста, как исправить код для корректной работы в повернутой ПСК?
Заранее спасибо!

Код:
[Выделить все]
(vl-load-com)

(defun text-with-block (param / oldcmd oldosmode olderr selset height text ang pt)

;Вызов:
;(text-with-block nil)

(setq oldcmd (getvar "cmdecho")
oldosmode (getvar "osmode")
olderr *error*
)
(defun *error* (msg)
(if (not (member msg (list "Отменено.")))
(princ (strcat "\nОшибка: " msg))
)
(setvar "cmdecho" oldcmd)
(setvar "osmode" oldosmode)
(setq *error* olderr)
(princ)
)
(setvar "cmdecho" 0)
(setvar "osmode" 0)
  (if (and (or (setq selset (ssget "_I" '((0 . "INSERT"))))
               (= (type (setq selset (vl-catch-all-apply (function (lambda () (ssget '((0 . "INSERT"))))))))
                  'pickset
               )
           )
           (setq selset ((lambda (/ tab item)
                           (repeat (setq tab  nil
                                         item (sslength selset)
                                   )
                             (setq tab (cons (ssname selset (setq item (1- item))) tab))
                           )
                         )
                        )
           )
           (= (type
                (setq height (vl-catch-all-apply
                               (function
                                 (lambda ()
                                   (initget 6)
                                   (cond ((cdr (assoc "height" param)))
                                         ((cdr (assoc "textsize" param)) (getvar "textsize"))
                                         ((getdist (strcat "\nВведите высоту текста <"
                                                           (rtos (cond ((not #def-height) (setq #def-height (getvar "textsize")))
                                                                       (#def-height)
                                                                 )
                                                                 2
                                                           )
                                                           ">: "
                                                   )
                                          )
                                         )
                                         (t #def-height)
                                   )
                                 )
                               )
                             )
                )
              )
              'real
           )
           (> height 0.)
           (= (type
                (setq text (vl-catch-all-apply (function (lambda (/ value)
                                                           (setq value (getstring t
                                                                                  (strcat "\nВведите текст <"
                                                                                          (cond (#def-text)
                                                                                                ((setq #def-text "0,000"))
                                                                                          )
                                                                                          ">: "
                                                                                  )
                                                                       )
                                                           )
                                                           (if (/= value "")
                                                             (setq #def-text value)
                                                             (setq value #def-text)
                                                           )
                                                           value
                                                         )
                                               )
                           )
                )
              )
              'str
           )
           (/= text "")
           (= (type
                (setq ang (vl-catch-all-apply
                              (function (lambda ()
                                          (getangle (strcat "\nВведите угол наклона текста: "))
                                        )
                              )
                            )
                )
              )
              'real
           )
           (= (type
                (setq align (vl-catch-all-apply
                              (function (lambda ()
                                          (initget "Left Center Right Middle _ L C R M")
                                          (cond ((getkword "\nУкажите выравнивание для текста [Left/Center/Right/Middle] <Left>: "))
                                                (t "L")
                                          )
                                        )
                              )
                            )
                )
              )
              'str
           )
           (= (type
                (setq dist (vl-catch-all-apply
                              (function (lambda ()
                                          (getpoint "\nУкажите точку вставки текста <Отмена>: ")
                                        )
                              )
                            )
                )
              )
              'list
           )
      )
    (progn (setq #def-text text
                 #def-height height
           )
           (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
           (foreach ent selset
             (setq pt (trans dist 1 0))
             (entmakex (list (cons 0 "TEXT")
                             (cons 40 #def-height)
                             (cons 10 pt)
                             (cons 11 pt)
                             (cons 1 #def-text)
                             (cons 50 (/ (* ang 180) pi))
                             (cons 7 (getvar "TEXTSTYLE"))
                             (cons 73 0)
                             (cons 72
                                   (cond ((= align "C") 1)
                                         ((= align "R") 2)
                                         ((= align "M") 4)
                                         (t 0)
                                   )
                             )
                       )
             )
           )
           (vla-endundomark adoc)
    )
  )
  (setvar "osmode" oldosmode)
  (setvar "cmdecho" oldcmd)
  (setq *error* olderr)
  (princ)
)

Миниатюры
Нажмите на изображение для увеличения
Название: 1.png
Просмотров: 16
Размер:	7.8 Кб
ID:	232356  


Последний раз редактировалось olga87, 02.12.2020 в 23:16.
Просмотров: 811
 
Непрочитано 04.12.2020, 10:18
#2
koMon


 
Регистрация: 26.09.2017
Сообщений: 863


заменить
Код:
[Выделить все]
 (cons 50 (/ (* ang 180) pi))
в (entmakex)
на
Код:
[Выделить все]
 (cons 50 (+ (angle '(0 0) (getvar 'ucsxdir)) ang))
koMon вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Разместить текст по блоку в ПСК

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Разместить текст выноски горизонтально в МСК olga87 LISP 0 07.05.2016 19:30
Как автоматически добавить текст/атрибуты блока к уже существующему блоку? ADJ AutoCAD 11 08.02.2015 18:34
Почему блок содержащий атрибут теряет его при приминении к блоку команды разместить? Роман Амосов Динамические блоки 2 20.05.2012 12:25
Как разместить текст вдоль круга! Homer AutoCAD 6 28.10.2008 13:25
Как получить текст пояснения к блоку? mmmx Программирование 13 13.12.2006 03:47