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

Nikilin · 13.07.2023, 12:30

Товарищи нужна подсказка.
Можно ли создать 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

koMon · 13.07.2023, 15:11

команда -boundary может помочь найти замкнутый контур по внутренней точке и построить например замкнутую полиллинию по его периметру.

Nikilin · 13.07.2023, 18:54

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

koMon · 13.07.2023, 21:07

эммм, а XD делать зачем?

Nikilin · 14.07.2023, 07:37

Цитата:

Сообщение от 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 параметры относящиеся к штриховки не меняются.
Еще не могу найти цвет фона и прозрачность

Кулик Алексей aka kpblc · 14.07.2023, 08:22

Может, стоит все же менять коды, а не дополнять? subst в руки и вперед, если с ActiveX играться не сильно охота )

name02 · 14.07.2023, 08:57

Может так попробовать:

Код:

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

 
(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
)

koMon · 14.07.2023, 10:24

Цитата:

Сообщение от 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)
)

VVA · 19.07.2023, 14:34

Вариант без 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)))

Nikilin · 28.07.2023, 05:57

Не было времени отписаться и испробовать все варианты. Завал был небольшой.

Цитата:

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

Вариант без vla

В общем код из сообщения №9 рабочий как часы. Один момент, не могу найти DXF код для цвета фона штриховки в мануале.
В крайне редких случаях мне нужна заливка фона допустим зеленым цветом.

Цитата:

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

если речь о расширенных данных, которые автокад присоединяет к штриховке...
ну вот vla-вариант для начала.

Прекрасно работающий вариант (сообщение №8). Плохо знаю vla поэтому пока не подтяну, не понятно как поменять цвет фона, угол, масштаб, аннотативность и ассоциативность штриховки.

koMon · 28.07.2023, 10:57

Цитата:

Сообщение от 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

ассоциативность штриховки

предпоследний аргумент у функции создания штриховки

Nikilin · 28.07.2023, 12:50

Цитата:

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

смотря на какой цвет менять, в общем случае у объекта-штриховки есть свойство backgroundcolor -> (vla-put-backgroundcolor hatch_object AcCmColor_object)

Я так понимаю просто задать (vla-put-backgroundcolor hatch_object 1) не получится? не могу найти мануал особенностей vla-put-backgroundcolor
С остальным вроде разобрался.

VVA · 28.07.2023, 13:29

Цитата:

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

В общем код из сообщения №9 рабочий как часы. Один момент, не могу найти DXF код для цвета фона штриховки в мануале.
В крайне редких случаях мне нужна заливка фона допустим зеленым цветом.

dxf группа цвета примитива - 62

Обновил #9 Добавил команду create-hatch-green

koMon · 28.07.2023, 14:26

Цитата:

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

Я так понимаю просто задать (vla-put-backgroundcolor hatch_object 1) не получится? не могу найти мануал особенностей vla-put-backgroundcolor

задать индексный цвет можно (vla-put-color hatch_object 1)
соррян, это для цвета штриховки)
BackGroundColor

Nikilin · 28.07.2023, 19:17

Цитата:

Сообщение от 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

Цитата:

Сообщение от 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. Хотя наверное нету смысла усложнять.

VVA · 29.07.2023, 10:36

Цитата:

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

Ругается

поправил

Nikilin · 29.07.2023, 11:37

Выдает всю ту же ошибку. Вполне возможно я что то не так делаю.

VVA · 31.07.2023, 10:41

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)))

Nikilin · 31.07.2023, 11:19

Цитата:

Сообщение от 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:18

Задам еще вопрос. Решил все же сделать вариацию с RGB вариантом и завис
В общем не могу адекватно считать RGB код
Пример.
1. У меня есть команда установки цвета. Прикручивается к отдельной кнопке.

Код:

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

(defun c:GE-COLOR-RGB ()
  (setq *GE-COLOR-RGB* (getstring T "\nВведи цвет RGB (пример:30 30 30): "))
  (princ (strcat "\nЦвет" *GE-COLOR-RGB*))
  (princ)
)

