[Ingpro]

Возможно подобная программа уже есть...
В этом коде я объединяю две программы, думаю, не совсем правильно (прошу профи поправить), но это работает.
Наверное, не все локальные переменные перечислены и нужно выполнить проверку на наличие стиля текста в чертеже...
Хотя, если стиль текста с таким именем уже существует, то он перезапишется (имя такое же, а шрифт другой).
Часто приходится работать с чужими файлами, где множество стилей текста (особенно файлы из Archicad).
Этот код позволяет создать свой стиль и заменить все тексты (!!! без выбора) на этот стиль.
Чтобы выбрать не весь текст, замените эту строку:
(setq ss (ssget "_X" '((0 . "*TEXT"))) i -1)
на
(setq ss (ssget '((0 . "*TEXT"))) i -1).
А как можно спросить в коде "Выбрать весь текст или выбрать в указанной области"?
В некоторых файлах мтексты приобретают имя нового стиля, но не поддерживают его шрифт, как это можно решить?
Т.е., если после применения кода выделить мтекст, то в свойствах отображается новое имя стиля,
но шрифт остается старый.
В этих мтекстах применено принудительное форматирование и код это не принимает. Если эти мтексты разбить,
то все свойства нового стиля сразу видны.

Код:

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

 (defun c:create-txtst-re ( / *error* ss eo i oldcmd doc)
(vl-load-com)
 (defun *error* (msg)
    (princ)
  ) ;_ end defun
(setq acadApp (vlax-get-Acad-object))
(setq acadDoc (vla-get-ActiveDocument acadApp))
(setq styles (vla-get-textstyles acadDoc))
 
(setq objStyle (vla-add styles "new-txt-style")) ; имя стиля текста / измените на своё имя
(setq ff "C:\\Program Files\\Autodesk\\AutoCAD 2015\\Fonts\\isocpeur.ttf") ; назначить стилю шрифт "isocpeur.ttf" / изм. на свой
;; путь к папке Fonts может быть другим (или к другой папке)
(vla-put-fontfile objStyle ff)

(vla-put-activetextstyle acadDoc objStyle) ; сделать новый стиль активным

;; Заменить все тексты на стиль new-txt-style
(setq ss (ssget "_X" '((0 . "*TEXT"))) i -1)
; (setq ss (ssget '((0 . "*TEXT"))) i -1) ; если надо выбрать не весь текст - раскомментируйте, а предыдущую строку закомментируйте
(setq oldcmd (getvar "cmdecho")) (setvar "cmdecho" 0)
	(while (< (setq i (1+ i)) (sslength ss))
	(setq eo (vlax-ename->vla-object (ssname ss i)))
		(vlax-put eo 'StyleName "new-txt-style")
	)
(vl-cmdf "_-PURGE" "_ST" " " "_N") ; очистить неиспользуемые стили текста
(setvar "cmdecho" oldcmd)
	(princ)
)

[Кулик Алексей aka kpblc]

А что, _.checkstandards уже выпилили из коробки?

[name02]

Сообщение от Ingpro А как можно спросить в коде "Выбрать весь текст или выбрать в указанной области"?

Смотри справку про getkword и initget
Что касается твоего случая, то я бы сделал что-то вроде этого - create-txtst-re.lsp

За основу взял твой файл, немного поправил код и добавил разформатирование StripMtext

Теперь можно выбрать заменять текстовый стиль во всем чертеже или только у выбранных, отменять удаление форматирования объектов

[Ingpro]

Сообщение от Ingpro В этих мтекстах применено принудительное форматирование и код это не принимает

Чтобы отформатировать мтекст такого вида
\A1;\pxql;{\Fcs_gost2304|c204;Какой-то мтекст
чтобы осталось только Какой-то мтекст
можно применить лисп mtextcf.lsp.
Наверное его можно добавить в программу, приведённую выше для удобства...

[name02]

Ты видел это пост - может программы из него тебе помогут?

Сообщение от Ingpro Наверное его можно добавить в программу, приведённую выше для удобства...

Ты не пробовал мою программу запускать?

[Ingpro]

Сообщение от name02 Ты видел это пост - может программы из него тебе помогут?

Да, я иногда использую эти программы...

Сообщение от name02 Ты не пробовал мою программу запускать?

А какую именно?...

[name02]

Из 3-го поста

[Ingpro]

Сообщение от name02 Из 3-го поста

Спасибо, новый стиль создается и можно выбрать "У всех" или "Указать", но мтекст не форматируется и стиль мтекстов не изменяется, мне кажется проще объединить с mtextcf.lsp.
StripMtext v5-0c.lsp довольно сложный, много установок и не всегда корректно работает... 1000 строк кода...
Такой сложный код не нужен, просто отформатировать мтекст, создать слой и заменить все или выбранные...

[name02]

Да, недоработал - при объединении не добавил некоторые функции - теперь все исправил

Файл - create-txtst-re.lsp

Проверяй работу!

[Ingpro]

Сообщение от name02 Да, недоработал - при объединении не добавил некоторые функции - теперь все исправил Файл - create-txtst-re.lsp Проверяй работу!

Спасибо, теперь слой создается, стиль меняется, но форматирования не происходит, новый стиль выглядит так:
\A1;\pxql;{\Fcs_gost2304|c204;Какой-то мтекст
Если не трудно, помогите объединить "ваших" и "наших" с mtextcf.lsp...
Эта конструкция у меня не работает, и ещё пишет про синтаксическую ошибку

Код:

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

 
(defun c:create-txtst-repl ( / *error* MTEXTCF new_txt_style ff acadDoc styles objStyle ss input oldcmd i eo)
(vl-load-com)
 (defun *error* (msg)
    (princ)
  ) ;_ end defun
(setq acadApp (vlax-get-Acad-object))
(setq acadDoc (vla-get-ActiveDocument acadApp))
(setq styles (vla-get-textstyles acadDoc))
 
(setq objStyle (vla-add styles "new-txt-style")) ; имя стиля текста / измените на своё имя
(setq ff "C:\\Program Files\\Autodesk\\AutoCAD 2022\\Fonts\\isocpeur.ttf") ; назначить стилю шрифт "isocpeur.ttf" / изм. на свой
;; путь к папке Fonts может быть другим (или к другой папке)
(vla-put-fontfile objStyle ff)

(vla-put-activetextstyle acadDoc objStyle) ; сделать новый стиль активным

;;Выбор объектов для изменения текстового стиля
  ;; Если нажать Ввод  - то выбираются все объекты
  ;; Если выбрать Указать - то нужно выбрать объекты вручную
  (initget "Всем Указать")
  (setq
    input (getkword
            "\nЗаменить текстовый стиль всех объектов документа или указать несколько [у Всех / Указать]: <у Всех>"
          ) ;_ end getkword
  ) ;_ end setq

  (setq ss
         (cond
           ((null input) (ssget "_X" '((0 . "*TEXT"))))
           ((= input "Всем") (ssget "_X" '((0 . "*TEXT"))))
           ((= input "Указать") (ssget '((0 . "*TEXT"))))
         ) ;_ end cond
  ) ;_ end setq
;***************
;; Заменить все тексты на стиль new-txt-style
;(setq ss (ssget "_X" '((0 . "*TEXT"))) i -1)
; (setq ss (ssget '((0 . "*TEXT"))) i -1) ; если надо выбрать не весь текст - раскомментируйте, а предыдущую строку закомментируйте
(setq oldcmd (getvar "cmdecho")) (setvar "cmdecho" 0)
	(while (< (setq i (1+ i)) (sslength ss))
	(setq eo (vlax-ename->vla-object (ssname ss i)))
		(vlax-put eo 'StyleName "new-txt-style")
	)
(vl-cmdf "_-PURGE" "_ST" " " "_N") ; очистить неиспользуемые стили текста
(setvar "cmdecho" oldcmd)
	(princ)
)

;;; MTextCleanFormat - odstrani formatovani z MTEXTU
;;;
 (defun MTEXTCF ; ??
(defun MTEXTCF0	(txr / pozice delka znak ntx)	; vlastni vykonna funkce, prevadi TXR na NTX
  (setq ntx "")
  (setq pozice 1)
  (setq delka (strlen txr))
  (while (<= pozice delka)
    (setq znak (substr txr pozice 1))
    (if	(= znak "\\")			;pokud je lomitko      
      (progn
 (setq pozice (1+ pozice))			; posunu se na dalsi znak
 (setq znak (substr txr pozice 1))
 (if (or (= znak "{") (= znak "}") (= znak "\\") (= znak "P")); bylo druhe lomitko nebo sloz.zavorka? (nebo P - oprava: VM 31.7.2001)
   (setq ntx (strcat ntx "\\" znak))		; ANO -> vysledny znak kopiruji
   (progn					; NE -> ignoruji znaky az do ";"
     (while (and (/= znak ";") (<= pozice delka))
       (setq pozice (1+ pozice))
       (setq znak (substr txr pozice 1))
       )
     )
   )
 )
      (if (and (/= znak "{") (/= znak "}"))		; pokud neni lomitko ... a neni to ani zavorka
 (setq ntx (strcat ntx znak))			; tak pouze kopiruji vstup
 )
      )
    (setq pozice (1+ pozice))
    )
  (setq ntx ntx)
 )


;(defun c:MTEXTCF (/ ss1 cnt ent en txr ntx isOver)
;  (vl-load-com)
  (setq ss1 (ssget '((-4 . "<OR")(0 . "MTEXT")(0 . "DIMENSION")(0 . "MULTILEADER")(-4 . "OR>"))))   ; vybereme MTEXTy a DIMy
  (if (null ss1)					; vybralo se neco?
    (progn
      (princ "nevybral jste zadny MTEXT (no MTEXT in selection)")
      (quit)
      )
    )

  (setq cnt 0)
  (repeat (sslength ss1)				; cyklus pres vyberovou mno inu
    (setq en (entget (setq ent (ssname ss1 cnt))))			; nactu entitu
	(if (setq isOver (= (cdr (assoc 0 en)) "DIMENSION"))
     (setq txr (vlax-get (vlax-ename->vla-object ent) 'TextOverride))	; vypreparuju text
     (setq txr (vlax-get (vlax-ename->vla-object ent) 'TextString))		; vypreparuju text (MText+MLeader = TextString, Dim = TextOverride)
	);if
    (setq ntx (mtextcf0 txr))				; provedu vlastni konverzi
    (if	(/= txr ntx)					; pokud se text zmenil
	 (if isOver
	  (vlax-put (vlax-ename->vla-object ent) 'TextOverride ntx)		; -> tak ho vymenim ve vykresove databazi
      (vlax-put (vlax-ename->vla-object ent) 'TextString ntx)		; -> tak ho vymenim ve vykresove databazi
	 );if
    )
    (setq cnt (1+ cnt))					; posunu se na dalsi entitu
    )
  (princ)
  )

;;; end of file

Чем удобен лисп mtextcf.lsp, он удаляет форматирование типа \A1;\pxql;{\, нет лишних вопросов...

[name02]

Давай по-порядку:
1 В моем файле (да и в твоем тоже) прописан адрес к файлу со шрифтом. Ты его поменял на корректный адрес (у меня Автокад 2022, поэтому я исправил адрес для себя)?
2 StripMtext может удалять различное форматирование из всех объектов автокада. В моей программе выбираются только текстовые объекты и из них удаляется только форматирование текста (ключ "F").
В твоей строке есть еще и другие виды форматирования:

\A1 - надстрочный текст
\pxql - выравнивание по левому краю
|c204 - курсив

При данной настройке программы они не удаляются. Если надо убрать все виды форматирования - замени в строке 13 (setq formats_to_remove "F") на (setq formats_to_remove "*")
И почитай справку по ключам для StripMtext - там написано, какой ключ за что отвечает и как их записывать для работы программы.

Кстати, пока тестировал, обнаружил, что оригинальная программа не удаляла зачеркнутый текст. Сделал соответствующие изменения - теперь удаляет
Файл - create-txtst-re.lsp

[Ingpro]

Сообщение от name02 Давай по-порядку: 1 В моем файле (да и в твоем тоже) прописан адрес к файлу со шрифтом. Ты его поменял на корректный адрес (у меня Автокад 2022, поэтому я исправил адрес для себя)?

У себя я исправляю на 2015

Сообщение от name02 2 StripMtext может удалять различное форматирование из всех объектов автокада. В моей программе выбираются только текстовые объекты и из них удаляется только форматирование текста (ключ "F").

Мне нужно и текст и мтекст
Не очень хочется комбинироваться с StripMtext, там много ненужного... Хочется чего-нибудь попроще

[name02]

Как раз минус твоей удалялки - она удаляет абсолютно все форматирование, которое может быть и не надо удалять (не проверял, но судя по коду это так)

Сообщение от Ingpro Не очень хочется комбинироваться с StripMtext, там много ненужного... Хочется чего-нибудь попроще

Не стоит из-за этого расстраиваться. Все работает, места не занимает - пользуйся на здоровье!

[Ingpro]

Сообщение от name02 Не стоит из-за этого расстраиваться. Все работает, места не занимает - пользуйся на здоровье!

Хорошо, спасибо за помощь.
Интересно, что этот лисп на чешском работает (разве переменные не надо переводить на англ.?):

Код:

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

 (defun MTEXTCF0	(txr / pozice delka znak ntx)	; vlastni vykonna funkce, prevadi TXR na NTX
  (setq ntx "")
  (setq pozice 1)
  (setq delka (strlen txr))

[name02]

Сообщение от Ingpro Интересно, что этот лисп на чешском работает (разве переменные не надо переводить на англ.?):

Сейчас вообще будет взрыв мозга:

Код:

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

 (defun МОЯ_ПРОГРАММА (слагаемое1 слагаемое2 / сумма )

  (setq сумма (+ слагаемое1 слагаемое2))

  (setq МОЯ_ПРОГРАММА сумма)

) ;_ end defun