CODE19：選択したポリラインの面積を一括表記

2023年05月16日
2023年06月22日

;選択したポリラインの面積を一括表記;+++++++++++++
(defun C:CODE19 ( / Obj cnt num tmpl ent PtX PtY Pt )
;+++++++++++++
    (princ "\nポリラインを選択")
    (setq Obj (ssget (list (cons 0 "LWPOLYLINE"))))
    (if (not(= Obj nil));最適化ポリラインが選択されたら・・・
        (progn
            (setq cnt 0
                    num (sslength Obj))
            ;------------
            (Command "OsnapCoord" "1" "-Layer" "M" "FlagArea" "")
            ;------------
            (while (< cnt num);
                (setq tmpl (ssname Obj cnt))
                (setq ent (entget tmpl))
                (setq MyHandle  (cdr (assoc 5 ent)));ハンドル名
 
                (setq npsu (cdr (assoc 90 ent)));頂点数
                (setq pstl ent)
                (setq nc 0)
                (repeat npsu;頂点数
                    (setq Pt (cdr (assoc 10 pstl)));LWPOLYLINEの頂点座標を取得
                    (setq Pt (trans Pt  tmpl 0));OCS座標からWCS座標に変換
                    (setq Pt (trans Pt  0 1));WCS座標からUCS座標に変換
                   ;------------                 
                    (setq PtX (car Pt)
                            PtY (cadr Pt))		
                    (setq ppnl (assoc 10 pstl))
                    (setq pstl (member ppnl pstl))
                    (setq pstl (cdr pstl))
                    (if (= nc 0)
                        (progn
                            (setq lppnt (list ppnt))
                            (setq SumXp PtX			
                                    SumYp PtY)
                        );progn
                        (progn
                            (setq lppnt (append lppnt (list ppnt)))
                            (setq SumXp (+ SumXp PtX)			
                                    SumYp (+ SumYp PtY))
                        );progn
                    );if
                    (setq nc (+ nc 1))
                );repeat
               ;-----平均座標
                ;+++++++++++++
                (setq PtXm (/ SumXp npsu)
                        PtYm (/ SumYp npsu))
                (setq PtXm (rtos PtXm )
                        PtYm (rtos PtYm ))
                ;+++++++++++++	
                (setq Ptm (strcat PtXm "," PtYm))
                (Command "Area" "o" (handent MyHandle) "")
                (setq ObjArea (getvar "Area"))
                (Command
                    "ID" Ptm
                    "Ucs" "w" 
                    "-MText"  "@"  "J" "MC" "@0,0"
                    (Strcat "A=" (rtos ObjArea)) ""
                    "Ucs" "p"
                    "Grips" "2"
                );Command	
                (setq cnt (1+ cnt))
            );while
        );progn
        ;最適化ポリラインが選択されなかったら・・・
        (alert "選択エラー：ポリラインが選択されていません") 
    ):if
    (princ)
)