2. Запускается рабочая программа
Для примера немного измененный код из сообщения 13

Код:

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

  
(defun c:GEO-HATCH-RGB (/ object_mark to_be_hatched_object hatch_object)
(setq PER1 *GE-LAY*) ; СЛОЙ
  (setq PER2 *GE-HTYPE*) ; ТИП ШТРИХОВКИ
  (setq PER3 *GE-COLOR-RGB*)) ; ЦВЕТ
  (setq PER4 *GE-BCOL-RGB* ; ЦВЕТ ФОНА
  (setq PER5 (atoi *GE-HSCALE*)) ; МАСШТАБ
  (setq PER6 (atoi *GE-HANGLE*)) ; УГОЛ
  
	(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 color1 (vlax-create-object (strcat "AutoCAD.AcCmColor." (substr (getvar "ACADVER") 1 2))))
	(vla-SetRGB color1 PER3) ;ТЕСТИРОВАТЬ!!!!!
	(vla-put-TrueColor hatch_object color1)
  
    (vla-put-patternangle hatch_object (* PER6 (/ pi 180))) ;присваиваем угол
    (vla-put-patternscale hatch_object PER5) ;присваиваем масштаб
  
	(setq col (vlax-create-object (strcat "AutoCAD.AcCmColor." (substr (getvar "ACADVER") 1 2))))
	(vla-setrgb 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)
)

Код возвращает ошибку, так как переменные PER3 и PER4 возвращают допустим "30 30 30" и "40 40 40". Вопрос как избавится от кавычек и приди к верному решению. Я что то завис. Фильтры списков возвращают ошибки.
Пролистал замечательную книжку Николая Полещука AutoLisp и не нашел то, что могло бы мне помочь.
Ответ скорей всего банален, но я в ступоре.

===AAA=== · 01.08.2023, 11:44

Метод (vla-setrgb ...) требует четыре параметра, а Вы пытаетесь скормить ему только два.
Разбейте переменные PER3 и PER4 на три отдельных значения (каждую) - и будет счастье.

А как - обсуждалось здесь же.

Тема: "Как в автолиспе перевести строку с пробелами в список?"

koMon · 01.08.2023, 11:45

Цитата:

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

переменные PER3 и PER4 возвращают допустим "30 30 30" и "40 40 40"

setrgb должна получить прямые цветовые координыты перечислением, соответственно per3 и per4 должны быть списками , а передача цвета в setrgb должна выглядеть как-то так (vla-SetRGB color1 (car PER3) (cadr per3) (caddr per3))

Nikilin · 01.08.2023, 11:49

Цитата:

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

setrgb должна получить прямые цветовые координыты перечислением, соответственно per3 и per4 должны быть списками , а передача цвета в setrgb должна выглядеть как-то так (vla-SetRGB color1 (car PER3) (cadr per3) (caddr per3))

Пробовал
Возвращает ошибку к сожалению. Не понял почему. Нету сообщения, есть только подсветка этого фрагмента. На работе отладка криво работает. Вечером попробую проверить на домашнем.
На работе работает тока вариант
(setq PER3R (atoi *GE-COL-R*)) ;
(setq PER3G (atoi *GE-COL-G*)) ;
(setq PER3B (atoi *GE-COL-B*)) ;
(setq PER4R (atoi *GE-BCOL-R*)) ;
(setq PER4G (atoi *GE-BCOL-G*)) ;
(setq PER4B (atoi *GE-BCOL-B*)) ;
Задать все переменные по отдельности и преобразовать каждый в число из текста. Минус такого способа в том что надо вызывать 3 программы для задания цвета, а не одну.

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

Цитата:

Сообщение от ===AAA===

Тема: "Как в автолиспе перевести строку с пробелами в список?"

Изучу спасибо.

koMon · 01.08.2023, 11:59

