fc2ブログ

CODE16:選択したポリラインの個別辺長を一括表記

2023年05月16日
AutoLISP サンプルコード公開Gallery

;選択したポリラインの個別辺長を一括表記
;+++++++++++++
(defun C:CODE16 ()
;+++++++++++++
    (princ "\nLWPOLYLINEを選択")
    (setq Obj (ssget (list (cons 0 "LWPOLYLINE"))))
    (if (not(= Obj nil));最適化ポリラインが選択されていたら・・・
        (progn
            (setq cnt 0)
            (setq num (sslength Obj))
            ;------
            (Command "OsnapCoord" "1" "-Layer" "M" "FlagLength" "")
            ;------
            (while (< cnt num);
                (setq tmpl (ssname Obj cnt))
                (setq ent (entget tmpl))
                (setq MyHandle  (cdr (assoc 5 ent)));ハンドル名
                (setq MyFlag  (cdr (assoc 70 ent)));ポリライン フラグ
               ;------
                (setq npsu (cdr (assoc 90 ent));頂点数
                        pstl ent
                        nc 0)
                (repeat npsu;頂点数
                            (setq Pt (cdr (assoc 10 pstl));LWPOLYLINEの頂点座標を取得
                            Pt (trans Pt  tmpl 0);OCS座標からWCS座標に変換
                            Pt (trans Pt  0 1));WCS座標からUCS座標に変換
                    ;------ 
                    (setq Ptx (car Pt)
                            Pty (cadr Pt))
                    (setq ppnl (assoc 10 pstl)
                            pstl (member ppnl pstl)
                            pstl (cdr pstl))
                    (if (= nc 0)
                        (progn
                            (setq lppnt (list ppnt))
                             (setq Pt1 Pt
                                     Pt1x Ptx
                                     Pt1y Pty)
                             (setq Pt0 Pt
                                     Pt0x Ptx
                                     Pt0y Pty)
                        );progn
                        (progn
                            (setq lppnt (append lppnt (list ppnt)))
                            (setq Pt2 Pt
                                    Pt2x Ptx
                                    Pt2y Pty)
                            ;中点座標
                            ;+++++++++++++
                            (setq PtXm (/ (+ Pt1x Pt2x) 2)
                                    PtYm (/ (+ Pt1y Pt2y) 2))                          
                            (setq PtXm (rtos PtXm )
                                    PtYm (rtos PtYm ))
                            ;+++++++++++++
                            (setq Ptm (strcat PtXm "," PtYm))
                            (setq ObjLength (distance Pt1 Pt2))    
                            (Command
                                "ID" Ptm
                                "Ucs" "w" 
                                "-MText"  "@"  "J" "BC" "@0,0" (Strcat  (rtos ObjLength)) ""
                                "Ucs" "p"
                                "Grips" "2"
                            );Command
                            (setq Pt1 Pt
                                    Pt1x Ptx
                                    Pt1y Pty)
                        );progn
                    );if
                    (setq nc (+ nc 1))
                );repeat
                (if (= MyFlag 1);閉じたポリライン
                    (progn
                        ;中点座標
                        ;+++++++++++++
                        (setq PtXm (/ (+ Pt1x Pt0x) 2)
                                PtYm (/ (+ Pt1y Pt0y) 2))                              
                        (setq PtXm (rtos PtXm )
                                PtYm (rtos PtYm ))
                        ;+++++++++++++
                        (setq Ptm (strcat PtXm "," PtYm))
                        (setq ObjLength (distance Pt1 Pt0))    
                        (Command
                            "ID" Ptm
                            "Ucs" "w" 
                            "-MText"  "@"  "J" "BC" "@0,0"
                            (Strcat  (rtos ObjLength)) ""
                            "Ucs" "p"
                            "Grips" "2"
                        );Command
                    );progn
                );if
                (setq cnt (1+ cnt))
            );while
        );progn
        ;最適化ポリラインが選択されていなかったら・・・
        (alert "選択エラー:最適化ポリラインが選択されていません") 
    ):if
    (princ)
)


 AutoLispサンプルコードプログラム 一覧(インデックス)

 AutoLispサンプルコードプログラム 【概説】

AutoLispサンプルコードプログラム
関連記事
スポンサーサイト



Gallery担当:山野 ロザリア平久郎
Posted by Gallery担当:山野 ロザリア平久郎