LISP. Очистка форматирования многострочного текста (Страница 2 из 2)

;|=============================================================================
*    Функция сносит форматирование многострочного текста. Удаляются символы "{"
* и "}", поскольку именно символ "}" является окончанием применения определенного
* фонта. Удаляются наборы типа {fTimes New Roman|b0|i0|c204|p18; и т.п.
*    Параметры вызова:
*  string-to-normalize  — строка, которую надо нормализовать
*  settings - настройки в виде списка строк ("F" "Q" и т.п.)
*  где F - шрифт;
*      Q - угол наклона;
*      T - межсимвольное расстояние;
*      W - ширина символов;
*      H - высота.
*    Примеры вызова:
(_kpblc-clear-mtext (cdr (assoc 1 (entget(car(entsel))))) '("F" "T"))
  ; для выбранного многострочного текста очищает форматирование.
=============================================================================|;
(defun _kpblc-clear-mtext (string-to-normalize settings    / tmpsettings
               sub_string sub_pos left_string right_string
              )
  (setq    tmpsettings
     (apply    'append
        (mapcar
          '(lambda (a)
             (list (strcat "{" a)
               (strcat "\\" a)
               (strcat "{\\" a)
             ) ;_ list
           ) ;_ lambda
          settings
        ) ;_ mapcar
     ) ;_ apply
  ) ;_ setq
  (if (vl-member-if
    '(lambda (a)
       (setq
         sub_pos (vl-string-search a (strcase string-to-normalize))
       ) ;_ setq
     ) ;_ lambda
    tmpsettings
      ) ;_ vl-member-if
    (progn
      (setq left_string            ;все, что до "{"
         (vl-string-trim
           "{"
           (substr
         string-to-normalize
         1
         (vl-string-position
           (ascii "\\")
           string-to-normalize
           sub_pos
         ) ;_ end of vl-string-position
           ) ;_ end of substr
         ) ;_ end of vl-string-trim
      ) ;_ end of setq
      (if (vl-string-position
        (ascii ";")
        string-to-normalize
        sub_pos
      ) ;_ end of vl-string-position
    (setq right_string        ;все, что между {f и ;
           (substr
         string-to-normalize
         (+ (vl-string-position
              (ascii ";")
              string-to-normalize
              sub_pos
            ) ;_ end of vl-string-position
            2
         ) ;_ end of +
           ) ;_ end of substr
    ) ;_ end of setq
    (setq right_string "")
      ) ;_ end of if
      (_kpblc-clear-mtext
    (strcat left_string right_string)
    settings
      ) ;_ _kpblc-clear-mtext
    ) ;_ end of progn
    string-to-normalize
  ) ;_ end of if
) ;_ end of defun
;|=============================================================================
*    Функция удаления форматирования на выбранных элементах
=============================================================================|;
;;;Глобальные переменные:
;;;unf-font
;;;unf-oblique
;;;unf-width
;;;unf-distbetween
;;;unf-height
;;;unf-settingsdefined
(defun c:unf-mtext (/ selset item _answer_ layer_set_list
            layer_status_list *error* col row
            _kpblc-layer-status-restore    _kpblc-layer-status-save
            list-of-perem list-of-label    settings
           )
;;;Настройки
  (setq    list-of-perem
              '(unf-font unf-oblique unf-width unf-distbetween unf-height)
    list-of-label '("Шрифт"    "Угол наклона" "Ширина"
            "Межсимвольное расстояние" "Высота"
               )
  ) ;_ setq
  (if (not unf-settingsdefined)
    (progn
      (mapcar 'set list-of-perem '(t t nil nil nil))
      (setq unf-settingsdefined t)
    ) ;_ progn
  ) ;_ if
;;;
  ;; Локальные функции
  ;; Обработчик ошибок
  (defun *error* (msg)
    (princ msg)
    ;; Завершение активных команд
    (while (/= (getvar "cmdactive") 0) (command))
    (_kpblc-layer-status-restore)
    (vla-endundomark *kpblc-activedoc*)
  ) ;_ end of defun
  (defun _kpblc-layer-status-restore ()
    (foreach item layer_status_list
      (if (not (vlax-erased-p (car item)))
    (vl-catch-all-apply
      '(lambda ()
         (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
         (vla-put-freeze
           (car item)
           (cdr (assoc "freeze" (cdr item)))
         ) ;_ vla-put-freeze
       ) ;_ end of lambda
    ) ;_ end of vl-catch-all-apply
      ) ;_ end of if
    ) ;_ end of foreach
    (setq layer_status_list nil)
  ) ;_ end of defun
  (defun _kpblc-layer-status-save ()
    (setq layer_status_list nil)
    (vlax-for item (vla-get-layers *kpblc-activedoc*)
      (setq layer_status_list
         (cons
           (list item
             (cons "freeze" (vla-get-freeze item))
             (cons "lock" (vla-get-lock item))
           ) ;_ end of cons
           layer_status_list
         ) ;_ end of cons
      ) ;_ end of setq
      (vla-put-lock item :vlax-false)
      (vl-catch-all-apply
    '(lambda () (vla-put-freeze item :vlax-false))
      ) ;_ vl-catch-all-apply
    ) ;_ end of vlax-for
  ) ;_ end of defun
  ;; Конец локальных функций
  ;; Запросы опций
  (vl-load-com)
  (while
    (progn (initget "вЕсь Выбор Настройки _ All Selection Options")
       (= (setq _answer_
             (getkword
               "Обрабатывать объем [вЕсь файл/Выбор/Настройки] ? <Весь файл> : "
             ) ;_ end of getkword
          ) ;_ end of setq
          "Options"
       ) ;_ =
    ) ;_ =
     (if (setq tmp
        (ks-flags-window
          "Удаление форматирования"
          (mapcar 'cons list-of-label (mapcar 'eval list-of-perem))
        ) ;_ KS-FLAGS-WINDOW
     ) ;_ setq
       (mapcar 'set list-of-perem tmp)
     ) ;_ if
  ) ;_ while
;;;Запись списка настроек
  (setq settings nil)
  (if unf-font
    (setq settings (cons "F" settings))
  ) ;_ if
  (if unf-oblique
    (setq settings (cons "Q" settings))
  ) ;_ if
  (if unf-width
    (setq settings (cons "W" settings))
  ) ;_ if
  (if unf-distbetween
    (setq settings (cons "T" settings))
  ) ;_ if
  (if unf-height
    (setq settings (cons "H" settings))
  ) ;_ if
;;;
  (or *kpblc-activedoc*
      (setq *kpblc-activedoc*
         (vla-get-activedocument (vlax-get-acad-object))
      ) ;_ setq
  ) ;_ or
  (vla-startundomark *kpblc-activedoc*)
  (if (= _answer_ "Selection")
    (setq selset (ssget '((0 . "MTEXT,ACAD_TABLE"))))
    (setq selset (ssget "_X" '((0 . "MTEXT,ACAD_TABLE"))))
  ) ;_ end of if
  (_kpblc-layer-status-save)
  (while (and selset (> (sslength selset) 0))
    (setq item (ssname selset 0))
    (ssdel item selset)
    (setq item (vlax-ename->vla-object item))
    (if    (= (vla-get-objectname item) "AcDbTable")
      (progn
    (vla-put-regeneratetablesuppressed item :vlax-true)
    (setq col 0)
    (repeat    (vla-get-columns item)
      (setq row 0)
      (repeat (vla-get-rows item)
        (vla-settext
          item
          row
          col
          (_kpblc-clear-mtext (vla-gettext item row col) settings)
        ) ;_ vla-settext
        (setq row (1+ row))
      ) ;_ repeat
      (setq col (1+ col))
    ) ;_ repeat
    (vla-put-regeneratetablesuppressed item :vlax-false)
    (vla-update item)
      ) ;_ progn
      (if (vlax-property-available-p item "TextString")
    (vlax-put-property
      item
      "TextString"
      (_kpblc-clear-mtext
        (vlax-get-property item "TextString")
        settings
      ) ;_ _kpblc-clear-mtext
    ) ;_ vlax-put-property
      ) ;_ if
    ) ;_ if
  ) ;_ end of while
  (_kpblc-layer-status-restore)
  (vla-endundomark *kpblc-activedoc*)
) ;_ end of defun
;;;Корнеев С.Н.
;;;KorneevSGASU@rambler.ru
;;;Функция для вывода диалога со списком флагов
;;;<main-label> - название окна
;;;<list-of-params> - список вида '(("Имя параметра" . <T/nil>)...)
;;;Возвращает список вида '(T T nil и т.д.)
;;;Cancel - возвращает nil.
;;;T - флаг включен
;;;nil - выключен
(defun ks-flags-window (main-label list-of-params / filename fid i
            dcl_id list-of-value
               )
;;;Создание временного файла диалового окна
  (setq    filename (vl-filename-mktemp "dcl" "" ".dcl")
    fid     (open filename "w")
    i     1
  ) ;_ setq
  (write-line
    (strcat "tmp: dialog {label = \"" main-label "\";")
    fid
  ) ;_ write-line
  (foreach a list-of-params
    (write-line
      (strcat ":toggle{label = \""
          (car a)
          "\"; key = \"k"
          (itoa i)
          "\";}"
      ) ;_ strcat
      fid
    ) ;_ write-line
    (setq i (1+ i))
  ) ;_ foreach
  (write-line "ok_cancel;}" fid)
  (close fid)
;;;Файл создан
;;;Открытие диалога
  (setq dcl_id (load_dialog filename))
  (new_dialog "tmp" dcl_id)
;;;Задание значений флагам
  (setq i 1)
  (foreach a list-of-params
    (set_tile (strcat "k" (itoa i))
          (if (cdr a)
        "1"
        "0"
          ) ;_ if
    ) ;_ set_tile
    (setq i (1+ i))
  ) ;_ foreach
  (action_tile
    "accept"
    "(setq i 1)
  (repeat (length list-of-params)
    (setq list-of-value (cons (get_tile (strcat \"k\" (itoa i))) list-of-value)
      i (1+ i)))
    (DONE_DIALOG)"
  ) ;_ action_tile
  (start_dialog)
  (unload_dialog dcl_id)
  (mapcar '(lambda (a)
         (if (= a "1")
           t
         ) ;_ if
       ) ;_ lambda
      (reverse list-of-value)
  ) ;_ mapcar
) ;_ defun

;|=============================================================================
*    Функция сносит форматирование многострочного текста. Удаляются символы "{"
* и "}", поскольку именно символ "}" является окончанием применения определенного
* фонта. Удаляются наборы типа {fTimes New Roman|b0|i0|c204|p18; и т.п.
*    Параметры вызова:
*  string-to-normalize  — строка, которую надо нормализовать
*  settings - настройки в виде списка строк ("F" "Q" и т.п.)
*  где F - шрифт;
*      Q - угол наклона;
*      T - межсимвольное расстояние;
*      W - ширина символов;
*      H - высота.
*    Примеры вызова:
(_kpblc-clear-mtext (cdr (assoc 1 (entget(car(entsel))))) '("F" "T"))
  ; для выбранного многострочного текста очищает форматирование.
=============================================================================|;
(defun _kpblc-clear-mtext (string-to-normalize settings    / tmpsettings
               sub_string sub_pos left_string right_string
              )
  (setq    tmpsettings
     (apply    'append
        (mapcar
          '(lambda (a)
             (list (strcat "{" a)
               (strcat "\\" a)
               (strcat "{\\" a)
             ) ;_ list
           ) ;_ lambda
          settings
        ) ;_ mapcar
     ) ;_ apply
  ) ;_ setq
  (if (vl-member-if
    '(lambda (a)
       (setq
         sub_pos (vl-string-search a (strcase string-to-normalize))
       ) ;_ setq
     ) ;_ lambda
    tmpsettings
      ) ;_ vl-member-if
    (progn
      (setq left_string            ;все, что до "{"
         (vl-string-trim
           "{"
           (substr
         string-to-normalize
         1
         (vl-string-position
           (ascii "\\")
           string-to-normalize
           sub_pos
         ) ;_ end of vl-string-position
           ) ;_ end of substr
         ) ;_ end of vl-string-trim
      ) ;_ end of setq
      (if (vl-string-position
        (ascii ";")
        string-to-normalize
        sub_pos
      ) ;_ end of vl-string-position
    (setq right_string        ;все, что между {f и ;
           (substr
         string-to-normalize
         (+ (vl-string-position
              (ascii ";")
              string-to-normalize
              sub_pos
            ) ;_ end of vl-string-position
            2
         ) ;_ end of +
           ) ;_ end of substr
    ) ;_ end of setq
    (setq right_string "")
      ) ;_ end of if
      (_kpblc-clear-mtext
    (strcat left_string right_string)
    settings
      ) ;_ _kpblc-clear-mtext
    ) ;_ end of progn
    string-to-normalize
  ) ;_ end of if
) ;_ end of defun
;|=============================================================================
*    Функция удаления форматирования на выбранных элементах
=============================================================================|;
;;;Глобальные переменные:
;;;unf-font
;;;unf-oblique
;;;unf-width
;;;unf-distbetween
;;;unf-height
;;;unf-settingsdefined
(defun c:unf-mtext (/ selset item _answer_ layer_set_list
            layer_status_list *error* col row
            _kpblc-layer-status-restore    _kpblc-layer-status-save
            list-of-perem list-of-label    settings
           )
;;;Настройки
  (setq    list-of-perem
              '(unf-font unf-oblique unf-width unf-distbetween unf-height)
    list-of-label '("Шрифт"    "Угол наклона" "Ширина"
            "Межсимвольное расстояние" "Высота"
               )
  ) ;_ setq
  (if (not unf-settingsdefined)
    (progn
      (mapcar 'set list-of-perem '(t t nil nil nil))
      (setq unf-settingsdefined t)
    ) ;_ progn
  ) ;_ if
;;;
  ;; Локальные функции
  ;; Обработчик ошибок
  (defun *error* (msg)
    (princ msg)
    ;; Завершение активных команд
    (while (/= (getvar "cmdactive") 0) (command))
    (_kpblc-layer-status-restore)
    (vla-endundomark *kpblc-activedoc*)
  ) ;_ end of defun
  (defun _kpblc-layer-status-restore ()
    (foreach item layer_status_list
      (if (not (vlax-erased-p (car item)))
    (vl-catch-all-apply
      '(lambda ()
         (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
         (vla-put-freeze
           (car item)
           (cdr (assoc "freeze" (cdr item)))
         ) ;_ vla-put-freeze
       ) ;_ end of lambda
    ) ;_ end of vl-catch-all-apply
      ) ;_ end of if
    ) ;_ end of foreach
    (setq layer_status_list nil)
  ) ;_ end of defun
  (defun _kpblc-layer-status-save ()
    (setq layer_status_list nil)
    (vlax-for item (vla-get-layers *kpblc-activedoc*)
      (setq layer_status_list
         (cons
           (list item
             (cons "freeze" (vla-get-freeze item))
             (cons "lock" (vla-get-lock item))
           ) ;_ end of cons
           layer_status_list
         ) ;_ end of cons
      ) ;_ end of setq
      (vla-put-lock item :vlax-false)
      (vl-catch-all-apply
    '(lambda () (vla-put-freeze item :vlax-false))
      ) ;_ vl-catch-all-apply
    ) ;_ end of vlax-for
  ) ;_ end of defun
  ;; Конец локальных функций
  ;; Запросы опций
  (vl-load-com)
  (while
    (progn (initget "вЕсь Выбор Настройки _ All Selection Options")
       (= (setq _answer_
             (getkword
               "Обрабатывать объем [вЕсь файл/Выбор/Настройки] ? <Весь файл> : "
             ) ;_ end of getkword
          ) ;_ end of setq
          "Options"
       ) ;_ =
    ) ;_ =
     (if (setq tmp
        (ks-flags-window
          "Удаление форматирования"
          (mapcar 'cons list-of-label (mapcar 'eval list-of-perem))
        ) ;_ KS-FLAGS-WINDOW
     ) ;_ setq
       (mapcar 'set list-of-perem tmp)
     ) ;_ if
  ) ;_ while
;;;Запись списка настроек
  (setq settings nil)
  (if unf-font
    (setq settings (cons "F" settings))
  ) ;_ if
  (if unf-oblique
    (setq settings (cons "Q" settings))
  ) ;_ if
  (if unf-width
    (setq settings (cons "W" settings))
  ) ;_ if
  (if unf-distbetween
    (setq settings (cons "T" settings))
  ) ;_ if
  (if unf-height
    (setq settings (cons "H" settings))
  ) ;_ if
;;;
  (or *kpblc-activedoc*
      (setq *kpblc-activedoc*
         (vla-get-activedocument (vlax-get-acad-object))
      ) ;_ setq
  ) ;_ or
  (vla-startundomark *kpblc-activedoc*)
  (if (= _answer_ "Selection")
    (setq selset (ssget '((0 . "MTEXT,ACAD_TABLE,DIMENSION"))))
    (setq selset (ssget "_X" '((0 . "MTEXT,ACAD_TABLE,DIMENSION"))))
  ) ;_ end of if
  (_kpblc-layer-status-save)
  (while (and selset (> (sslength selset) 0))
    (setq item (ssname selset 0))
    (ssdel item selset)
    (setq item (vlax-ename->vla-object item))
    (if    (= (vla-get-objectname item) "AcDbTable")
      (progn
    (vla-put-regeneratetablesuppressed item :vlax-true)
    (setq col 0)
    (repeat    (vla-get-columns item)
      (setq row 0)
      (repeat (vla-get-rows item)
        (vla-settext
          item
          row
          col
          (_kpblc-clear-mtext (vla-gettext item row col) settings)
        ) ;_ vla-settext
        (setq row (1+ row))
      ) ;_ repeat
      (setq col (1+ col))
    ) ;_ repeat
    (vla-put-regeneratetablesuppressed item :vlax-false)
    (vla-update item)
      ) ;_ progn
      (foreach a '("TextString" "TextOverride")
    (if (vlax-property-available-p item a)
      (vlax-put-property
        item
        a
        (_kpblc-clear-mtext
          (vlax-get-property item a)
          settings
        ) ;_ _kpblc-clear-mtext
      ) ;_ vlax-put-property
    ) ;_ if
      ) ;_ foreach
    ) ;_ if
  ) ;_ end of while
  (_kpblc-layer-status-restore)
  (vla-endundomark *kpblc-activedoc*)
) ;_ end of defun
;;;ks-flags-window
;;;Корнеев С.Н.
;;;KorneevSGASU@rambler.ru
;;;Функция для вывода диалога со списком флагов
;;;<main-label> - название окна
;;;<list-of-params> - список вида '(("Имя параметра" . <T/nil>)...)
;;;Возвращает список вида '(T T nil и т.д.)
;;;Cancel - возвращает nil.
;;;T - флаг включен
;;;nil - выключен
(defun ks-flags-window (main-label list-of-params / filename fid i
            dcl_id list-of-value *error*
               )
  (defun *error* (msg)
    (vl-catch-all-apply 'close (list fid))
    (vl-file-delete filename)
    (princ msg)
  ) ;_ defun
;;;Создание временного файла диалового окна
  (setq    filename (vl-filename-mktemp "dcl" "" ".dcl")
    fid     (open filename "w")
    i     1
  ) ;_ setq
  (write-line
    (strcat "tmp: dialog {label = \"" main-label "\";")
    fid
  ) ;_ write-line
  (foreach a list-of-params
    (write-line
      (strcat ":toggle{label = \""
          (car a)
          "\"; key = \"k"
          (itoa i)
          "\";}"
      ) ;_ strcat
      fid
    ) ;_ write-line
    (setq i (1+ i))
  ) ;_ foreach
  (write-line "ok_cancel;}" fid)
  (close fid)
;;;Файл создан
;;;Открытие диалога
  (setq dcl_id (load_dialog filename))
  (new_dialog "tmp" dcl_id)
;;;Задание значений флагам
  (setq i 1)
  (foreach a list-of-params
    (set_tile (strcat "k" (itoa i))
          (if (cdr a)
        "1"
        "0"
          ) ;_ if
    ) ;_ set_tile
    (setq i (1+ i))
  ) ;_ foreach
  (action_tile
    "accept"
    "(setq i 1)
  (repeat (length list-of-params)
    (setq list-of-value (cons (get_tile (strcat \"k\" (itoa i))) list-of-value)
      i (1+ i)))
    (DONE_DIALOG)"
  ) ;_ action_tile
  (start_dialog)
  (unload_dialog dcl_id)
  (vl-file-delete filename)
  (mapcar '(lambda (a)
         (if (= a "1")
           t
         ) ;_ if
       ) ;_ lambda
      (reverse list-of-value)
  ) ;_ mapcar
) ;_ defun