если цвет задаётся строкой, напр. "30 30 30", то сделать из неё список можно (read (strcat "(" "30 30 30" ")"))

Nikilin · 01.08.2023, 12:04

я верно понял?, что если PER3 возвращает "30 30 30"
То код (read (strcat "(" PER3 ")")) вернет просто список 30 30 30
И уже теперь извлекая компоненты будет работать setRGB

koMon · 01.08.2023, 12:06

ну да

Nikilin · 01.08.2023, 12:08

Спасибо.

koMon · 01.08.2023, 12:24

если хочется и индексный цвет и rgb или вдруг книжный, то лучше сделать небольшой диалог на запрос всех параметров штриховки. в выборе цвета очень удобна функция (acad_truecolordlg...), правда она возвращает rgb цвет в dxf коде и в десятичном числе, которое нужно расшифровывать для извлечения R, G, B.

Nikilin · 01.08.2023, 12:42

Цитата:

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

если хочется и индексный цвет и rgb или вдруг книжный, то лучше сделать небольшой диалог на запрос всех параметров штриховки. в выборе цвета очень удобна функция (acad_truecolordlg...), правда она возвращает rgb цвет в dxf коде и в десятичном числе, которое нужно расшифровывать для извлечения R, G, B.

Я думал про это, но решил, что в рамках моих требований это лишнее.
Объясню логику, что я делаю.
Кнопка допусти на штриховку будет такая.
^C^CSET-LAY;СЛОЙ;^C^CSET-COLOR-RGB;"70 70 70";....По аналогии другие переменные^C^CGEO-HATCH-RGB
Таким образом при желании повторить и нажать enter переменные уже установлены глобально и работает только часть GEO-HATCH-RGB
В общем криво, но логику объяснил.
Именно поэтому усложнять слишком не стоит. Для макроса лучше оставить как есть.
Если доведу до ума может и выложу исходники, где нибудь в сообщение. Мало ли кто решит заморочиться тем же.

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

VVA · 02.08.2023, 16:35

Цитата:

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

Цвет заливки изменить через DXF группу нельзя

Найди в коде строку

Цитата:

(lib:dxf-ent-modify (entlast) 62 3); _62-dxf-код цвета 3-зеленый цвет ACI

Замени цифру 3 на цифру 1, посмотри результат
Цифры 3 и 1 - это ACI (Autocad Color Index) зеленый и красный соотвественно
Вместо них могут быть цифры от 1 до 256. Таблица ACI цветов

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

Цитата:

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

очень удобна функция (acad_truecolordlg...), правда она возвращает rgb цвет в dxf коде и в десятичном числе

Есть и обычная функция acad_colordlg

Nikilin · 02.08.2023, 18:14

Цитата:

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

Замени цифру 3 на цифру 1, посмотри результат
Цифры 3 и 1 - это ACI (Autocad Color Index) зеленый и красный соотвественно
Вместо них могут быть цифры от 1 до 256. Таблица ACI цветов

Прошу простить скорей я не верно описал проблему
Я прекрасно понимаю что цвет определяется таблицей ACI, но
Мне интересна DXF группа цвета заливки штриховки, и именно ее я в справочниках не нашел.
62 группа отвечает за цвет самой штриховки и она прекрасно работает.
Думал что если группа 70 установленная на "1" , то 63 может поменять цвет фона, но не работает (в справочнике описана как "For MPolygon, pattern fill color as the ACI")
А группа 70 как "Solid fill flag (solid fill = 1; pattern fill = 0); for MPolygon, the version of MPolygon"

koMon · 02.08.2023, 21:15

Цитата:

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

Думал что если группа 70 установленная на "1" , то 63 может поменять цвет фона

в мануале нет явной DXF группы для установки цвета заливки штриховки, так же как нет её и в DXF дампе, поэтому здесь не надо думать)
зато она есть в расширенных данных, опять же в десятичном числе.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Создание и восстановление профиля Автокад с помощью файла 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