[cyberkolbasa]

Вобщем стояла задача как можно оперативнее получить массовые характеристики этажей высотного здания. 3Дмодель здания была только в скаде. И тут пригодились свежеприобретенные (хоть и весьма скромные) знания по лиспу. Удалось сваять код, который решил поставленную задачу.

Код:

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

;;;------------------ConvToSolid.lsp---------------------
;;; Преобразование модели стержень/пластина в солидмодель
;;; 11.07.08 Широких Алексей (cyberkolbasa)
;;;------------------------------------------------------
;;; Команды конвертации объектов:
;;; l-s ;преобразует балки/колонны в солиды line to solid
;;; f-s ;преобразует плиты/стены в солиды 3dface to solid
;;;------------------------------------------------------
;;; Комана просмотра свойств 3Д-тел:
;;; getmi
;;; после выполнения команды для просмотра
;;; результатов вычислений нажать F2
;;;------------------------------------------------------


(defun C:L-S (/ i n a_x b_y set_line start_pt end_pt)
   ;;------------------------------------------------
   ;;преобразует балки/колонны в солиды line to solid
   ;;для запуска в комстроке набрать l-s
   ;;------------------------------------------------
   ;;назначение системных переменных
   (setq osm (getvar "osmode"))
   (setvar "osmode" 0)			;отключение эха
   (setq ech (getvar "cmdecho"))
   (setvar "cmdecho" 0)			;отключение объектной привязки
   (command "_ucs" "w")			;включение МСК
   (command "_shademode" "h")		;режим шейдинга

   (setq a_x (getreal "\nВведите ширину сечения колонны/балки (размер по Х):"))
   (setq b_y (getreal "\nВведите высоту сечения колонны/балки (размер по У):"))

   (princ "\nВыделите колонны/балки (примитивы Line):")
   (setq set_line (ssget '((0 . "line")))) ;выделияем отрезки и суем их в набор set_line
   (setq i (sslength set_line))
   (setq n 0)
   (repeat i
      (setq start_pt (cdr (assoc 10 (entget (ssname set_line n))))) ;получаем коорд. начало отрезка
      (setq end_pt (cdr (assoc 11 (entget (ssname set_line n))))) ;получаем коорд. конца отрезка
      (command "_ucs" "n" "za" start_pt end_pt) ;новая система координат вдоль отрезка
      (command "_3dface"
	       (list (- 0 (* 0.5 a_x)) (- 0 (* 0.5 b_y)) 0)
	       (list (+ 0 (* 0.5 a_x)) (- 0 (* 0.5 b_y)) 0)
	       (list (+ 0 (* 0.5 a_x)) (+ 0 (* 0.5 b_y)) 0)
	       (list (- 0 (* 0.5 a_x)) (+ 0 (* 0.5 b_y)) 0)
	       ""
      )
      (command "_extrude" (entlast) "" "p" (ssname set_line n)) ;вытягиваем солид колонны
      (setq n (1+ n))
      (command "_ucs" "w")
   )

   (setvar "cmdecho" ech)
   (setvar "osmode" osm)
)

(defun C:F-S (/ i n t_pl set_face pt1 pt2 pt3 pt4 solname1 solname2)
   ;;------------------------------------------------
   ;;преобразует плиты/стены в солиды 3dface to solid
   ;;для запуска в комстроке набрать f-s
   ;;------------------------------------------------
   ;;назначение системных переменных
   (setq osm (getvar "osmode"))
   (setvar "osmode" 0)			;отключение эха
   (setq ech (getvar "cmdecho"))
   (setvar "cmdecho" 0)			;отключение объектной привязки
   (command "_ucs" "w")			;включение МСК
   (command "_shademode" "h")		;режим шейдинга

   (setq t_pl (getreal "\nВведите толщину плиты/стены:"))

   (princ "\nВыделите плиты/стены (примитивы 3DFace):")
   (setq set_face (ssget '((0 . "3dface")))) ;выделияем 3dface и суем их в набор set_face
   (setq i (sslength set_face))
   (setq n 0)
   (repeat i
      (setq pt1 (cdr (assoc 10 (entget (ssname set_face n))))) ;получаем коорд. 1 вершины
      (setq pt2 (cdr (assoc 11 (entget (ssname set_face n))))) ;получаем коорд. 2 вершины
      (setq pt3 (cdr (assoc 12 (entget (ssname set_face n))))) ;получаем коорд. 3 вершины
      (setq pt4 (cdr (assoc 13 (entget (ssname set_face n))))) ;получаем коорд. 4 вершины
      (command "_3dface" pt1 pt2 pt3 pt4 "")
      (command "_extrude" (entlast) "" (* -0.5 t_pl) 0) ;вытягиваем солид плиты на полтолщины
      (setq solname1 (entlast))
      (command "_3dface" pt1 pt2 pt3 pt4 "")
      (command "_extrude" (entlast) "" (* 0.5 t_pl) 0) ;вытягиваем солид плиты на полтолщины
      (setq solname2 (entlast))
      (command "_union" solname1 solname2 "")
      (setq n (1+ n))
   )

   (setvar "cmdecho" ech)
   (setvar "osmode" osm)
)

(setq dens 2400)			;плотность материала по умолчанию
(defun momi (/ filop str-mpr)
   ;;---------------------функция--------------------------
   ;;определяет моменты инерции 3Д-тел (ед.массы*ед.длины2)
   ;;------------------------------------------------------
   ;;назначение системных переменных
   (setq osm (getvar "osmode"))
   (setvar "osmode" 0)			;отключение эха
   (setq ech (getvar "cmdecho"))
   (setvar "cmdecho" 0)			;отключение объектной привязки
   (command "_ucs" "w")			;включение МСК
   (command "_shademode" "h")		;режим шейдинга

   (setq filop (open (findfile "momi-temp.mpr") "r"))

   ;;начало цикла обработки файла
   (repeat 15
      (setq str-mpr (read-line filop))

      (if
	 (wcmatch str-mpr "*Volume:*")	;получаем объем
	   (setq volu (atof (vl-string-trim "Volume: " str-mpr)))
      )

      (if
	 (wcmatch str-mpr "*Bounding box:*") ;получаем габариты
	   (progn
	      (setq xb (vl-string-trim "Bounding box: X:" str-mpr))
	      (setq str-mpr (read-line filop))
	      (setq yb (vl-string-trim " Y:" str-mpr))
	      (setq str-mpr (read-line filop))
	      (setq zb (vl-string-trim " Z:" str-mpr))
	   )
      )

      (if
	 (wcmatch str-mpr "*Centroid:*") ;получаем ц.т.
	   (progn
	      (setq xc (atof (vl-string-trim "Centroid: X:" str-mpr)))
	      (setq str-mpr (read-line filop))
	      (setq yc (atof (vl-string-trim " Y:" str-mpr)))
	      (setq str-mpr (read-line filop))
	      (setq zc (atof (vl-string-trim " Z:" str-mpr)))
	   )
      )

      (if
	 (wcmatch str-mpr "*Moments of inertia:*") ;получаем мометы инерции относиельно МСК
	   (progn
	      (setq ix (atof (vl-string-trim "Moments of inertia: X:" str-mpr)))
	      (setq str-mpr (read-line filop))
	      (setq iy (atof (vl-string-trim " Y:" str-mpr)))
	      (setq str-mpr (read-line filop))
	      (setq iz (atof (vl-string-trim " Z:" str-mpr)))
	   )
      )

      (if
	 (wcmatch str-mpr "*Principal moments*") ;получаем главные мометы инерции
	   (progn
	      (setq str-mpr (read-line filop))
	      (setq icx (atof (vl-string-trim " I:" str-mpr)))
	      (setq str-mpr (read-line filop))
	      (setq icy (atof (vl-string-trim " J:" str-mpr)))
	      (setq str-mpr (read-line filop))
	      (setq icz (atof (vl-string-trim " K:" str-mpr)))
	   )
      )
   )

   (close filop)
   (princ "\n \n------ РЕЗУЛЬТАТЫ ВЫЧИСЛЕНИЙ ------ \n")
   (progn (princ "\nОбщий объем = ") (princ volu))
   (progn (princ "\nПлотность материала = ") (princ dens))
   (setq mass (* dens volu))
   (progn (princ "\nОбщая масса = ") (princ mass))
   (princ "\n\nКоординаты центра тяжести:")
   (progn (princ "\nХс = ") (princ xc))
   (progn (princ "\nYс = ") (princ yc))
   (progn (princ "\nZс = ") (princ zc))
   (princ "\n\nМоменты инерции относительно Глобальной системы координат:")
   (progn (princ "\nIx = ") (princ ix))
   (progn (princ "\nIy = ") (princ iy))
   (progn (princ "\nIz = ") (princ iz))
   (princ "\n\nМоменты инерции относительно ГЛАВНОЙ системы координат:")
   (progn (princ "\nIcx = ") (princ icx))
   (progn (princ "\nIcy = ") (princ icy))
   (progn (princ "\nIcz = ") (princ icz))
   (setq icxyz (sqrt (+ (* icx icx) (* icy icy) (* icz icz))))
   (princ "\n\nВекторная сумма ГЛАВНЫХ моментов инерции:")
   (progn (princ "\nIcxyz = ") (princ icxyz))
;;;   (princ "\nГабаритные размеры бокса:")
;;;   (progn (princ "\nХb = ") (princ xb))
;;;   (progn (princ "\nYb = ") (princ yb))
;;;   (progn (princ "\nZb = ") (princ zb))
   (princ)

   (setvar "cmdecho" ech)
   (setvar "osmode" osm)

)

(defun C:GETMI ()			;команда расчета свойств 3Д-тел
   (princ "\nВыделите 3Д-тела (примитивы 3DSolid):")
   (setq set_solid (ssget '((0 . "3dsolid")))) ;выделияем 3dsolid и суем их в набор set_solid
   (command "_massprop" set_solid "" "y" "momi-temp")
   (momi)
)

Ниже прикреплен dxf-файл одного этажа экспортированный из скада. На нем можно опробовать работу этого кода.

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

Варианты замены кода принимаются?

[cyberkolbasa]

Сообщение от Кулик Алексей aka kpblc Варианты замены кода принимаются?

Конечно! Рад буду поучиться у матерых лисп-программистов.

ЗЫ. Детально смогу рассмотреть "варианты замены кода" не раньше сентября. Завтра убываю в расположение... На военные сборы. Заранее всем спасибо.

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

Сильно хочется спать, поэтому пока только кусок для колонн:

Код:

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

(defun make-columns (/              *error*        _dwgru-conv-pickset-to-list
                     selset         adoc           width
                     height         space          elist
                     low            pline
                     ) ;_ end of /

  (defun *error* (msg)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun

  (defun _dwgru-conv-pickset-to-list (value / tab item)
    (repeat (setq tab  nil
                  item (sslength value)
                  ) ;_ end setq
      (setq tab (cons (ssname value (setq item (1- item))) tab))
      ) ;_ end repeat
    ) ;_ end defun

  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-StartUndoMark
  (if
    (and
      (= (type (setq selset
                      (vl-catch-all-apply
                        '(lambda ()
                           (prompt
                             "\nВыберите отрезки для построения колонн <Отмена> : "
                             ) ;_ end of prompt
                           (ssget '((0 . "LINE")))
                           ) ;_ end of lambda
                        ) ;_ end of vl-catch-all-apply
                     ) ;_ end of setq
               ) ;_ end of type
         'pickset
         ) ;_ end of =
      (= (type (setq
                 width (vl-catch-all-apply
                         '(lambda ()
                            (getdist
                              "\nУкажите ширину сечения колонны, м <Отмена> : "
                              ) ;_ end of getdist
                            ) ;_ end of lambda
                         ) ;_ end of vl-catch-all-apply
                 ) ;_ end of setq
               ) ;_ end of type
         'real
         ) ;_ end of =
      (> width 0.)
      (= (type (setq
                 height (vl-catch-all-apply
                          '(lambda ()
                             (getdist
                               "\nУкажите высоту сечения колонны, м <Отмена> : "
                               ) ;_ end of getdist
                             ) ;_ end of lambda
                          ) ;_ end of vl-catch-all-apply
                 ) ;_ end of setq
               ) ;_ end of type
         'real
         ) ;_ end of =
      (> height 0.)
      ) ;_ end of and
     (progn
       (setq
         space (vla-objectidtoobject
                 adoc
                 (vla-get-ownerid (vlax-ename->vla-object (ssname selset 0)))
                 ) ;_ end of vla-ObjectIDToObject
         ) ;_ end of setq
       (foreach ent (_dwgru-conv-pickset-to-list selset)
         (setq elist (entget ent)
               low   (car (vl-sort (list (cdr (assoc 10 elist)) (cdr (assoc 11 elist)))
                                   '(lambda (a b) (< (last a) (last b)))
                                   ) ;_ end of vl-sort
                          ) ;_ end of car
               ) ;_ end of setq
         (vla-addextrudedsolidalongpath
           space
           (car (vlax-safearray->list
                  (vlax-variant-value
                    (vla-addregion
                      space
                      (vlax-make-variant
                        (vlax-safearray-fill
                          (vlax-make-safearray
                            vlax-vbobject
                            '(0 . 0)
                            ) ;_ end of vlax-make-safearray
                          (list
                            (vlax-ename->vla-object
                              (setq pline
                                     (entmakex
                                       (append
                                         (list '(0 . "LWPOLYLINE")
                                               '(100 . "AcDbEntity")
                                               '(100 . "AcDbPolyline")
                                               '(90 . 4)
                                               '(70 . 1)
                                               '(43 . 0.)
                                               (cons 38 (last low))
                                               '(39 . 0.)
                                               ) ;_ end of list
                                         (mapcar '(lambda (x)
                                                    (cons 10 x)
                                                    ) ;_ end of lambda
                                                 (list (list (- (car low) (* width 0.5))
                                                             (- (cadr low) (* height 0.5))
                                                             ) ;_ end of list
                                                       (list (+ (car low) (* width 0.5))
                                                             (- (cadr low) (* height 0.5))
                                                             ) ;_ end of list
                                                       (list (+ (car low) (* width 0.5))
                                                             (+ (cadr low) (* height 0.5))
                                                             ) ;_ end of list
                                                       (list (- (car low) (* width 0.5))
                                                             (+ (cadr low) (* height 0.5))
                                                             ) ;_ end of list
                                                       ) ;_ end of list
                                                 ) ;_ end of mapcar
                                         '((210 0. 0. 1.))
                                         ) ;_ end of append
                                       ) ;_ end of entmakex
                                    ) ;_ end of setq
                              ) ;_ end of vlax-ename->vla-object
                            ) ;_ end of list
                          ) ;_ end of vlax-safearray-fill
                        ) ;_ end of vlax-make-variant
                      ) ;_ end of vla-addregion
                    ) ;_ end of vlax-variant-value
                  ) ;_ end of vlax-safearray->list
                ) ;_ end of car
           (vlax-ename->vla-object ent)
           ) ;_ end of vla-addextrudedsolidalongpath
         (entdel pline)
          ;(entdel line)
         ) ;_ end of foreach
       ) ;_ end of progn
     ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

Код особо не гонял.