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

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

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

Ответ
Страница 1 из 2 1 2 >
Перейти к новому Перейти к новому  
Поиск в этой теме
Непрочитано 13.07.2023, 12:30 #1
Создание штриховки с помощью лисп
Nikilin
 
Регистрация: 28.10.2019
Сообщений: 57
Товарищи нужна подсказка.
Можно ли создать lisp который будет создавать штриховку в Указанной точке
После создания штриховки lisp должен менять параметры у созданной штриховки на предустановленные.
Пример.
ШАГ 1. Код создает штриховку SOLID на слое 0
ШАГ 2. Код считывает глобальные переменные и создает временные переменные
ШАГ 3. Применение временных переменных к штриховке
(vla-put-PatternType hatch pat)
(vla-put-PatternAngle hatch ang)
(vla-put-PatternScale hatch sc)
(vla-put-Transparency hatch trans)
(vla-put-BackgroundColor hatch bg-color)
(vla-put-Color hatch Color)
(vla-put-Layer hatch layer-name)
(vla-put-Associative hatch assoc)
(vla-put-Annotative hatch annot)
P.S. Вариант с использование Command работает, но не подходит.
Пробовал создание пустой штриховки и замену ее параметров через entmod, не получилось.


Есть прекрасный вариант подобного кода (Приложен ниже в оригинале), но он работает только через выбор замкнутой поллинии. Нужен код именно с указанием внутренней точки.
Код:
[Выделить все] 
 (defun c:TEST ( / ss cnt e hList)
(setq ss nil)
(prompt "\nSelect Closed Polylines to Hatch: ")
(while (not (setq ss (ssget '((0 . "LWPOLYLINE")))))
  (prompt "...invalid selection set.")
);while
(setq cnt (sslength ss))
(while (<= 0 (setq cnt (1- cnt)))
  (setq e (ssname ss cnt))
  (if (setq tmp (CreateHatchList e))
    (setq hList (cons tmp hList))
  );if
);while
(setq hList (reverse hList))
(if (entmakex-hatch hList 0.0 "ANSI31" 1.0)
  (prompt "\nSuccess!")
  (prompt "\n...Failure.")
);if
(princ)
);defun

(defun CreateHatchList (e / i j pList found)
(foreach i (entget e)
  (if (= 10 (car i))
    (progn
      (setq pList (cons i pList))
      (setq found nil j (member i (entget e)))
      (while (and (not found) (< 0 (length j)))
	(if (= 42 (car (car j)))
	  (setq pList (cons (car j) pList) found t)
	);if
	(setq j (cdr j))
      );while
    );progn
  );if
);foreach
(reverse pList)
);defun

(defun entmakex-hatch (l a n s)
 ;; By ElpanovEvgeniy
 ;; L - list point
 ;; A - angle hatch
 ;; N - name pattern
 ;; S - scale
 ;; return - hatch ename
 (entmakex
  (apply
   'append
   (list
    (list '(0 . "HATCH") '(100 . "AcDbEntity") '(410 . "Model") '(100 . "AcDbHatch")
          '(10 0.0 0.0 0.0) '(210 0.0 0.0 1.0)
          (cons 2 n)
          (if (= n "SOLID")
           '(70 . 1)
           '(70 . 0)
          ) ;_  if
          '(71 . 0)
          (cons 91 (length l))
    ) ;_  list
    (apply 'append
           (mapcar '(lambda (a)
                     (apply 'append
                            (list (list '(92 . 7) '(72 . 1) '(73 . 1) (cons 93 (/ (length a) 2)))
				  (mapcar '(lambda (b) b) a)
                                  '((97 . 0))
                            ) ;_  list
                     ) ;_  apply
                    ) ;_  lambda
                   l
           ) ;_  mapcar
    ) ;_  apply
    (list '(75 . 0) '(76 . 1) (cons 52 a) (cons 41 s) '(77 . 0) '(78 . 1) (cons 53 a)
          '(43 . 0.) '(44 . 0.) '(45 . 1.) '(46 . 1.) '(79 . 0) '(47 . 1.) '(98 . 2)
          '(10 0. 0. 0.0) '(10 0. 0. 0.0) '(451 . 0) '(460 . 0.0) '(461 . 0.0) '(452 . 1)
          '(462 . 1.0) '(453 . 2) '(463 . 0.0) '(463 . 1.0) '(470 . "LINEAR")
    ) ;_  list
   ) ;_  list
  ) ;_  apply
 ) ;_  entmakex
) ;_  defun
Буду рад если скажете, можно ли сделать подобный код, или мне надо прекратить поиски, так как lisp не позволяет определить замкнутый контур по внутренней точке.
ИТОГИ ВЕТКИ
Прекрасный код от VVA (ПОСТ №9) (lib:dxf-ent-modify вообще выше всяких похвал удобная штука)
Код:
[Выделить все] 
(defun c:create-hatch-green ( / e1 en pt )
  (vl-load-com)
  (setq e1 (entlast))
  (while (equal e1 (setq en (entlast)))
    (initget 1)
    (setq pt (getpoint "\nУкажите точку внутри замкнутого контура:"))
    (vl-cmdf "_-boundary" pt "")
    )
  (entmakex-hatch 
     (list(mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget en))))
     0
    "SOLID"
    1.)
  (lib:dxf-ent-modify (entlast) 62 3); _62-dxf-код цвета  3-зеленый цвет ACI
  (princ)
)

(defun c:create-hatch ( / e1 en pt )
  (vl-load-com)
  (setq e1 (entlast))
  (while (equal e1 (setq en (entlast)))
    (initget 1)
    (setq pt (getpoint "\nУкажите точку внутри замкнутого контура:"))
    (vl-cmdf "_-boundary" pt "")
    )
  (entmakex-hatch 
     (list(mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget en))))
     0
    "SOLID"
    1.)
  (princ)
)

