Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)

Red Nova · 20.07.2008, 20:12

Со школы не ладится у меня с программированием. Все предметы щелкал, а на экзамене по информатике (Visual foxpro) программку типа суммирования столбцов списал у соседа (это уже в университете).
Не смотря на эте намерен научится писать программы для Автокада на лиспе, скачал книгу Хювенена, несколько примеров создания программ, но после получасового “смотрения” таких книг мое мышление явно притормаживает.
Решил пойти другим путем.
Нашел самый короткий лисп из моей коллекции, и прошу программистов с этого форума пошагово объяснить какой символ что означает. Надеюсь на вашу помощь.

Код:

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

(defun c:make-blocks-explodeable (/ adoc)
  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-startundomark
  (vlax-for blk_def (vla-get-blocks adoc)
    (if (and (equal (vla-get-isxref blk_def) :vlax-false)
             (equal (vla-get-islayout blk_def) :vlax-false)
             ) ;_ end of and
      (vl-catch-all-apply '(lambda () (vla-put-explodable blk_def :vlax-true)))
      ) ;_ end of if
    ) ;_ end of vlax-for
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

_____________________________________________________________________________________________________________

Прошло много лет и топик теперь представляет из себя площадку для обучения азов программирования для многих начинающих.
Так что начинающие лиспогрызы приветствуются .

Jek30 · 14.11.2022, 13:24

Цитата:

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

странно , а зачем печатать из пространства листа какой то кусок?
вы можете вбить (command "_.plot") и смотреть что вам выводит и какие варианты дает автокад, в некоторыхпараметрах можно ввести "?" чтобы посмотреть все варианты
Соответвествно чтобы не из модели печатать нужно в 3 строке где сейчас "model" , нужно указать имя листа из которого печатать. обычно имя текущего листа можно получить через (getvar "CTAB") но тут он не работает.
тоже самое если не хотите вписывать то в строке "_fit" нужно указать свое значение.

Это не кусок, а быстрая печать формата А4 или какого захочешь, если выставишь в коде лиспа (просто лисп включил, указал нужный чертеж, и он тут же распечатался)

я со всеми моментами разобрался в том числе и с "_fit", авот как его заставить чтоб этот лисп работал в пространстве Листов??

Composter · 14.11.2022, 16:14

Так если у вас лист сформирован через публикацию "_PUBLISH" печатаешь любой лист , через page setup можно выставить любой другой формат. Зачем изобретать велосипед?
вместо "_fit" нужно указать масштаб например вот так "1:1".

Jek30 · 15.11.2022, 09:09

Цитата:

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

Так если у вас лист сформирован через публикацию "_PUBLISH" печатаешь любой лист , через page setup можно выставить любой другой формат. Зачем изобретать велосипед

Потому-что на новом велосипеде достаточно нажать только одну кнопочку и нужный чертеж распечатался, нежели капашиться в page setup. А публикация это не удобно, в плане того что там на каждый чертеж нужно создавать отдельный лист, а у меня все эти чертежи в одном пространстве Лист1. (так легче их сравнивать между собой, чем бегать по вкладкам Листов). А работаю я в Листе, потомучто там у меня видовые экраны.

Цитата:

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

вместо "_fit" нужно указать масштаб например вот так "1:1".

Спасибо! но я так и сделал и в остальных переменных тоже разобрался. Только вот осталась одна строчка.
вот эта↓
"model" ; Имя листа или [?] <Модель>:
В модели он шикарно работает, но как сделать так чтоб он работал и в листах?
Что конкретно прописать в коде, чтоб он заработал и в пространстве Листа? (В лиспах не шарю вообще) ☺

Composter · 15.11.2022, 12:49

а у меня все эти чертежи в одном пространстве Лист1
Рука-лицо. Зачем тогда вобще вам пространство листа тогда?
Есть куча вариантов когда нижимаешь 1 кнопку и формируются все листы с нужными размерами листов https://forum.dwg.ru/showthread.php?t=104517

Что конкретно прописать в коде, чтоб он заработал и в пространстве Листа?
Нужно указать имя листа

Jek30 · 15.11.2022, 12:58

Цитата:

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

Рука-лицо. Зачем тогда вобще вам пространство листа тогда?

Если бы не видовые экраны, то я бы пользовался только моделью.

Цитата:

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

Есть куча вариантов когда нижимаешь 1 кнопку и формируются все листы с нужными размерами листов https://forum.dwg.ru/showthread.php?t=104517

Этот фрагмент лиспа как раз таки из той темы, плюс еще двумя штуками от туда я пользуюсь. Но охото ещё коечто автоматизировать, просто я не умею☺

Цитата:

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

Что конкретно прописать в коде, чтоб он заработал и в пространстве Листа?

Да, нужно чтобы этот лисп работол в пространстве листа с любым именем.

Цитата:

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

Нужно указать имя листа

Я пытался туда вбить имя листа, но лисп выдавал почемуто ошибку. Поэтому к вам и обратился☺

Кулик Алексей aka kpblc · 15.11.2022, 14:15

Цитата:

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

Да, нужно чтобы этот лисп работол в пространстве листа с любым именем.

Ну так получи активное пространство и бери его имя, делов-то

Jek30 · 15.11.2022, 14:30

Цитата:

Сообщение от Кулик Алексей aka kpblc

Ну так получи активное пространство и бери его имя, делов-то

Я в лиспах вообще не шарю. Мне бы кто-нибудь эту самую строчку прописал бы правильно!))

Кулик Алексей aka kpblc · 15.11.2022, 14:50

(getvar "ctab") - вот тебе и имя активной закладки (в подавляющем большинстве случаев).

Jek30 · 15.11.2022, 14:59

Цитата:

Сообщение от Кулик Алексей aka kpblc

(getvar "ctab") - вот тебе и имя активной закладки (в подавляющем большинстве случаев).

Вот так прописал этот "гетвар" ☺ : в модели пашет, а в листах выдает ошибку↓↓↓

