[Supermax]

Стал писать функцию, которая вычисляет сумму всех площадей и за основу взял GeomProps Александра Ривилиса, но, оказалось, что 3Dface изогнутая по оси этой прогой не считается (пока).
Вот я и призадумался. Посмотрел сам объект и заметил, что 2 и 4 точки (а их всего четыре) всегда составляют грань изогнутого 3Dface. И эта грань острая, без сплайновых заморочек. Значит 3Dface не что иное как склеенных два треугольника (1-2-4) и (2-3-4). Все координаты точек есть в dxf коде объекта, значит, даже без применения всяких изощрений можно тригонометрически посчитать площадь этих треугольников.


Объект "AcDbSubDMesh" как мне сказал Александр Ривилис имеет свойство area и я надеюсь на скорое его появление в GeomProps.

(defun 3Dfase-area (obj / l p r s)
;|
Функция сделана на основе функции Елпанова Евгения
http://elpanov.com/index.php?id=36
3-я версия

Проверку на соответствие типу объекта намеренно не вставлял, так как планирую использовать при обработке наборов
созданных с такой фильтрацией.

Пример использования:
(3Dfase-area (car (entsel)))

|;
(setq l (cons 0 (mapcar (function distance)
(list (cdr (assoc 10 (entget obj))) (cdr (assoc 11 (entget obj))) (cdr (assoc 13 (entget obj))))
(list (cdr (assoc 11 (entget obj))) (cdr (assoc 13 (entget obj))) (cdr (assoc 10 (entget obj))))
))
p (/ (apply (function +) l) 2.)
) ;_ setq

(setq r (cons 0 (mapcar (function distance)
(list (cdr (assoc 11 (entget obj))) (cdr (assoc 12 (entget obj))) (cdr (assoc 13 (entget obj))))
(list (cdr (assoc 12 (entget obj))) (cdr (assoc 13 (entget obj))) (cdr (assoc 11 (entget obj))))
))
s (/ (apply (function +) r) 2.)
) ;_ setq

(+
(sqrt (abs (apply (function *) (mapcar (function -) l (list p p p p)))))
(sqrt (abs (apply (function *) (mapcar (function -) r (list s s s s)))))
)
) ;_ defun