(defun entmakex-hatch (L a n s)
;; By ElpanovEvgeniy
;; L - list of list point. like ((pt11 pt12 pt13)(pt21 pt22 pt23))
;; A - angle hatch
;; N - name pattern
;; S - scale
;; returne - hatch ename
;;USE
;|
(entmakex-hatch '(((538.794 584.563) (895.629 584.563) (895.629 997.377) (538.794 997.377))
                  ((386.809 345.13) (670.955 345.13) (670.955 855.369) (386.809 855.369))
                 )
                (/ pi 2)
                "ANSI31"
                2.
) ;_  entmakex-hatch
(entmakex-hatch
(list
  (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (car (entsel "\nSelect Polyline:")))))
) ;_  list
(/ pi 2)
"SOLID"
2.
)
(entmakex-hatch
(list
  (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (car (entsel "\nSelect Polyline:")))))
) ;_  list
(/ pi 2)
"_USER" ;_USER DEFINED
2.
)
(entmakex-hatch
(list
  (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (car (entsel "\nSelect Polyline:")))))
) ;_  list
(/ pi 2)
"ANSI32"
2.
)
|;
(entmakex
  (apply
   'append
   (list
    (list '(0 . "HATCH")
          '(100 . "AcDbEntity")
          '(410 . "Model")
          '(100 . "AcDbHatch")
          '(10 0.0 0.0 0.0)
          '(210 0.0 0.0 1.0)
          (cons 2 n)
          (if (= n "SOLID")
           '(70 . 1)
           '(70 . 0)
          ) ;_  if
          '(71 . 0)
          (cons 91 (length l))
    ) ;_  list
    (apply 'append
           (mapcar '(lambda (a)
                     (apply 'append
                            (list (list '(92 . 7) '(72 . 0) '(73 . 1) (cons 93 (length a)))
                                  (mapcar '(lambda (b) (cons 10 b)) a)
                                  '((97 . 0))
                            ) ;_  list
                     ) ;_  apply
                    ) ;_  lambda
                   l
           ) ;_  mapcar
    ) ;_  apply
    (if (= n "SOLID")
     (list '(75 . 0)
          '(76 . 1)
          '(47 . 1.)
          '(98 . 2)
          '(10 0. 0. 0.0)
          '(10 0. 0. 0.0)
          '(450 . 0)
          '(451 . 0)
          '(460 . 0.0)
          '(461 . 0.0)
          '(452 . 0)
          '(462 . 0.0)
          '(453 . 2)
          '(463 . 0.0)
          '(63 . 256)
          '(463 . 1.0)
          '(63 . 256)
          '(470 . "LINEAR")
    ) ;_  list
    (list '(75 . 0)
          '(76 . 1)
          (cons 52 a)
          (cons 41 s)
          '(77 . 0)
          '(78 . 1)
          (cons 53 a)
          '(43 . 0.)
          '(44 . 0.)
          '(45 . 1.)
          '(46 . 1.)
          '(79 . 0)
          '(47 . 1.)
          '(98 . 2)
          '(10 0. 0. 0.0)
          '(10 0. 0. 0.0)
          '(470 . "LINEAR")
    ) ;_  list
      )
   ) ;_  list
  ) ;_  apply
) ;_  entmakex
) ;_  defun
    ;|
  ======================= lib:dxf-ent-modify ===========================================
*    Функция модификации указанного бита примитива
*    Параметры вызова:
*   ent   - примитив, полученный через (entsel), (entlast) etc
            или список полей (entget(entlast))