(defun c:aaa1 ()
<(defun GetBoundingBox (en / obj minpt maxpt)
(if (= (type en) 'ENAME)
(progn
(setq obj (vlax-ename->vla-object en))
(vla-getboundingbox obj 'minpt 'maxpt)
(list
(trans (vlax-safearray->list minpt) 0 1)
(trans (vlax-safearray->list maxpt) 0 1)
) ;_ end of list
) ;_ end of progn
) ;_endof if progn
) ;_endof defun

(princ "Выберите объект для печати")
(setq box (GetBoundingBox (car(entsel)))); список из координат минимума и максимума габаритов выбранного объекта
(setq xy1 (car box)); координаты для определения области печати, xy1 - левая нижняя, xy2 - правая верхняя
(setq xy2 (car (cdr box)))

(command "_.plot"
"_Yes"
(getvar "ctab") ; Имя листа или [?] <Модель>:
"PDFCreator.pc3" ;Имя устройства вывода
"A4" ;Формат листа бумаги
"Millimeters" ;Единицы измерения размеров листа
"portrait" ;Ориентация чертежа
"_No" ;Перевернуть чертеж?
"_Window" ;Печатаемая область
xy1 ;Первая точка окна
xy2 ;Вторая точка окна
"1:1" ;[Вписать]
"_center" ;Смещение от начала (x,y) или [Центрировать]
"_No" ;Учитывать стили печати?
"monochrome.ctb" ;Имя таблицы стилей печати
"_yes" ;Учитывать веса линий?
"As displayed" ;Режим вывода раскрашенных ВЭ
"_No" ;Запись чертежа в файл
"_No" ;Сохранить изменения параметров листа
"_yes" ;Перейти к печати
) ;_ end of command>
)

Кулик Алексей aka kpblc · 15.11.2022, 15:05

Ну, во-первых, в расширенном редакторе есть возможность показывать нормально форматированный код.
Во-вторых, что там перед локальным defun'ом делает символ "<"?
В-третьих, что за ошибка? И в каком месте?

----- добавлено через ~2 мин. -----
И зачем выполнять перевод точек из мировой системы в пользовательскую?

Короче, проверяй значения каждой переменной перед вызовом команды

Composter · 15.11.2022, 15:46

Я ж уже писал что (getvar "ctab" ) не работает. Он пишет неверное имя листа.

Лучше не морочить голову а воспользоваться другим лиспом из той темы и оформлять отдельный лист в отдельном пространстве.

Кулик Алексей aka kpblc · 15.11.2022, 17:50

Цитата:

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

Я ж уже писал что (getvar "ctab" ) не работает. Он пишет неверное имя листа.

Лучше не морочить голову а воспользоваться другим лиспом из той темы и оформлять отдельный лист в отдельном пространстве.

Ни разу не сталкивался. Приведи пример такого файла, где ctab возвращает неверный результат

Composter · 15.11.2022, 17:54

Я тоже не сталкивался, имелл ввиду что пару сообщений выше писал.попытался впучную в команде ._plot вставить это в соответствующем запросе и получил ошибку.

Jek30 · 16.11.2022, 13:40

Цитата:

Сообщение от Кулик Алексей aka kpblc

Ну, во-первых, в расширенном редакторе есть возможность показывать нормально форматированный код.

Я же говорю: "В лиспе я вообще не разбираюсь"

Цитата:

Сообщение от Кулик Алексей aka kpblc

Во-вторых, что там перед локальным defun'ом делает символ "<"?

Это таким способом этот лисп у меня запускается с кнопки.

Цитата:

Сообщение от Кулик Алексей aka kpblc

В-третьих, что за ошибка? И в каком месте?

Ошибка в том что лисп в пространстве листа не пашет! (а в пространстве модели работает прекрасно)
Моя логика подсказывает что нужно изменить вот эту строчку ↓↓↓, но я могу и ошибаться (это просто мое мнение)
"model" ; Имя листа или [?] <Модель>: (такая она была сначала)
(getvar "ctab") ; Имя листа или [?] <Модель>: (такая стала она теперь, но по прежнему не пашет в простр-ве листа)

Цитата:

Сообщение от Кулик Алексей aka kpblc

И зачем выполнять перевод точек из мировой системы в пользовательскую?

это я ваще не понял что означает☺

Цитата:

Сообщение от Кулик Алексей aka kpblc

Короче, проверяй значения каждой переменной перед вызовом команды

пробовал разные все получилось (центрировать, замена формата и т.д.) кроме, того чтоб лисп работал в пространстве листа

Кулик Алексей aka kpblc · 16.11.2022, 15:06

Я про переменные, а не про печать. На твоем месте я бы почитал книгу "AutoCAD язык макрокоманд и создание макросов" (есть в Download). Спойлер: тогда поймешь, что сначала надо команду пройтись "руками", последовательно отвечая на все ее запросы - и тогда появится хоть какой-то шанс на то, что макрос/программа корректно сработает.

valerik88 · 16.11.2022, 15:19

Jek30, Не разбирался в твоём коде, просто вставил последний кусок из своего рабочего кода, у меня всё заработало в листах.
Сравни свой с моим, может найдётся причина.

Jek30 · 17.11.2022, 12:48

Цитата:

Сообщение от Кулик Алексей aka kpblc

На твоем месте я бы почитал книгу "AutoCAD язык макрокоманд и создание макросов" (есть в Download).

Да просто не охота ради пару лиспиков штудировать неизвестную мне литературу ☺

----- добавлено через ~3 мин. -----

Цитата:

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

Не разбирался в твоём коде, просто вставил последний кусок из своего рабочего кода, у меня всё заработало в листах.
Сравни свой с моим, может найдётся причина.

Какой у тебя лисп работает? Который ты во вложении скинул? (У меня он почему-то не пашет,попробовал значения некоторые поменять, тоже не работает)

Кулик Алексей aka kpblc · 17.11.2022, 12:54

Цитата:

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

Да просто не охота ради пару лиспиков штудировать неизвестную мне литературу

Ну тут выбор-то не сильно богатый - либо самостоятельно разобраться и сделать как хочется, либо постоянно просить кого-то сделать.

Jek30 · 17.11.2022, 13:03

Цитата:

Сообщение от Кулик Алексей aka kpblc

Ну тут выбор-то не сильно богатый - либо самостоятельно разобраться и сделать как хочется, либо постоянно просить кого-то сделать.

Ладно. Всё-равно спасибо!

)))))

nikkomp · 02.12.2022, 13:50

Здраствуйте, вот надыбал два lispa по копированию текста, нельзя ли их скомпоновать так чтобы, чтобы можно было копировать и вставлять текст в примитивы СПДС GraphiCS?

Код:

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