(vl-load-com)
;|
;;; Функция вычисления площади объекта "AcDbPolygonMesh"
;;; функция возвращает список площадей основной поверхности,
;;; поверхности замкнтых M столбцов,
;;; поверности замкнутых N строк
;;; и поверхности образованной точками краев полигона.
;;;
;;; Автор : Андрей Лазебный (Supermax)
;;; Параметры:
;;; obj1 - указатель на объект типа ename
;;;
;;; Примеры вызова:
;;;
;;; (apply '+ (polimesh-area (car (entsel))))
;;; получаем сумму всех поверхностей
;;;
;;; (car (polimesh-area (car (entsel))))
;;; получаем площадь основной поверхности
;;;
;;;
;;; Проверку на соответствие типу объекта намеренно не вставлял, так как планирую использовать при обработке наборов
;;; созданных с такой фильтрацией.
;;;
|;

(defun polimesh-area (obj1 / listpoint pl listpoint2 m n facemesh startbit listpoint3 listpoint4 listpoint5 listpoint6 rez1 rez2 rez3 rez4)

;=========================================================================
;Загружаем служебную функцию вычисления площади 3Dface по четырем точкам

(defun 3Dface-area-2 ( listpoint / l p r s rez1 p1 p2 p3 p4)

;|
Функция сделана на основе функции Елпанова Евгения
http://elpanov.com/index.php?id=36
3-я версия

Пример использования:
(3Dface-area-2 (list point1 point2 point4 point3))
point1-4 списки из координат точек
|;
(setq p1 (nth 0 listpoint))
(setq p2 (nth 1 listpoint))
(setq p3 (nth 3 listpoint))
(setq p4 (nth 2 listpoint))


(setq l (cons 0 (mapcar (function distance)
(list p1 p2 p4)
(list p2 p4 p1)
))
p (/ (apply (function +) l) 2.)
) ;_ setq

(setq r (cons 0 (mapcar (function distance)
(list p2 p3 p4)
(list p3 p4 p2)
))
s (/ (apply (function +) r) 2.)
) ;_ setq

(setq rez1 (+
(sqrt (abs (apply (function *) (mapcar (function -) l (list p p p p)))))
(sqrt (abs (apply (function *) (mapcar (function -) r (list s s s s)))))
))

) ;_ defun

;===========================================================
;Вычисляем площадь основной поверхности

(setq obj (vlax-ename->vla-object obj1))

(setq listpoint (vlax-safearray->list (vlax-variant-value (vla-get-Coordinates obj))))
;делим список на подсписки по 3 элемента в каждом
(setq pl (/ (length listpoint) 3))
(setq listpoint2 nil)
(repeat pl (setq listpoint2 (append listpoint2 (list (list (nth 0 listpoint) (nth 1 listpoint) (nth 2 listpoint))))) (setq listpoint (cdddr listpoint)))
;смотрим столбцы и строки
(setq m (vla-get-MVertexCount obj))
(setq n (vla-get-NVertexCount obj))
;количество поверхностей основной плоскости
(setq facemesh (* (- m 1) (- n 1)))
;получаем список плоскостей
(setq startbit 0)
(setq startstring 1)
(setq listpoint3 nil)
(repeat facemesh (setq listpoint3 (append listpoint3 (list (list
(nth startbit listpoint2)
(nth (+ 1 startbit) listpoint2)
(nth (+ n startbit) listpoint2)
(nth (+ n 1 startbit) listpoint2)))))
(if (< startstring (- n 1)) (progn (setq startbit (+ 1 startbit)) (setq startstring (+ 1 startstring)))
(progn (setq startstring 1) (setq startbit (+ 2 startbit))))

)

;получаем площадь
(setq rez1 (apply '+ (mapcar (function (lambda (x) (3dface-area-2 x))) listpoint3)))

;-------------------------------------------------------------------------------------
;Вычисляем площадь поверхностей, образованных замыканием M столбцов

(if (= (vla-get-MClose obj) :vlax-true)
(progn
(setq startbit (- (* n m) n))
(setq listpoint3 nil)
(repeat n (setq listpoint3 (append listpoint3 (list (nth startbit listpoint2)))) (setq startbit (+ 1 startbit)))

(setq startbit 0)
(setq listpoint4 nil)
(repeat n (setq listpoint4 (append listpoint4 (list (nth startbit listpoint2)))) (setq startbit (+ 1 startbit)))

(setq listpoint5 (append listpoint3 listpoint4))
(setq startbit 0)
(setq listpoint3 nil)
(setq startstring 1)
(setq facemesh (- m 1))
(repeat facemesh (setq listpoint3 (append listpoint3 (list (list
(nth startbit listpoint5)
(nth (+ 1 startbit) listpoint5)
(nth (+ n startbit) listpoint5)
(nth (+ n 1 startbit) listpoint5)))))
(if (< startstring (- n 1)) (progn (setq startbit (+ 1 startbit)) (setq startstring (+ 1 startstring)))
(progn (setq startstring 1) (setq startbit (+ 2 startbit))))
)

(setq rez2 (apply '+ (mapcar (function (lambda (x) (3dface-area-2 x))) listpoint3)))
))
(if (null rez2) (setq rez2 0))

;---------------------------------------------------------------------------------------------
;Вычисляем площадь поверхности образованной замыканием N строк

(if (= (vla-get-NClose obj) :vlax-true)
(progn

(setq startbit (- n 1))
(setq listpoint6 nil)
(repeat (- n 1) (setq listpoint6 (append listpoint6 (list (list
(nth startbit listpoint2)
(nth (- startbit (- n 1)) listpoint2)
(nth (+ n startbit) listpoint2)
(nth (+ 1 startbit) listpoint2)))))
(setq startbit (+ n startbit))
)
(setq rez3 (apply '+ (mapcar (function (lambda (x) (3dface-area-2 x))) listpoint6)))

))
(if (null rez3) (setq rez3 0))

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

(if (and (= (vla-get-NClose obj) :vlax-true) (= (vla-get-MClose obj) :vlax-true))
(progn
(setq listpoint7 (list
(nth (- (* n m) 1) listpoint2)
(nth (- (* n m) n) listpoint2)
(nth (- n 1) listpoint2)
(nth 0 listpoint2)
))

(setq rez4 (3dface-area-2 listpoint7))
))
(if (null rez4) (setq rez4 0))

;---------------------------------------------------------------------------------------------------
;Распечатываем результат

(princ (list rez1 rez2 rez3 rez4))
);end defun polimesh-area

[VVA]

Александр Ривилис, Александр, спасибо. В качестве пожеланий добавить в архив readme про оманды GeomPropsStart и GeomPropsStop.
И еще один вопрос по функционированию. До сих пор, когда собирался выбирать большой объем данных, я закрывал окно свойств. Так вот вопрос: работает ли Geomprops, если окно свойств закрыто?

[Александр Ривилис]

Сообщение от VVA Так вот вопрос: работает ли Geomprops, если окно свойств закрыто?

Нет. AutoCAD не обращается к GeomProps если окно свойств закрыто. Но команды включения/выключения GeomProps я сделал по той причине, что иногда нужно при открытой панели свойств выбрать много примитивов (например, если нужно убедится, что выбранные примитивы на одном слое).
Но вызывать функции, которые из позволяют получить площадь/периметр/объем примитивов из LISP/VBA можно и при закрытом окне свойств.