*   kode   - dxf-код, значение которого надо установить
*   value   - новое значение (0 - поблоку 256 - послою)
*             или bylayer byblock
*    Примеры вызова:
(lib:dxf-ent-modify (entlast) 8 "0")   ; перенести последний примитив на слой 0
(lib:dxf-ent-modify (car(entsel)) 62 10)   ; установить выбранному примитиву цвет 10
*    Возвращаемое значение:
*   примитив с модифицированным dxf-списком. Примитив автоматически перерисовывается.
=======================================================================================
|;
    (defun lib:dxf-ent-modify (ent kode value / ent_list old_dxf new_dxf)
      (if (= (type ent) 'LIST)
        (setq ent_list ent
              ent (cdr (assoc -1 ent_list))
        )
        (setq ent_list (entget ent))
      )
      (if (and
            (member (lib:dxf 0 ent_list) '( "STYLE" "DIMSTYLE" "LAYER"))
            (= kode 100) ;_ end of and
          )
        nil
        (progn
          (setq new_dxf (cons kode
                          (if (and (= kode 62) (= (type value) 'str))
                            (if (= (strcase value) "BYLAYER")
                              256
                              0
                            ) ;_ end of if
                            value
                          ) ;_ end of if
                        ) ;_ end of cons
          ) ;_ end of setq
          (if (not (equal new_dxf (setq old_dxf (assoc kode ent_list))))
            (progn
              (entmod (if old_dxf
                        (subst new_dxf old_dxf ent_list)
                        (append ent_list (list new_dxf))
                      ) ;_ end of if
              ) ;_ end of entmod
              (entupd ent)
              (redraw ent)
            ) ;_ end of progn
          ) ;_ end of if
        ) ;_ end of progn
      ) ;_ end of if
      ent
    ) ;_ end of defun
;|  ! ***************************************************************************
;; !                           lib:dxf
;; ! ***************************************************************************
;; ! Function : Returns the first occurence of a DXF dotted pair from a list
                Возвращает первое вхождение точечной пары DXF списка
;; ! Argument : 'n'     - The DXF code to check / DXF код
;; !            'lst' -    The List to check  / Список
;; ! Returns  : The value of the DXF dotted pair, if it exists else returns nil
                Значение точечной пары, если есть или nil
;; ! ****************************************************************************|;

(defun lib:dxf (n lst)(if (= (type lst) 'ENAME)(setq lst (entget lst)))(cdr (assoc n lst)))
Вариант от koMon пост №8 после доработок по моим хотелкам
Вариант через индексы цвета
Код:
[Выделить все] 
(defun c:DRAW-HATCH (/ object_mark to_be_hatched_object hatch_object)
  (setq PER1 "ТВОЙ СЛОЙ") ;Слой
  (setq PER2 "ANSI31") ;Образец штриховки
  (setq PER3 7) ;Цвет штриховки
  (setq PER4 250) ;Цвет фона штриховки
  (setq PER5 1) ;Масштаб
  (setq PER6 90); Угол в градусах
  
	(setq object_mark (vla-get-count (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object)))))) 
	(while (= object_mark (vla-get-count (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object)))))) 
		(vl-catch-all-apply 'vl-cmdf (list "_-boundary" (getpoint "\nУкажите точку внутри замкнутого контура: ") ""))) ;создаем замкнутый котор
  (setq pline (entlast)) ;записываем полилинию
	(setq to_be_hatched_object (vlax-ename->vla-object (entlast))) 
	(setq hatch_object (vla-addhatch (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object))))
									 achatchpatterntypepredefined
									 PER2 ;Тип штриховки
									 :vlax-false ;аннатотивность выключена
									 achatchobject
					   )
	);создаем штриховка
    (vlax-safearray-put-element (setq outer_loop (vlax-make-safearray vlax-vbobject '(0 . 0))) 0 to_be_hatched_object)
    (vla-appendouterloop hatch_object outer_loop)
    (vla-put-color hatch_object PER3) ;присваиваем цвет
    (vla-put-patternangle hatch_object (* PER6 (/ pi 180))) ;присваиваем угол
    (vla-put-patternscale hatch_object PER5) ;присваиваем масштаб
    (setq col (vla-get-backgroundcolor hatch_object))
    (vla-put-colorindex col PER4)
    (vla-put-backgroundcolor hatch_object col) ;присваиваем цвет фону
    (vla-put-Linetype hatch_object "ByLayer") ;присваиваем тип линии
    (setq LayerName PER1)
    (setq LayerTable (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))
    (setq AddedLayerName (vl-catch-all-apply 'vla-add (list LayerTable LayerName)))
    (vla-put-layer hatch_object LayerName) ;присваиваем слой
    (entdel pline) ;удаляем полилинию 
    (vl-catch-all-apply 'vl-cmdf (list "_hatchtoback" "_regen")) ;перемещаем на задний план и регенерируем
(princ)
)
Вариант через цвета RGB
Код:
[Выделить все] 
(defun c:DRAW-HATCH-RGB (/ object_mark to_be_hatched_object hatch_object)
  (setq PER1 "ТВОЙ СЛОЙ") ;Слой
  (setq PER2 "ANSI31") ;Образец штриховки
  (setq PER3 "100 100 100") ;Цвет штриховки RGB
  (setq PER4 "30 30 30") ;Цвет фона штриховки RGB
  (setq PER5 1) ;Масштаб
  (setq PER6 90); Угол в градусах
  
	(setq object_mark (vla-get-count (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object)))))) 
	(while (= object_mark (vla-get-count (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object)))))) 
		(vl-catch-all-apply 'vl-cmdf (list "_-boundary" (getpoint "\nУкажите точку внутри замкнутого контура: ") ""))) ;создаем замкнутый котор
  (setq pline (entlast)) ;записываем полилинию
	(setq to_be_hatched_object (vlax-ename->vla-object (entlast))) 
	(setq hatch_object (vla-addhatch (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object))))
									 achatchpatterntypepredefined
									 PER2 ;Тип штриховки
									 :vlax-false ;аннатотивность выключена
									 achatchobject
					   )
	);создаем штриховка
    (vlax-safearray-put-element (setq outer_loop (vlax-make-safearray vlax-vbobject '(0 . 0))) 0 to_be_hatched_object)
    (vla-appendouterloop hatch_object outer_loop)

  
    	(setq PER3rgb (read (strcat "(" PER3 ")")))
  	(setq color1 (vlax-create-object (strcat "AutoCAD.AcCmColor." (substr (getvar "ACADVER") 1 2))))
	(vla-SetRGB color1 (car PER3rgb) (cadr PER3rgb) (caddr PER3rgb)) ;ТЕСТИРОВАТЬ!!!!!
	(vla-put-TrueColor hatch_object color1)

    (vla-put-patternangle hatch_object (* PER6 (/ pi 180))) ;присваиваем угол
    (vla-put-patternscale hatch_object PER5) ;присваиваем масштаб


        (setq PER4rgb (read (strcat "(" PER4 ")")))
	(setq col (vlax-create-object (strcat "AutoCAD.AcCmColor." (substr (getvar "ACADVER") 1 2))))
	(vla-setrgb col (car PER4rgb) (cadr PER4rgb) (caddr PER4rgb)) 
	(vla-put-backgroundcolor hatch_object col)

    (vla-put-Linetype hatch_object "ByLayer") ;присваиваем тип линии
    (setq LayerName PER1)
    (setq LayerTable (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))
    (setq AddedLayerName (vl-catch-all-apply 'vla-add (list LayerTable LayerName)))
    (vla-put-layer hatch_object LayerName) ;присваиваем слой
    (entdel pline) ;удаляем полилинию 
    (vl-catch-all-apply 'vl-cmdf (list "_hatchtoback" "_regen")) ;перемещаем на задний план и регенерируем
(princ)
)

Отдельное спасибо ===AAA=== за наводку и Кулик Алексей aka kpblc за код
Код:
[Выделить все] 
 (defun _kpblc-conv-string-to-list (string separator / i)
                                  ;|
*    Функция разбора строки. Возвращает список либо точечную пару.
*    Параметры вызова:
*	string		разбираемая строка
*	separator	символ, используемый в качестве разделителя частей
*    Примеры вызова:
(_kpblc-conv-string-to-list "1;2;3;4;5;6" ";")	;'(1 2 3 4 5 6)
(_kpblc-conv-string-to-list "1;2" ";")		;'(1 2)
*    От рекурсии отказался - при длинных строках возможны вылеты.
|;
  (cond
    ((= string "") nil)
    ((vl-string-search separator string)
     ((lambda (/ pos res)
        (while (setq pos (vl-string-search separator string))
          (setq res    (cons (substr string 1 pos) res)
                string (substr string (+ (strlen separator) 1 pos))
                ) ;_ end of setq
          ) ;_ end of while
        (reverse (cons string res))
        ) ;_ end of lambda
      )
     )
    (t (list string))
    ) ;_ end of cond
  ) ;_ end of defun
Последний раз редактировалось Nikilin, 02.08.2023 в 11:43. Причина: ФИНАЛ ТЕМЫ
Просмотров: 3046
 
Непрочитано 13.07.2023, 15:11
#2
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,809

команда -boundary может помочь найти замкнутый контур по внутренней точке и построить например замкнутую полиллинию по его периметру.
__________________
K Lisp
koMon вне форума  
 
Автор темы   Непрочитано 13.07.2023, 18:54
#3
Nikilin


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

Если я верно понял.
1. Создаем полилинию через -boundary
2. Создаем штриховку в замкнутой полилинии через выбор линии
3. Меняем свойсва штриховки
4. Удаляем полилинию.
Вариант не плохой, осталось сделать XD.
Nikilin вне форума  
 
Непрочитано 13.07.2023, 21:07
#4
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,809

эммм, а XD делать зачем?
__________________
K Lisp
koMon вне форума  
 
Автор темы   Непрочитано 14.07.2023, 07:37
#5
Nikilin


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

Цитата:
Сообщение от koMon Посмотреть сообщение
эммм, а XD делать зачем?
Все не получилось сделать XD

Что то я определенно не знаю
В общем
Код:
[Выделить все] 
 (defun c:create-hatch ()
  (vl-load-com)
  
  ;; 1. Создание полилинии через команду BOUNDARY
  (command "_boundary" pause pause "")
  (setq pline (entlast)) ; Получение последнего созданного объекта (полилинии)
  
  ;; 2. Создание штриховки в полилинии
  (command "_hatch" "_S" pline "" "")
  (setq hatch (entlast)) ; Получение последнего созданного объекта (штриховки)
  
  ;; 3. Изменение слоя, угла, образца, масштаба, аннотативности и ассоциативности штриховки
  (setq layer-name "NEW_LAYER") ; Новое имя слоя для штриховки
  (setq angl (* 74.0 (/ pi 180.0))) ; Новый угол в градусах
  (setq pattern-name "ANSI31") ; Новый образец штриховки
  (setq hatch-scale 5.0) ; Новый масштаб штриховки
  (setq hatch-color 1) ; Новый цвет штриховки
  (setq hatch-annotation 0) ; Новая аннотативность штриховки (Нет)
  (setq hatch-associativity 0) ; Новая ассоциативность штриховки (Нет)
  
  (entmod (append
           (entget hatch)
           (list
            (cons 8 layer-name)
            (cons 52 angl)
            (cons 2 pattern-name)
            (cons 41 hatch-scale)
            (cons 62 hatch-color)
            (cons 71 hatch-annotation)
            (cons 75 hatch-associativity)
            )
           )
          )
  
  ;; 4. Удаление ранее созданной полилинии
  (entdel pline)
  
  (princ)
)

Простой код получается пока, но меняется только цвет и слой. DXF параметры относящиеся к штриховки не меняются.
Еще не могу найти цвет фона и прозрачность
Nikilin вне форума  
 
Непрочитано 14.07.2023, 08:22
#6
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 40,404

Может, стоит все же менять коды, а не дополнять? subst в руки и вперед, если с ActiveX играться не сильно охота )
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 14.07.2023, 08:57
#7
name02


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

Может так попробовать:
Код:
[Выделить все] 
 
(defun c:create-hatch ( / ins_pt hatch)
 (vl-load-com)
 (setq ins_pt (getpoint "\nУкажите точку внутри замкнутого контура:"))
 (command-s "_-hatch" ins_pt "")
 (setq hatch (vlax-ename->vla-object (entlast)))

 и далее твой код из ШАГ 3
)
name02 вне форума  
 
Непрочитано 14.07.2023, 10:24
#8
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,809

Цитата:
Сообщение от Nikilin Посмотреть сообщение
Все не получилось сделать XD
если речь о расширенных данных, которые автокад присоединяет к штриховке...

ну вот vla-вариант для начала.
Код:
[Выделить все] 
 
(defun c:hatch_closed_boundary (/ object_mark to_be_hatched_object hatch_object)
	(setq object_mark (vla-get-count (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object)))))) 
	(while (= object_mark (vla-get-count (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object)))))) 
		(vl-catch-all-apply 'vl-cmdf (list "-boundary" (getpoint "\nУкажите точку внутри замкнутого контура: ") ""))
	)
	(setq to_be_hatched_object (vlax-ename->vla-object (entlast))) 
	(setq hatch_object (vla-addhatch (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object))))
									 achatchpatterntypepredefined
									 "SOLID"
									 :vlax-true
									 achatchobject
					   )
	)
	(vlax-safearray-put-element (setq outer_loop (vlax-make-safearray vlax-vbobject '(0 . 0))) 0 to_be_hatched_object)
	(vla-appendouterloop hatch_object outer_loop)
	(vla-put-color hatch_object 1)
	(princ)
)
__________________
K Lisp
Последний раз редактировалось koMon, 14.07.2023 в 10:31.
koMon вне форума  
 
Непрочитано 19.07.2023, 14:34
#9
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996

Вариант без vla
Код:
[Выделить все] 
(defun c:create-hatch-green ( / e1 en pt )
  (vl-load-com)
  (setq e1 (entlast))
  (while (equal e1 (setq en (entlast)))
    (initget 1)
    (setq pt (getpoint "\nУкажите точку внутри замкнутого контура:"))
    (vl-cmdf "_-boundary" pt "")
    )
  (entmakex-hatch 
     (list(mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget en))))
     0
    "SOLID"
    1.)
  (lib:dxf-ent-modify (entlast) 62 3); _62-dxf-код цвета  3-зеленый цвет ACI
  (princ)
)