;;Text to Text Copy Color
(defun c:ttcc (/ actDoc vlaObj sObj sText curObj oldForm
        oType oldMode conFlag errFlag *error* color)
  (vl-load-com)
  (setq color 1) ;_ Text color Цвет текта nil - nothing
  ;;; Text to Text Copy
;;; Original posted Aleksandr Smirnov {Smirnoff} now known as ASMI
;;; Aleksandr Smirnov (ASMI)
;;; https://www.caduser.ru/forum/topic21894.html
;;; Modifyed V. Azarko (VVA)
;;; https://www.caduser.ru/forum/topic21894.html
;;; 22.10.2008 Add MULTILEADER
;;; 20.05.2009 Add Color
     (setq actDoc(vla-get-ActiveDocument
        (vlax-get-acad-object)))
      (vla-StartUndoMark actDoc)
  (defun TTC_Paste(pasteStr / nslLst vlaObj hitPt
                   hitRes Row Column lst ss)
    (setq errFlag nil)
  (setvar "ERRNO" 0)(initget "Switch")
    (while (progn
        (setq Lst(nentsel "\nPaste text or first point of corner or [Switch layout] <Enter-exit> >>"))
        (cond ((= Lst "Switch")
          (TTC_ls)
          (setvar "ERRNO" 0)
          (initget "Switch")
          T
          )
;;;         ((and (null Lst)
;;;          (= (getvar "errno") 7)
;;;          )
;;;          (princ "* Missing * ")
;;;          (setvar "ERRNO" 0)
;;;          (initget "Switch")
;;;          T
;;;          )
         (t nil)
         )
        )
      );_while
  (if (and (null Lst)
      (= (getvar "errno") 7)
      (setq hitPt (getcorner  (setq vlaObj (cadr(GRREAD nil 1))) "\nOther point: "))
      (setq ss (ssget "_C" vlaObj hitPt '((0 . "*TEXT"))))
      )
    (progn
    (setq Lst (mapcar '(lambda(x)(cons x '((0 0 0))))
         (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
       )
     )
    )
    (setq Lst (list Lst))
    )
(foreach nsllst Lst
    (if nsllst (progn
  (cond
    (
     (and
       (= 4(length nslLst))
       (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))
       ); end and
     (setq vlaObj
      (vlax-ename->vla-object
        (cdr(assoc -1(entget(car(last nslLst)))))))
     (if
       (vl-catch-all-error-p
         (vl-catch-all-apply
       '(lambda()
          (vla-put-TextOverride vlaObj pasteStr)
          (if color (vla-put-color vlaObj color)))))
         (progn
         (princ "\n Can't paste. Object may be on locked layer. ")
         (setq errFlag T)
         ); end progn
       ); end if
     ); end condition #1
    (
     (and
       (= 4(length nslLst))
       (= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))
       ); end and
     (setq vlaObj
      (vlax-ename->vla-object
        (cdr(assoc -1(entget(car(last nslLst))))))
     hitPt(vlax-3D-Point(trans(cadr nslLst)1 0))
     hitRes(vla-HitTest vlaObj hitPt
        (vlax-3D-Point '(0.0 0.0 1.0)) 'Row 'Column)
           ); end setq
     (if(= :vlax-true hitRes)
     (progn
         (if
     (vl-catch-all-error-p
       (vl-catch-all-apply
     '(lambda()
        (vla-SetText vlaObj Row Column pasteStr)
            ;|(if color (vla-put-color vlaObj color))|;)))
     (progn
       (princ "\n Can't paste. Object may be on locked layer. ")
       (setq errFlag T)
       ); end progn
     ); end if
         ); end progn
       ); end if
     ); end condition # 2
    (
     (and
       (= 4(length nslLst))
       (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))
       ); end and
     (princ "\nCan't paste to block's DText or MText. Select Attribute ")
     (setq errFlag T)
     ); end condition #3
    (
     (and
       (= 2(length nslLst))
         (member(cdr(assoc 0(entget(car nslLst))))
           '("TEXT" "MTEXT" "ATTRIB" "ATTDEF" "MULTILEADER"))
       ); end and
     (setq vlaObj
      (vlax-ename->vla-object(car nslLst)))
        (if
     (vl-catch-all-error-p
       (vl-catch-all-apply '(lambda()
         (vla-put-TextString vlaObj pasteStr)
         (if color (vla-put-color vlaObj color)))))
    (progn
       (princ "\nError. Can't pase text. ")
      (setq errFlag T)
      ); end progn
     ); end if
     ); end condition #4
    (T
     (princ "\nCan't paste. Invalid object. ")
     (setq errFlag T)
     ); end condition #5
    ); end cond
             T
      ); end progn
            nil
           ); end if
  )
    ); end of TTC_Paste
    (defun TTC_MText_Clear(Mtext / Text Str)
    (setq Text "")
    (while(/= Mtext "")
      (cond
  ((wcmatch
     (strcase
       (setq Str
        (substr Mtext 1 2)))
                     "\\[\\{}`~]")
   (setq Mtext(substr Mtext 3)
         Text(strcat Text Str)
   ); end setq
  ); end condition #1
  ((wcmatch(substr Mtext 1 1) "[{}]")
    (setq Mtext
     (substr Mtext 2))
  ); end condition #2
  (
   (and
   (wcmatch
     (strcase
       (substr Mtext 1 2)) "\\P")
   (/=(substr Mtext 3 1) " ")
    ); end and
         (setq Mtext (substr Mtext 3)
               Text (strcat Text " ")
         ); end setq
   ); end condition #3
  ((wcmatch
     (strcase
       (substr Mtext 1 2)) "\\[LOP]")
    (setq Mtext(substr Mtext 3))
  ); end condition #4
  ((wcmatch
     (strcase
       (substr Mtext 1 2)) "\\[ACFHQTW]")
    (setq Mtext
     (substr Mtext
       (+ 2
          (vl-string-search ";" Mtext))))
  ); end condition #5
  ((wcmatch
     (strcase (substr Mtext 1 2)) "\\S")
    (setq Str(substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
          Text(strcat Text (vl-string-translate "#^\\" " " Str))
          Mtext(substr Mtext (+ 4 (strlen Str)))
   ); end setq
   (print Str)
  ); end condition #6
  (T
   (setq Text(strcat Text(substr Mtext 1 1))
         Mtext (substr Mtext 2)
   )
  ); end condition #7
      ); end cond
    ); end while
  Text
); end of TTC_MText_Clear
(defun ttc-layouts-list (doc)
  (or doc (setq doc (vla-get-activedocument (vlax-get-acad-object))))
  (vl-sort
    ((lambda (/ res)
       (vlax-for item (vla-get-layouts doc)
         (setq res (cons item res))
         ) ;_ end of vlax-for
       ) ;_ end of lambda
     )
    '(lambda (a b)
       (< (vla-get-taborder a) (vla-get-taborder b))
       ) ;_ end of lambda
    ) ;_ end of vl-sort
  ) ;_ end of defun