(defun c:create-hatch ( / e1 en pt )
  (vl-load-com)
  (setq e1 (entlast))
  (while (equal e1 (setq en (entlast)))
    (initget 1)
    (setq pt (getpoint "\nУкажите точку внутри замкнутого контура:"))
    (vl-cmdf "_-boundary" pt "")
    )
  (entmakex-hatch 
     (list(mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget en))))
     0
    "SOLID"
    1.)
  (princ)
)

(defun entmakex-hatch (L a n s)
;; By ElpanovEvgeniy
;; L - list of list point. like ((pt11 pt12 pt13)(pt21 pt22 pt23))
;; A - angle hatch
;; N - name pattern
;; S - scale
;; returne - hatch ename
;;USE
;|
(entmakex-hatch '(((538.794 584.563) (895.629 584.563) (895.629 997.377) (538.794 997.377))
                  ((386.809 345.13) (670.955 345.13) (670.955 855.369) (386.809 855.369))
                 )
                (/ pi 2)
                "ANSI31"
                2.
) ;_  entmakex-hatch
(entmakex-hatch
(list
  (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (car (entsel "\nSelect Polyline:")))))
) ;_  list
(/ pi 2)
"SOLID"
2.
)
(entmakex-hatch
(list
  (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (car (entsel "\nSelect Polyline:")))))
) ;_  list
(/ pi 2)
"_USER" ;_USER DEFINED
2.
)
(entmakex-hatch
(list
  (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (car (entsel "\nSelect Polyline:")))))
) ;_  list
(/ pi 2)
"ANSI32"
2.
)
|;
(entmakex
  (apply
   'append
   (list
    (list '(0 . "HATCH")
          '(100 . "AcDbEntity")
          '(410 . "Model")
          '(100 . "AcDbHatch")
          '(10 0.0 0.0 0.0)
          '(210 0.0 0.0 1.0)
          (cons 2 n)
          (if (= n "SOLID")
           '(70 . 1)
           '(70 . 0)
          ) ;_  if
          '(71 . 0)
          (cons 91 (length l))
    ) ;_  list
    (apply 'append
           (mapcar '(lambda (a)
                     (apply 'append
                            (list (list '(92 . 7) '(72 . 0) '(73 . 1) (cons 93 (length a)))
                                  (mapcar '(lambda (b) (cons 10 b)) a)
                                  '((97 . 0))
                            ) ;_  list
                     ) ;_  apply
                    ) ;_  lambda
                   l
           ) ;_  mapcar
    ) ;_  apply
    (if (= n "SOLID")
     (list '(75 . 0)
          '(76 . 1)
          '(47 . 1.)
          '(98 . 2)
          '(10 0. 0. 0.0)
          '(10 0. 0. 0.0)
          '(450 . 0)
          '(451 . 0)
          '(460 . 0.0)
          '(461 . 0.0)
          '(452 . 0)
          '(462 . 0.0)
          '(453 . 2)
          '(463 . 0.0)
          '(63 . 256)
          '(463 . 1.0)
          '(63 . 256)
          '(470 . "LINEAR")
    ) ;_  list
    (list '(75 . 0)
          '(76 . 1)
          (cons 52 a)
          (cons 41 s)
          '(77 . 0)
          '(78 . 1)
          (cons 53 a)
          '(43 . 0.)
          '(44 . 0.)
          '(45 . 1.)
          '(46 . 1.)
          '(79 . 0)
          '(47 . 1.)
          '(98 . 2)
          '(10 0. 0. 0.0)
          '(10 0. 0. 0.0)
          '(470 . "LINEAR")
    ) ;_  list
      )
   ) ;_  list
  ) ;_  apply
) ;_  entmakex
) ;_  defun
    ;|
  ======================= lib:dxf-ent-modify ===========================================
*    Функция модификации указанного бита примитива
*    Параметры вызова:
*   ent   - примитив, полученный через (entsel), (entlast) etc
            или список полей (entget(entlast))
*   kode   - dxf-код, значение которого надо установить
*   value   - новое значение (0 - поблоку 256 - послою)
*             или bylayer byblock
*    Примеры вызова:
(lib:dxf-ent-modify (entlast) 8 "0")   ; перенести последний примитив на слой 0
(lib:dxf-ent-modify (car(entsel)) 62 10)   ; установить выбранному примитиву цвет 10
*    Возвращаемое значение:
*   примитив с модифицированным dxf-списком. Примитив автоматически перерисовывается.
=======================================================================================
|;
    (defun lib:dxf-ent-modify (ent kode value / ent_list old_dxf new_dxf)
      (if (= (type ent) 'LIST)
        (setq ent_list ent
              ent (cdr (assoc -1 ent_list))
        )
        (setq ent_list (entget ent))
      )
      (if (and
            (member (lib:dxf 0 ent_list) '( "STYLE" "DIMSTYLE" "LAYER"))
            (= kode 100) ;_ end of and
          )
        nil
        (progn
          (setq new_dxf (cons kode
                          (if (and (= kode 62) (= (type value) 'str))
                            (if (= (strcase value) "BYLAYER")
                              256
                              0
                            ) ;_ end of if
                            value
                          ) ;_ end of if
                        ) ;_ end of cons
          ) ;_ end of setq
          (if (not (equal new_dxf (setq old_dxf (assoc kode ent_list))))
            (progn
              (entmod (if old_dxf
                        (subst new_dxf old_dxf ent_list)
                        (append ent_list (list new_dxf))
                      ) ;_ end of if
              ) ;_ end of entmod
              (entupd ent)
              (redraw ent)
            ) ;_ end of progn
          ) ;_ end of if
        ) ;_ end of progn
      ) ;_ end of if
      ent
    ) ;_ end of defun
;|  ! ***************************************************************************
;; !                           lib:dxf
;; ! ***************************************************************************
;; ! Function : Returns the first occurence of a DXF dotted pair from a list
                Возвращает первое вхождение точечной пары DXF списка
;; ! Argument : 'n'     - The DXF code to check / DXF код
;; !            'lst' -    The List to check  / Список
;; ! Returns  : The value of the DXF dotted pair, if it exists else returns nil
                Значение точечной пары, если есть или nil
;; ! ****************************************************************************|;

(defun lib:dxf (n lst)(if (= (type lst) 'ENAME)(setq lst (entget lst)))(cdr (assoc n lst)))
__________________
Как использовать код на Лиспе читаем здесь
Последний раз редактировалось VVA, 29.07.2023 в 10:35.
VVA вне форума  
 
Автор темы   Непрочитано 28.07.2023, 05:57
#10
Nikilin


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

Не было времени отписаться и испробовать все варианты. Завал был небольшой.
Цитата:
Сообщение от VVA Посмотреть сообщение
Вариант без vla
В общем код из сообщения №9 рабочий как часы. Один момент, не могу найти DXF код для цвета фона штриховки в мануале.
В крайне редких случаях мне нужна заливка фона допустим зеленым цветом.
Цитата:
Сообщение от koMon Посмотреть сообщение
если речь о расширенных данных, которые автокад присоединяет к штриховке...
ну вот vla-вариант для начала.
Прекрасно работающий вариант (сообщение №8). Плохо знаю vla поэтому пока не подтяну, не понятно как поменять цвет фона, угол, масштаб, аннотативность и ассоциативность штриховки.
Последний раз редактировалось Nikilin, 28.07.2023 в 07:39.
Nikilin вне форума  
 
Непрочитано 28.07.2023, 10:57
#11
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,809

Цитата:
Сообщение от Nikilin Посмотреть сообщение
поменять цвет фона
смотря на какой цвет менять, в общем случае у объекта-штриховки есть свойство backgroundcolor -> (vla-put-backgroundcolor hatch_object AcCmColor_object)
Цитата:
Сообщение от Nikilin Посмотреть сообщение
угол
(vla-put-patternangle hatch_object angle_in_radians)
Цитата:
Сообщение от Nikilin Посмотреть сообщение
масштаб
(vla-put-patternscale hatch_object decimal_number)
Цитата:
Сообщение от Nikilin Посмотреть сообщение
аннотативность
надо читать мануалы
Цитата:
Сообщение от Nikilin Посмотреть сообщение
ассоциативность штриховки
предпоследний аргумент у функции создания штриховки
__________________
K Lisp
koMon вне форума  
 
Автор темы   Непрочитано 28.07.2023, 12:50
#12
Nikilin


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

Цитата:
Сообщение от koMon Посмотреть сообщение
смотря на какой цвет менять, в общем случае у объекта-штриховки есть свойство backgroundcolor -> (vla-put-backgroundcolor hatch_object AcCmColor_object)
Я так понимаю просто задать (vla-put-backgroundcolor hatch_object 1) не получится? не могу найти мануал особенностей vla-put-backgroundcolor
С остальным вроде разобрался.
Последний раз редактировалось Nikilin, 28.07.2023 в 12:58.
Nikilin вне форума  
 
Непрочитано 28.07.2023, 13:29
#13
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996

Цитата:
Сообщение от Nikilin Посмотреть сообщение
В общем код из сообщения №9 рабочий как часы. Один момент, не могу найти DXF код для цвета фона штриховки в мануале.
В крайне редких случаях мне нужна заливка фона допустим зеленым цветом.
dxf группа цвета примитива - 62

Обновил #9 Добавил команду create-hatch-green
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 28.07.2023, 14:26
#14
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,809

Цитата:
Сообщение от Nikilin Посмотреть сообщение
Я так понимаю просто задать (vla-put-backgroundcolor hatch_object 1) не получится? не могу найти мануал особенностей vla-put-backgroundcolor
задать индексный цвет можно (vla-put-color hatch_object 1)
соррян, это для цвета штриховки)
BackGroundColor
__________________
K Lisp
koMon вне форума  
 
Автор темы   Непрочитано 28.07.2023, 19:17
#15
Nikilin


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

Цитата:
Сообщение от VVA Посмотреть сообщение
dxf группа цвета примитива - 62

Обновил #9 Добавил команду create-hatch-green
Ругается
Exception has occurred.
no function definition: LIB:'DXF
на строке (member (lib:dxf 0 ent_list) '( "STYLE" "DIMSTYLE" "LAYER"))
Nikilin вне форума  
 
Автор темы   Непрочитано 28.07.2023, 20:26
#16
Nikilin


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

Цитата:
Сообщение от koMon Посмотреть сообщение
задать индексный цвет можно (vla-put-color hatch_object 1)
соррян, это для цвета штриховки)
BackGroundColor
Как итог вот этот код в данном исполнении. Вроде отвечает всем моим хотелкам. Чуть чуть народная солянка, но работает и я рад этому.

Код:
[Выделить все] 
(defun c:hatch_closed_boundary (/ object_mark to_be_hatched_object hatch_object)
	(setq object_mark (vla-get-count (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object)))))) 
	(while (= object_mark (vla-get-count (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object)))))) 
		(vl-catch-all-apply 'vl-cmdf (list "_-boundary" (getpoint "\nУкажите точку внутри замкнутого контура: ") ""))
	)
  (setq pline (entlast))
	(setq to_be_hatched_object (vlax-ename->vla-object (entlast))) 
	(setq hatch_object (vla-addhatch (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object))))
									 achatchpatterntypepredefined
									 "ANSI31"
									 :vlax-false
									 achatchobject
					   )
	)
    (vlax-safearray-put-element (setq outer_loop (vlax-make-safearray vlax-vbobject '(0 . 0))) 0 to_be_hatched_object)
    (vla-appendouterloop hatch_object outer_loop)
    (vla-put-color hatch_object 1)
    (vla-put-patternangle hatch_object (* 90 (/ pi 180)))
    (vla-put-patternscale hatch_object 5)
    (setq col (vla-get-backgroundcolor hatch_object))
    (vla-put-colorindex col 2)
    (vla-put-backgroundcolor hatch_object col)
    (vla-put-Linetype hatch_object "ByLayer")
    (setq LayerName "MyNewLayer")
    (setq LayerTable (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))
    (setq AddedLayerName (vl-catch-all-apply 'vla-add (list LayerTable LayerName)))
    (vla-put-layer hatch_object LayerName)
    (entdel pline)
    (vl-catch-all-apply 'vl-cmdf (list "_hatchtoback" "_regen"))
(princ)
)
Хотя есть вариант доработать так чтобы цвет фона и самой штриховки можно было задавать в виде RGB. Хотя наверное нету смысла усложнять.
Последний раз редактировалось Nikilin, 28.07.2023 в 20:34. Причина: Дополнение
Nikilin вне форума  
 
Непрочитано 29.07.2023, 10:36
#17
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996

Цитата:
Сообщение от Nikilin Посмотреть сообщение
Ругается
поправил
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Автор темы   Непрочитано 29.07.2023, 11:37
#18
Nikilin


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

Выдает всю ту же ошибку. Вполне возможно я что то не так делаю.
Nikilin вне форума  
 
Непрочитано 31.07.2023, 10:41
1 | #19
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996

Nikilin, Я добавил к коду пропущенную функцию, которая используется. Нужно еще раз скопировать и загрузить

Цитата:
Сообщение от Nikilin Посмотреть сообщение
no function definition: LIB:'DXF
на строке (member (lib:dxf 0 ent_list) '( "STYLE" "DIMSTYLE" "LAYER"))
Код:
[Выделить все] 
;|  ! ***************************************************************************
;; !                           lib:dxf
;; ! ***************************************************************************
;; ! Function : Returns the first occurence of a DXF dotted pair from a list
                Возвращает первое вхождение точечной пары DXF списка
;; ! Argument : 'n'     - The DXF code to check / DXF код
;; !            'lst' -    The List to check  / Список
;; ! Returns  : The value of the DXF dotted pair, if it exists else returns nil
                Значение точечной пары, если есть или nil
;; ! ****************************************************************************|;

(defun lib:dxf (n lst)(if (= (type lst) 'ENAME)(setq lst (entget lst)))(cdr (assoc n lst)))
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Автор темы   Непрочитано 31.07.2023, 11:19
#20
Nikilin


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

Цитата:
Сообщение от VVA Посмотреть сообщение
Nikilin, Я добавил к коду пропущенную функцию, которая используется. Нужно еще раз скопировать и загрузить



Код:
[Выделить все] 
;|  ! ***************************************************************************
;; !                           lib:dxf
;; ! ***************************************************************************
;; ! Function : Returns the first occurence of a DXF dotted pair from a list
                Возвращает первое вхождение точечной пары DXF списка
;; ! Argument : 'n'     - The DXF code to check / DXF код
;; !            'lst' -    The List to check  / Список
;; ! Returns  : The value of the DXF dotted pair, if it exists else returns nil
                Значение точечной пары, если есть или nil
;; ! ****************************************************************************|;

(defun lib:dxf (n lst)(if (= (type lst) 'ENAME)(setq lst (entget lst)))(cdr (assoc n lst)))
Все прекрасно работает.

К сожалению на сколько я понял. Могу быть не прав. Цвет заливки изменить через DXF группу нельзя. Или тут тоже есть свои особенности. В общем изучив "http://docs.autodesk.com/ACD/2011/ENU/filesDXF/WS1a9193826455f5ff18cb41610ec0a2e719-7a13.htm", подобную группу я не нашел.
Вариации рабочих LSP добавлю в шапке, немного позже.
Последний раз редактировалось Nikilin, 01.08.2023 в 11:09.
Nikilin вне форума  
Ответ
Страница 1 из 2 1 2 >
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Создание штриховки с помощью лисп

Опции темы Поиск в этой теме
Поиск в этой теме:

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Создание и восстановление профиля Автокад с помощью файла reg olga87 AutoCAD 3 27.12.2020 19:22
Масштаб штриховки, указанный в свойствах, не соответствует масштабу на чертеже wepp AutoCAD 10 31.08.2016 09:16
Макрос VBA Excel для извлечения таблиц из линий, полилиний, текста из DWG файлов в Excel с помощью NanoCAD/AutoCAD JZY Готовые программы 8 14.07.2016 06:31
Как отключить вкладку "Редактор штриховки" при выборе штриховки? EvilBraiN AutoCAD 5 13.07.2016 09:35

Обратная связь - Вверх