;;; RUS ************************************************************************
;;; * Библиотека DWGruLispLib Copyright ©2008  DWGru Programmers Group
;;; *
;;; * _TTC-GET-USER-DCL (Кандидат)
;;; *
;;; * Запрос значения у пользователя через диалоговое окно
;;; *
;;; *
;;; * 26/01/2008 Версия 0002. Редакция Владимир Азарко (VVA)
;;;              - Выход по двойному клику, если запрещен множественный выбор (multi-nil)
;;;              - Обработка нескольких колонок
;;; * 21/01/2008 Версия 0001. Редакция Владимир Азарко (VVA)
;;; ************************************************************************
;;; EN ************************************************************************
;;; * Library DWGruLispLib Copyright © 2008 DWGru Programmers Group
;;; *
;;; * _TTC-GET-USER-DCL (Candidate)
;;; *
;;; * Inquiry of value at the user through a dialogue window
;;; *
;;; *
;;; * 26/01/2008 Version 0002. Edition Vladimir Azarko (VVA)
;;; - the Output on double a clique if the plural choice (multi-nil) is forbidden
;;; - Processing of several columns
;;; * 21/01/2008 Version 0001. Edition Vladimir Azarko (VVA)
(defun _TTC-GET-USER-DCL (ZAGL        INFO-LIST   MULTI
                            /           FL          RET
                            DCL_ID      MAXROW      MAX_COUNT_COL
                            COUNT_COL   I           LISTBOX_HEIGHT
                            LST         _LOC_FINISH _LOC_CLEAR
                            NCOL
                           )
;|
* ENGLISH
* Inquiry of value at the user through a dialogue window
* Dialogue is formed to "strike"
* the Quantity of lines on page without скроллинга is set by variable MAXROW.
* It is necessary to remember, that number MAXROW increases on 3.
* the Maximum quantity of columns is set by variable MAX_COUNT_COL
* It is published
     http://dwg.ru/f/showthread.php?p=203746#post203746
* Parameters of a call:
    zagl - heading of a window [String]
    info-list - the list of line values[List of String]
    multi - t - the plural choice is resolved, nil-is not present
* Returns:
The list of the chosen lines or nil - a cancelling
* the Example
(_TTC-GET-USER-DCL " Specify a variant " ' ("First " Second " " Third ") nil); _-> ("First")
(_TTC-GET-USER-DCL " Specify a variant " ' ("First " Second " " Third ") t); _-> ("First " Second ")
(_TTC-GET-USER-DCL " Specify a variant "
   (progn (setq i 0 lst nil) (repeat 205 (setq lst (cons (strcat "Значение-" (itoa (setq i (1 + i)))) lst))) (reverse lst)) nil)
(_TTC-GET-USER-DCL " Specify a variant, using CTRL and SHIFT for a choice "
   (progn (setq i 0 lst nil) (repeat 205 (setq lst (cons (strcat "Значение-" (itoa (setq i (1 + i)))) lst))) (reverse lst)) t)
|;
                   
                   
;|
* RUS                  
* Запрос значения у пользователя через диалоговое окно
* Диалог формируется "налету"
* Количество строк на страницу без скроллинга задается переменной MAXROW.
* Необходимо помнить, что число MAXROW увеличивается на 3.
* Максимальное количество колонок задается переменной MAX_COUNT_COL
* Опубликована
     http://dwg.ru/f/showthread.php?p=203746#post203746
* Параметры вызова:
    zagl - заголовок окна [String]
    info-list - список строковых значений[List of String]
    multi - t - разрешен множественный выбор, nil- нет
* Возвращает:
Список выбранных строк или nil - отмена
* Пример
(_TTC-GET-USER-DCL "Укажите вариант" '("Первый" "Второй" "Третий") nil) ;_->("Первый")
(_TTC-GET-USER-DCL "Укажите вариант" '("Первый" "Второй" "Третий") t) ;_->("Первый" "Второй")
(_TTC-GET-USER-DCL "Укажите вариант"
   (progn (setq i 0 lst nil)(repeat 205 (setq lst (cons (strcat "Значение-" (itoa (setq i (1+ i)))) lst)))(reverse lst)) nil)
(_TTC-GET-USER-DCL "Укажите вариант, используя CTRL и SHIFT для выбора"
   (progn (setq i 0 lst nil)(repeat 205 (setq lst (cons (strcat "Значение-" (itoa (setq i (1+ i)))) lst)))(reverse lst)) t)
|;
;_ ===== КОНСТАНТЫ ============
  (setq MAXROW 40) ;_макc. кол-во строк без скроллинга (К нему дальше добавится еще 3 строчки)
                   ;_  max lines without scrolling (To it 3 more lines further will be added)
  (setq MAX_COUNT_COL 5) ;_максимальное количество колонок
                         ;_ ; _ a maximum quantity of columns
;;;==================== Локальные фунцкции START==================================
;;;==================== Local functions START==================================
  (defun _LOC_FINISH ()
    (setq I   0
          RET NIL
    ) ;_ end ofsetq
    (repeat COUNT_COL
      (setq I (1+ I))
      (setq RET (cons (cons I (get_tile (strcat "info" (itoa I)))) RET))
    ) ;_ end ofrepeat
    (setq RET (reverse RET))
    (done_dialog 1)
  ) ;_ end ofdefun
  (defun _LOC_CLEAR (NOMER)
    (setq I 0)
    (repeat COUNT_COL
      (setq I (1+ I))
      (if (/= I NOMER)
        (progn
          (start_list (strcat "info" (itoa I)))
          (mapcar 'add_list (nth (1- I) LST))
          (end_list)
        ) ;_ end ofprogn
      ) ;_ end ofif
    ) ;_ end ofrepeat
  ) ;_ end ofdefun
;;;==================== Локальные фунцкции END ==================================
;;;==================== Local functions END ==================================
;;;==================== MAIN PART ===============================================
  (if (null ZAGL)
    (if (= (getvar "DWGCODEPAGE") "ANSI_1251")
      (setq ZAGL "Выбор")
      (setq ZAGL "Select")
    ) ;_ end ofif
  ) ;_ end if
  (if (zerop (rem (length INFO-LIST) MAXROW)) ;_Целое количество столбцов
    (setq COUNT_COL (/ (length INFO-LIST) MAXROW)) ;_Его и оставляем
    (setq COUNT_COL (1+ (fix (/ (length INFO-LIST) MAXROW 1.0)))) ;_Берем ближайшее целое
  ) ;_ end ofif
  (if (> COUNT_COL MAX_COUNT_COL)
    (setq COUNT_COL MAX_COUNT_COL)
  ) ;_Ограничиваем max количеством
  (setq LISTBOX_HEIGHT (+ 3 MAXROW)) ;_  добавляем 3 строчки для красоты и для исключения пограничного скроллинга
                                     ;_ We add 3 lines for appearance and for exception boundary scroll
  (if (and (= COUNT_COL 1) (<= (length INFO-LIST) MAXROW))
    (setq LISTBOX_HEIGHT (+ 3 (length INFO-LIST)))
  ) ;_ end ofif
  (setq I 0)
  (setq FL (vl-filename-mktemp "dwgru" NIL ".dcl"))
  (setq RET (open FL "w")
        LST NIL
  ) ;_ end ofsetq
  (mapcar '(lambda (X) (write-line X RET))
          (append (list "dwgru_get_user : dialog { "
                        (strcat "label=\"" ZAGL "\";")
                        ": boxed_row {"
                        (if (= (getvar "DWGCODEPAGE") "ANSI_1251")
                          "label = \"Значение\";"
                          "label = \"Value\";"
                        ) ;_ end ofif
                  ) ;_ end oflist
                  (repeat COUNT_COL
                    (setq LST
                           (append
                             LST
                             (list
                               " :list_box {"
                               "alignment=top ;"
                               (if MULTI
                                 "multiple_select = true ;"
                                 "multiple_select = false ;"
                               ) ;_ end ofif
                               "width=31 ;"
                               (strcat "height= " (itoa LISTBOX_HEIGHT) " ;")
                               "is_tab_stop = false ;"
                               (strcat "key = \"info" (itoa (setq I (1+ I))) "\";}")
                             ) ;_ end oflist
                           ) ;_ end ofappend
                    ) ;_ end ofsetq
                  ) ;_ end ofrepeat
                  (list
                    "}"
                    ":row{"
                    "ok_cancel_err;}}"
                  ) ;_ end oflist
          ) ;_ end of list
  ) ;_ end of mapcar
  (setq RET (close RET))
  (if (and (null (minusp (setq DCL_ID (load_dialog FL))))
           (new_dialog "dwgru_get_user" DCL_ID)
      ) ;_ end and
    (progn
      (setq LST INFO-LIST)
      ((lambda (/ RET1 BUF ITM)
         (repeat (1- COUNT_COL)
           (setq I '-1)
           (while (and (setq ITM (car LST))
                       (< (setq I (1+ I)) MAXROW)
                  ) ;_ end ofand
             (setq BUF (cons ITM BUF)
                   LST (cdr LST)
             ) ;_ end ofsetq
           ) ;_ end ofwhile
           (setq RET1 (cons (reverse BUF) RET1)
                 BUF  NIL
           ) ;_ end ofsetq
         ) ;_ end ofrepeat
         (setq RET RET1)
       ) ;_ end oflambda
      )
      (if LST
        (setq RET (cons LST RET))
      ) ;_ end ofif
      (setq LST (reverse RET))
      (setq I 0)
      (mapcar '(lambda (THIS_LIST)
                 (if (<= (setq I (1+ I)) COUNT_COL)
                   (progn
                     (start_list (strcat "info" (itoa I)))
                     (mapcar 'add_list THIS_LIST)
                     (end_list)
                   ) ;_ end ofprogn
                 ) ;_ end ofif
               ) ;_ end oflambda
              LST
      ) ;_ end ofmapcar
      (set_tile "info1" "0")
      (setq I 0
            NCOL 1
      ) ;_ end ofsetq
      (repeat COUNT_COL
        (action_tile
          (strcat "info" (itoa (setq I (1+ I))))
          (strcat "(progn (setq Ncol "
                  (itoa I)
                  ")(if (not multi)(_loc_clear Ncol))"
                  "(if (and (not multi)(= $reason 4))(_loc_finish)))"
          ) ;_ end ofstrcat
        ) ;_ end ofaction_tile
      ) ;_ end ofrepeat
      (action_tile "cancel" "(done_dialog 0)")
      (action_tile "accept" "(_loc_finish)")
      (if MULTI
        (set_tile "error"
                  (if (= (getvar "DWGCODEPAGE") "ANSI_1251")
                    "Используйте CTRL и SHIFT для выбора"
                    "Use CTRL and SHIFT for a choicet"
                  ) ;_ end ofif
        ) ;_ end ofset_tile
        (set_tile "error"
                  (if (= (getvar "DWGCODEPAGE") "ANSI_1251")
                    "Можно выбирать двойным щелчком"
                    "It is possible to choose double click"
                  ) ;_ end ofif
        ) ;_ end ofset_tile
      ) ;_ end ofif
      (if (zerop (start_dialog))
        (setq RET NIL)
        (progn
          (setq
            RET (apply
                  'append
                  (mapcar
                    '(lambda (ITM)
                       (setq THIS_LIST (nth (1- (car ITM)) LST))
                       (mapcar
                         (function (lambda (NUM) (nth NUM THIS_LIST)))
                         (read (strcat "(" (cdr ITM) ")"))
                       ) ;_ end ofmapcar
                     ) ;_ end oflambda
                    RET
                  ) ;_ end ofmapcar
                ) ;_ end ofapply
          ) ;_ end ofsetq
        ) ;_ end ofprogn
      ) ;_ end if
      (unload_dialog DCL_ID)
    ) ;_ end of progn
  ) ;_ end of if
  (vl-file-delete FL)
  RET
) ;_ end of defun
(defun TTC_ls ( / ret)
  (and
    (setq
      ret
       (car (_TTC-GET-USER-DCL
              "Select layout"
              (mapcar 'vla-get-name (ttc-layouts-list nil))
              nil
              ) ;_ end of _TTC-GET-USER-DCL
            ) ;_ end of car
      ) ;_ end of setq
    (setvar "CTAB" ret)
    ) ;_ end of and
  (princ)
  ) ;_ end of defun
  (defun TTC_Copy (/ sObj sText tType actDoc)
(setvar "ERRNO" 0)(initget "Switch")
   (if
    (and
    (or
    (while (progn
        (setq sObj(nentsel "\nCopy text [Switch layout]... "))
        (cond ((= Lst "Switch")
          (TTC_ls)
          (setvar "ERRNO" 0)
          (initget "Switch")
          T
          )
         ((and (null Lst)
          (= (getvar "errno") 7)
          )
          (princ "* Missing * ")
          (setvar "ERRNO" 0)
          (initget "Switch")
          T
          )
         (t nil)
         )
        )
      ) T)
;;;      (or
;;;      (while (= (setq sObj(nentsel "\nCopy text [Switch layout]... ")) "Switch")
;;;   (TTC_ls)
;;;   (initget "Switch")
;;;   )
;;;         t)
     (setq sObj(car sObj))
     (member(setq tType(cdr(assoc 0(entget sObj))))
      '("TEXT" "MTEXT" "ATTRIB" "ATTDEF" "MULTILEADER"))
     ); end and
    (progn
      (setq actDoc(vla-get-ActiveDocument(vlax-get-Acad-object))
       sText(vla-get-TextString(vlax-ename->vla-object sObj))
      ); end setq
      ;;; (if(= tType "MTEXT")(setq sText(TTC_MText_Clear sText))); end if
      (setq sText(TTC_MText_Clear sText))
      ); end progn
    ); end if
    sText
    ); end of TTC_Copy
  (defun CCT_Str_Echo(paseStr / comStr)
    (if(< 20(strlen paseStr))
      (setq comStr
       (strcat
         (substr paseStr 1 17)"..."))
      (setq comStr paseStr)
      ); end if
    (princ
      (strcat "\nText = \"" comStr "\""))
    (princ)
    ); end of CCT_Str_Echo
    (defun *error*(msg)
    (vla-EndUndoMark
      (vla-get-ActiveDocument
        (vlax-get-acad-object)))
    (princ "\nQuit TTC")
    (princ)
    ); end of *error*
    (if(not ttc:Mode)(setq ttc:Mode "Multiple"))
    (initget "Multiple Pair-wise")
    (setq oldMode ttc:Mode
    ttc:Mode
     (getkword
       (strcat "\nSpecify mode [Multiple/Pair-wise] <" ttc:Mode ">: "))
    conFlag T
    paseStr ""
     ); end setq
    (if(null ttc:Mode)(setq ttc:Mode oldMode))
    (if(= ttc:Mode "Multiple")
      (progn
  (if(and(setq paseStr(TTC_Copy))conFlag)
    (progn
    (CCT_Str_Echo paseStr)
    (while(setq conFlag(TTC_Paste paseStr))T
      ); end while
    ); end progn
    ); end if
  ); end progn
      (progn
  (while
    (and conFlag paseStr)
    (setq paseStr(TTC_Copy))
    (if(and paseStr conFlag)
      (progn
    (CCT_Str_Echo paseStr)
    (setq errFlag T)
    (while errFlag
    (setq conFlag(TTC_Paste paseStr))
         );end while
       ); end progn
      ); end if
    ); end while
  ); end progn
      ); end if
   (vla-EndUndoMark actDoc)
   (princ "\nQuit TTC")
  (princ)

и вот

Код:

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

(defun c:ttc (/ *error* vlaObj sObj sText curObj oType oldMode conFlag errFlag) ;*error* actDoc
;;;     (vl-load-com)
;;;     (setq actDoc (vla-get-activedocument
;;;		       (vlax-get-acad-object)
;;;		  ) ;_ vla-get-ActiveDocument
;;;     ) ;_ setq

  (defun *error* (msg)
     (vla-endundomark
	  (vla-get-activedocument
	       (vlax-get-acad-object)
	  ) ;_ vla-get-ActiveDocument
     ) ;_ vla-EndUndoMark
     (princ "\nQuit TTC")
     (princ)
) ;_ defun
  
     (vla-startundomark adoc)
;;;***********************************
;;;     выбор режима

;;;     (if (not ttc:Mode)
;;;	  (setq ttc:Mode "Multiple")
;;;     ) ;_ if
     (initget "Multiple Pair-wise")
     (setq
;;;	  oldMode  ttc:Mode
;;;	   ttc:Mode
;;;		    (getkword
;;;			 (strcat "\nSpecify mode [Multiple/Pair-wise] <" ttc:Mode ">: ")
;;;		    ) ;_ getkword
	  conFlag
	      t
	  paseStr ""
     )						  ; end setq
;;;     (if (null ttc:Mode)
;;;	  (setq ttc:Mode oldMode)
;;;     ) ;_ if


;;;***********************************
     (setq ttc:Mode "Multiple")			  ; предопределенный режим
;;;***********************************

     (setq t_offer "\nВыберите исходный текст... >")

     (if (= ttc:Mode "Multiple")
	  (progn
	       (if (and (setq paseStr (TTC_Copy t_offer)) conFlag)
		    (progn
			 (CCT_Str_Echo paseStr)
			 (while	(setq conFlag (TTC_Paste paseStr "\nКуда вставлять текст? >"))
			      t
			 )			  ; end while
		    )				  ; end progn
	       )				  ; end if
	  )					  ; end progn
	  (progn
	       (while
		    (and conFlag paseStr)
			(setq paseStr (TTC_Copy t_offer))
			(if (and paseStr conFlag)
			     (progn
				  (CCT_Str_Echo paseStr)
				  (setq errFlag t)
				  (while errFlag
				       (setq conFlag (TTC_Paste paseStr "\nКуда вставлять текст? >"))
				  )		  ;end while
			     )			  ; end progn
			)			  ; end if
	       )				  ; end while
	  )					  ; end progn
     )						  ; end if
     (vla-endundomark adoc)
     (princ "\nQuit TTC")
     (princ)
)						  ; end c:ttc



(defun TTC_Copy (offer / sObj sText tType i)                                   ; возвращает строку, работает с текстом, таблицами, мтекстом и пр.    sObj sText tType actDoc
                                                            ; offer - приглашение для выбора объекта
  (setq sObj  (entget (car (nentsel offer)))
        tType (cdr (assoc 0 sObj))
  ) ;_ setq
  (if sObj
    (cond
;;;---------------------------------------------------------------------------------------------------------------------
      ((member tType '("TEXT" "MTEXT"))                     ;текст, мтекст
       (setq sText (cdr (assoc 1 sObj)))
       (if (= tType "MTEXT")
         (setq sText (TTC_MText_Clear sText))
       ) ;_ if
      )
;;;---------------------------------------------------------------------------------------------------------------------
      ((or (= tType "spdsNotePosition")                     ;позиционная выноска
           (= tType "spdsNoteComb")                         ;гребенчатая выноска
           (= tType "spdsNoteChain")                        ;цепная выноска
           (= tType "spdsLinearMark")                       ;маркировка линейных конструкций
       ) ;_ or
       (setq i 0)
       (repeat (length sObj)
         (if (= (cdr (nth i sObj)) "String1")
           (progn
             (setq sText (cdr (nth (1+ i) sObj)))
           ) ;_ progn
         ) ;_ if
         (setq i (1+ i))
       ) ;_ repeat
      )
;;;---------------------------------------------------------------------------------------------------------------------
      ((or
         (= tType "spdsLevelMark")                          ;отметка уровня
         (= tType "spdsPlaneLevelMark")                     ;отметка уровня на плане
         (= tType "spdsNodeMark")                           ;обозначение узла
       ) ;_ or
       (setq i 0)
       (repeat (length sObj)
         (if (= (cdr (nth i sObj)) "Text")
           (progn
             (setq sText (cdr (nth (1+ i) sObj)))
           ) ;_ progn
         ) ;_ if
         (setq i (1+ i))
       ) ;_ repeat
      )
;;;---------------------------------------------------------------------------------------------------------------------
      ((= tType "spdsNoteKnot")                             ;узловая выноска 
       (setq sText (cdr (assoc 300 sObj)))
      )
;;;---------------------------------------------------------------------------------------------------------------------
      ((= tType "spdsConstructionLine")                     ;строительная ось
       (setq i 0)
       (repeat (length sObj)
         (if (= (cdr (nth i sObj)) "Axis name")
           (progn
             (setq sText (cdr (nth (1+ i) sObj)))
           ) ;_ progn
         ) ;_ if
         (setq i (1+ i))
       ) ;_ repeat
      )
;;;---------------------------------------------------------------------------------------------------------------------
      ((or
         (= tType "spdsSection")                            ;разрез
         (= tType "spdsView")                               ;вид
       ) ;_ or
        (setq i 0)
        (repeat (length sObj)
          (if (= (cdr (nth i sObj)) "VSPrefix")
            (progn
              (setq sText (strcat
                            (cdr (nth (1+ i) sObj))         ;VSPrefix
                            (cdr (nth (+ 3 i) sObj))        ;VSNumber
                            (if (/= (cdr (nth (+ 5 i) sObj)) "")
                              (progn
                                (strcat
                                  "("
                                  (cdr (nth (+ 5 i) sObj))  ;SheetNumber
                                  ")"
                                ) ;_ strcat
                              ) ;_ progn
                              ""
                            ) ;_ if
                          ) ;_ strcat
              ) ;_ setq
            ) ;_ progn
          ) ;_ if
          (setq i (1+ i))
        ) ;_ repeat
      )
;;;---------------------------------------------------------------------------------------------------------------------
      ((= tType "spdsNoteMultilayer")                       ;выноска для многослойных конструкций
       (setq i 0)
       (repeat (length sObj)
         (if (= (cdr (nth i sObj)) "NoteM_String0")
           (progn
             (setq sText (cdr (nth (1+ i) sObj)))
           ) ;_ progn
         ) ;_ if
         (setq i (1+ i))
       ) ;_ repeat
      )
;;;---------------------------------------------------------------------------------------------------------------------
      ((= tType "spdsNoteSecant")                           ;узловая секущая выноска
       (setq i 0)
       (repeat (length sObj)
         (if (= (cdr (nth i sObj)) "NodeNumber")
           (progn
             (setq sText (strcat
                           (cdr (nth (1+ i) sObj))          ;NodeNumber

                           (if (/= (cdr (nth (+ 3 i) sObj)) "")
                             (progn
                               (strcat
                                 "("
                                 (cdr (nth (+ 3 i) sObj))   ;SheetNumber
                                 ")"
                               ) ;_ strcat
                             ) ;_ progn
                             ""
                           ) ;_ if
                         ) ;_ strcat
             ) ;_ setq
           ) ;_ progn
         ) ;_ if
         (setq i (1+ i))
       ) ;_ repeat
      )
;;;---------------------------------------------------------------------------------------------------------------------
      ((= tType "spdsSquare")                               ;площадь
       (setq i 0)
       (repeat (length sObj)
         (if (= (cdr (nth i sObj)) "Text up")
           (progn
             (setq sText (cdr (nth (1+ i) sObj)))
           ) ;_ progn
         ) ;_ if
         (setq i (1+ i))
       ) ;_ repeat
      )
;;;---------------------------------------------------------------------------------------------------------------------
      ((= tType "spdsCLineOrient")                          ;указатель ориентации
       (setq i 0)
       (repeat (length sObj)
         (if (= (cdr (nth i sObj)) "Marker name")
           (progn
             (setq sText (cdr (nth (1+ i) sObj)))
           ) ;_ progn
         ) ;_ if
         (setq i (1+ i))
       ) ;_ repeat
      )
;;;---------------------------------------------------------------------------------------------------------------------
    ) ;_ cond
  ) ;_ if
  sText
) ;_ defun


(defun TTC_Paste (pasteStr offr / nslLst vlaObj hitPt hitRes Row Column sObj-new sObj)
  (setq errFlag nil)
;;;  (if (not offr) (setq offr "\nКуда вставлять текст? >"))
  (if (setq nslLst (nentsel offr))
    (progn (cond
             ((and (= 4 (length nslLst))                    ;размер
                   (= "DIMENSION" (cdr (assoc 0 (entget (car (last nslLst))))))
              ) ;_ and
              (setq vlaObj (vlax-ename->vla-object (cdr (assoc -1 (entget (car (last nslLst))))))
              ) ;_ setq
              (if (vl-catch-all-error-p
                    (vl-catch-all-apply
                      'vla-put-textoverride
                      (list vlaObj pasteStr)
                    ) ;_ vl-catch-all-apply
                  ) ;_ vl-catch-all-error-p
                (progn
                  (princ "\n Can't paste. Object may be on locked layer. ")
                  (setq errFlag t)
                ) ;_ progn
              ) ;_ if
             )
;;;---------------------------------------------------------------------------------------------------------------------
             ((and (= 4 (length nslLst))                    ;таблица
                   (= "ACAD_TABLE" (cdr (assoc 0 (entget (car (last nslLst))))))
              ) ;_ and
              (setq vlaObj (vlax-ename->vla-object (cdr (assoc -1 (entget (car (last nslLst))))))
                    hitPt  (vlax-3d-point (cadr nslLst))
                    hitRes (vla-hittest
                             vlaObj
                             hitPt
                             (vlax-3d-point '(0.0 0.0 1.0))
                             'Row
                             'Column
                           ) ;_ vla-HitTest
              ) ;_ setq
              (if (= :vlax-true hitRes)
                (progn
                  (if
                    (vl-catch-all-error-p
                      (vl-catch-all-apply
                        'vla-settext
                        (list vlaObj Row Column pasteStr)
                      ) ;_ vl-catch-all-apply
                    ) ;_ vl-catch-all-error-p
                     (progn
                       (princ "\n Can't paste. Object may be on locked layer. ")
                       (setq errFlag t)
                     ) ;_ progn
                  ) ;_ if
                ) ;_ progn
              ) ;_ if
             )
;;;---------------------------------------------------------------------------------------------------------------------
             ((and (= 4 (length nslLst))                    ;блок
                   (= "INSERT" (cdr (assoc 0 (entget (car (last nslLst))))))
              ) ;_ and
              (princ "\nCan't paste to block's DText or MText. ")
              (setq errFlag t)
             )
;;;---------------------------------------------------------------------------------------------------------------------
             ((and (= 2 (length nslLst))                    ;текст, атрибуты
                   (member (cdr (assoc 0 (entget (car nslLst))))
                           '("TEXT" "MTEXT" "ATTRIB" "ATTDEF")
                   ) ;_ member
              ) ;_ and
              (setq vlaObj (vlax-ename->vla-object (car nslLst)))
              (if (vl-catch-all-error-p
                    (vl-catch-all-apply
                      'vla-put-textstring
                      (list vlaObj pasteStr)
                    ) ;_ vl-catch-all-apply
                  ) ;_ vl-catch-all-error-p
                (progn
                  (princ "\nError. Can't paste text. ")
                  (setq errFlag t)
                ) ;_ progn
              ) ;_ if
             )
;;;---------------------------------------------------------------------------------------------------------------------
             ((and (= 2 (length nslLst))
                   (member (cdr (assoc 0 (setq sObj (entget (setq ename (car nslLst))))))
                           '("spdsNotePosition"             ;позиционная выноска
                             "spdsNoteComb"                 ;гребенчатая выноска
                             "spdsNoteChain"                ;цепная выноска
                             "spdsLinearMark"               ;маркировка линейных конструкций
                            )
                   ) ;_ member
              ) ;_ and
              (setq i 0)
              (repeat (length sObj)
                (if (= (cdr (nth i sObj)) "String1")
                  (progn
                    (setq sObj (subst (cons 300 pasteStr) (nth (1+ i) sObj) sObj))
                    (entmod sObj)                           ;изменяем примитив
                  ) ;_ progn
                ) ;_ if
                (setq i (1+ i))
              ) ;_ repeat
             )
;;;---------------------------------------------------------------------------------------------------------------------
             ((and (= 2 (length nslLst))
                   (member (cdr (assoc 0 (setq sObj (entget (setq ename (car nslLst))))))
                           '("spdsLevelMark"                ;отметка уровня
                             "spdsPlaneLevelMark"           ;отметка уровня на плане
                             "spdsNodeMark"                 ;обозначение узла
                            )
                   ) ;_ member
              ) ;_ and
              (setq i 0)
              (repeat (length sObj)
                (if (= (cdr (nth i sObj)) "Text")
                  (progn
                    (setq sObj (subst (cons 300 pasteStr) (nth (1+ i) sObj) sObj))
                    (entmod sObj)                           ;изменяем примитив
                  ) ;_ progn
                ) ;_ if
                (setq i (1+ i))
              ) ;_ repeat
             )
;;;---------------------------------------------------------------------------------------------------------------------
             ((and (= 2 (length nslLst))                    ;узловая выноска
                   (= (cdr (assoc 0 (setq sObj (entget (setq ename (car nslLst)))))) "spdsNoteKnot")
              ) ;_ and
              (setq numb pasteStr                           ;номер узла
                    list-num ""                             ;номер листа
              ) ;_ setq
              (if (setq addr-start (vl-string-search "(" pasteStr))
                (if (setq addr-end (vl-string-search ")" pasteStr))
                  (setq numb     (substr pasteStr 1 addr-start)
                        list-num (substr pasteStr (+ addr-start 2) (- addr-end addr-start 1))
                  ) ;_ setq
                ) ;_ if 
              ) ;_ if
              (setq i 0)
              (repeat (length sObj)
                (setq sObj-new (append sObj-new (list (nth i sObj))))
                (if (= (cdr (nth i sObj)) "NodeNumber")
                  (setq sObj-new (append sObj-new (list (cons 300 numb)))
                        sObj-new (append sObj-new (list (cons 301 "SheetNumber")))
                        sObj-new (append sObj-new (list (cons 300 list-num)))
                        i        (+ i 3)
                  ) ;_ setq
                ) ;_ if
                (setq i (1+ i))
              ) ;_ repeat
              (entmod (vl-remove-if 'null sObj-new))        ;изменяем примитив
             )
;;;---------------------------------------------------------------------------------------------------------------------
;;; 		   ((and (= 2 (length nslLst))              ;строительная ось
;;;                         (= (cdr (assoc 0 (setq sObj (entget (setq ename (car nslLst)))))) "spdsConstructionLine")
;;;                    ) ;_ and
;;;                     (setq i 10)
;;;                     (repeat (length sObj)
;;;                       (cond
;;;                         ((= (type (cdr (nth i sObj))) 'STR)
;;;                          (if (wcmatch (cdr (nth i sObj)) "Строительная ось *")
;;;                            (setq sObj (subst (cons 300 (strcat "Строительная ось " pasteStr)) (nth i sObj) sObj))
;;;                          ) ;_ if
;;;                         )
;;;                         ((= (cdr (nth i sObj)) "Axis name")
;;;                          (setq sObj (subst (cons 300 pasteStr) (nth (1+ i) sObj) sObj))
;;;                         )
;;;                       ) ;_ cond
;;;                       (setq i (1+ i))
;;;                     ) ;_ repeat
;;;                     (entmod sObj)                          ;изменяем примитив
;;;                   )
;;;---------------------------------------------------------------------------------------------------------------------
             ((and (= 2 (length nslLst))
                   (member (cdr (assoc 0 (setq sObj (entget (setq ename (car nslLst))))))
                           '("spdsSection"                  ;разрез
                             "spdsView"                     ;вид
                            )
                   ) ;_ member
              ) ;_ and
              (setq numb pasteStr                           ;номер узла
                    list-num ""                             ;номер листа
              ) ;_ setq
              (if (setq addr-start (vl-string-search "(" pasteStr))
                (if (setq addr-end (vl-string-search ")" pasteStr))
                  (setq numb     (substr pasteStr 1 addr-start)
                        list-num (substr pasteStr (+ addr-start 2) (- addr-end addr-start 1))
                  ) ;_ setq
                ) ;_ if 
              ) ;_ if
              (setq i 0)
              (repeat (length sObj)
                (setq sObj-new (append sObj-new (list (nth i sObj))))
                (if (= (cdr (nth i sObj)) "VSNumber")
                  (setq sObj-new (append sObj-new (list (cons 300 numb)))
                        sObj-new (append sObj-new (list (cons 301 "SheetNumber")))
                        sObj-new (append sObj-new (list (cons 300 list-num)))
                        i        (+ i 3)
                  ) ;_ setq
                ) ;_ if
                (setq i (1+ i))
              ) ;_ repeat
              (entmod (vl-remove-if 'null sObj-new))        ;изменяем примитив
             )
;;;---------------------------------------------------------------------------------------------------------------------
             ((and (= 2 (length nslLst))                    ;выноска для многослойных конструкций
                   (= (cdr (assoc 0 (setq sObj (entget (setq ename (car nslLst)))))) "spdsNoteMultilayer")
              ) ;_ and
              (setq i 0)
              (repeat (length sObj)
                (if (= (cdr (nth i sObj)) "NoteM_String0")
                  (progn
                    (setq sObj (subst (cons 300 pasteStr) (nth (1+ i) sObj) sObj))
                    (entmod sObj)                           ;изменяем примитив
                  ) ;_ progn
                ) ;_ if
                (setq i (1+ i))
              ) ;_ repeat
             )
;;;---------------------------------------------------------------------------------------------------------------------
             ((and (= 2 (length nslLst))                    ;узловая секущая выноска
                   (= (cdr (assoc 0 (setq sObj (entget (setq ename (car nslLst)))))) "spdsNoteSecant")
              ) ;_ and
              (setq numb pasteStr                           ;номер узла
                    list-num ""                             ;номер листа
              ) ;_ setq
              (if (setq addr-start (vl-string-search "(" pasteStr))
                (if (setq addr-end (vl-string-search ")" pasteStr))
                  (setq numb     (substr pasteStr 1 addr-start)
                        list-num (substr pasteStr (+ addr-start 2) (- addr-end addr-start 1))
                  ) ;_ setq
                ) ;_ if 
              ) ;_ if
              (setq i 0)
              (repeat (length sObj)
                (setq sObj-new (append sObj-new (list (nth i sObj))))
                (if (= (cdr (nth i sObj)) "NodeNumber")
                  (setq sObj-new (append sObj-new (list (cons 300 numb)))
                        sObj-new (append sObj-new (list (cons 301 "SheetNumber")))
                        sObj-new (append sObj-new (list (cons 300 list-num)))
                        i        (+ i 3)
                  ) ;_ setq
                ) ;_ if
                (setq i (1+ i))
              ) ;_ repeat
              (entmod (vl-remove-if 'null sObj-new))        ;изменяем примитив
             )
;;;---------------------------------------------------------------------------------------------------------------------
             ((and (= 2 (length nslLst))                   ;площадь
                   (= (cdr (assoc 0 (setq sObj (entget (setq ename (car nslLst)))))) "spdsSquare")
              ) ;_ and
              (setq i 0)
              (repeat (length sObj)
                (if (= (cdr (nth i sObj)) "Text up")
                  (progn
                    (setq sObj (subst (cons 300 pasteStr) (nth (1+ i) sObj) sObj))
                    (entmod sObj)                           ;изменяем примитив
                  ) ;_ progn
                ) ;_ if
                (setq i (1+ i))
              ) ;_ repeat
             )             
;;;---------------------------------------------------------------------------------------------------------------------
             ((and (= 2 (length nslLst))                   ;указатель ориентации
                   (= (cdr (assoc 0 (setq sObj (entget (setq ename (car nslLst)))))) "spdsCLineOrient")
              ) ;_ and
              (setq i 0)
              (repeat (length sObj)
                (if (= (cdr (nth i sObj)) "Marker name")
                  (progn
                    (setq sObj (subst (cons 300 pasteStr) (nth (1+ i) sObj) sObj))
                    (entmod sObj)                           ;изменяем примитив
                  ) ;_ progn
                ) ;_ if
                (setq i (1+ i))
              ) ;_ repeat
             ) 
;;;---------------------------------------------------------------------------------------------------------------------
             (t
              (princ "\nCan't paste. Invalid object. ")
              (setq errFlag t)
             )                                              
           )                                                ; end cond
           t
    )                                                       ; end progn
    nil
  )                                                         ; end if
;;;  (princ)
) ;_ defun



(defun CCT_Str_Echo (paseStr / comStr)
     (if (< 20 (strlen paseStr))
	  (setq	comStr
		    (strcat
			 (substr paseStr 1 17)
			 "..."
		    ) ;_ strcat
	  ) ;_ setq
	  (setq comStr paseStr)
     )						  ; end if
     (princ
	  (strcat "\nText = \"" comStr "\"")
     ) ;_ princ
     (princ)
)						  ; end of CCT_Str_Echo





(defun TTC_MText_Clear (Mtext / Text Str)
     (setq Text "")
     (while (/= Mtext "")
	  (cond
	       ((wcmatch
		     (strcase
			  (setq	Str
				    (substr Mtext 1 2)
			  ) ;_ setq
		     ) ;_ strcase
		     "\\[\\{}`~]"
		) ;_ wcmatch
		(setq Mtext (substr Mtext 3)
		      Text  (strcat Text Str)
		)				  ; end setq
	       )				  ; end condition #1
	       ((wcmatch (substr Mtext 1 1) "[{}]")
		(setq Mtext
			  (substr Mtext 2)
		) ;_ setq
	       )				  ; end condition #2
	       ((wcmatch
		     (strcase
			  (substr Mtext 1 2)
		     ) ;_ strcase
		     "\\[LOP]"
		) ;_ wcmatch
		(setq Mtext (substr Mtext 3))
	       )				  ; end condition #3
	       ((wcmatch
		     (strcase
			  (substr Mtext 1 2)
		     ) ;_ strcase
		     "\\[ACFHQTW]"
		) ;_ wcmatch
		(setq Mtext
			  (substr Mtext
				  (+ 2
				     (vl-string-search ";" Mtext)
				  ) ;_ +
			  ) ;_ substr
		) ;_ setq
	       )				  ; end condition #4
	       ((wcmatch
		     (strcase (substr Mtext 1 2))
		     "\\S"
		) ;_ wcmatch
		(setq Str   (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
		      Text  (strcat Text (vl-string-translate "#^\\" " " Str))
		      Mtext (substr Mtext (+ 4 (strlen Str)))
		)				  ; end setq
;;;		(print Str)
	       )				  ; end condition #5
	       (t
		(setq Text  (strcat Text (substr Mtext 1 1))
		      Mtext (substr Mtext 2)
		) ;_ setq
	       )				  ; end condition #6
	  )					  ; end cond
     )						  ; end while
     Text
) ;_ defun

Просто второй lisp предназначен именно для этого, но у меня он не работает.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
LISP. Вставка в таблицу поля, соотвествующего площади примитива	Profan	Готовые программы	272	06.06.2021 23:12
Сейсмозащита и сейсмоизоляция существующих, построенных зд.	IANationalInformAgentstvo	Прочее. Архитектура и строительство	216	20.01.2015 16:51
Мониторы LCD CRT		Разное	94	17.06.2008 10:51
ЮМОР 2006 =)	Perezz!!	Разное	1122	04.01.2007 00:46

20.07.2008, 20:12
Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу) Red Nova ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ. Торонто Регистрация: 23.10.2007 Сообщений: 1,980 Со школы не ладится у меня с программированием. Все предметы щелкал, а на экзамене по информатике (Visual foxpro) программку типа суммирования столбцов списал у соседа (это уже в университете). Не смотря на эте намерен научится писать программы для Автокада на лиспе, скачал книгу Хювенена, несколько примеров создания программ, но после получасового “смотрения” таких книг мое мышление явно притормаживает. Решил пойти другим путем. Нашел самый короткий лисп из моей коллекции, и прошу программистов с этого форума пошагово объяснить какой символ что означает. Надеюсь на вашу помощь. Код: [Выделить все] (defun c:make-blocks-explodeable (/ adoc) (vl-load-com) (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))) ) ;_ end of vla-startundomark (vlax-for blk_def (vla-get-blocks adoc) (if (and (equal (vla-get-isxref blk_def) :vlax-false) (equal (vla-get-islayout blk_def) :vlax-false) ) ;_ end of and (vl-catch-all-apply '(lambda () (vla-put-explodable blk_def :vlax-true))) ) ;_ end of if ) ;_ end of vlax-for (vla-endundomark adoc) (princ) ) ;_ end of defun _____________________________________________________________________________________________________________ Прошло много лет и топик теперь представляет из себя площадку для обучения азов программирования для многих начинающих. Так что начинающие лиспогрызы приветствуются . __________________ Блог Последний раз редактировалось Red Nova, 12.07.2017 в 05:43.
Просмотров: 1974034