;選択したオブジェクトの座標値を書き出す(ExtractID.lsp)










;<--------------Oct.11-2025
;<--------------Aug.01-2025
;<--------------Feb.20-2024
;<--------------Feb.09-2024
;<--------------Nov.22-2022
;<--------------Oct.16-2022
;<--------------Jun.19-2022
;<--------------Feb.14-2022


  ;選択した線分の両端点座標値を書き出す
  ;******************* 線分を選択
  (defun C:ExtractIDLine ( / Obj UcsWE cnt num MyEnt ed Cid Pt )
  ;*******************2025/11/11
   (RegistRowsRate);行間隔調整サブルーチン
   ;+++++
   (princ "\n****  線分を選択  ****")   
   (setq Obj (Ssget (List (Cons 0 "LINE"))))
   (setq cnt 0)
   (setq num (Sslength Obj))
   ;+++++
   (while (< cnt num);
    (setq MyEnt (Ssname Obj cnt))
    (setq Ent (entget MyEnt))
    ;=========== 
    ; 始点
    ;===========
    (setq Pt (Cdr(Assoc 10 Ent)))
    ;+++++++
    (setq Pt (trans Pt  MyEnt 0));OCS座標からWCS座標に変換
    (setq Pt (trans Pt  0 1));WCS座標からUCS座標に変換
    ;+++++素地
    (setq Xp (car Pt)
              Yp (cadr Pt))		
    ;+++++作図単位による調整
    (setq Xp (rtos (* Xp (atof (Getenv "係数")))))
    (setq Yp (rtos (* Yp (atof (Getenv "係数")))))
    ;+++++小数点揃え
    (setq Xp (rtos (atof Xp) 2 (Atoi (Getenv "小数点"))))
    (setq Yp (rtos (atof Yp) 2 (Atoi (Getenv "小数点"))))
    ;+++++++	
    (setq Pt (strcat Xp "," Yp))
    ;+++++
    (Command
        "OsnapCoord" "1" "-Layer" "M" "FlagID" ""
        "ID" Pt 
        "Ucs" "w" "-MText" "@" "J" "ML" "L" "A" 行間隔 "@0,0" 
        (Strcat "X=" Xp) (Strcat "Y=" Yp) ""
        "Ucs" "p")
    ;=========== 
    ; 終点
    ;=========== 
    (setq Pt (Cdr(Assoc 11 Ent)))
    ;+++++++
    (setq Pt (trans Pt  MyEnt 0));OCS座標からWCS座標に変換
    (setq Pt (trans Pt  0 1));WCS座標からUCS座標に変換
    ;+++++素地
    (setq Xp (car Pt)
              Yp (cadr Pt))		
    ;+++++作図単位による調整
    (setq Xp (rtos (* Xp (atof (Getenv "係数")))))
    (setq Yp (rtos (* Yp (atof (Getenv "係数")))))
    ;+++++小数点揃え
    (setq Xp (rtos (atof Xp) 2 (Atoi (Getenv "小数点"))))
    (setq Yp (rtos (atof Yp) 2 (Atoi (Getenv "小数点"))))
    ;+++++++
    (setq Pt (strcat Xp "," Yp))
    ;+++++++
    (command 
        "ID" Pt 
        "Ucs" "w" "-MText" "@" "J" "ML" "L" "A" 行間隔 "@0,0" 
        (Strcat "X=" Xp) (Strcat "Y=" Yp) ""
        "Ucs" "p")
    ;+++++
    (setq cnt (1+ cnt))
   );while
   (princ)
  );-----------




  ;選択したポリラインの頂点座標値を書き出す
  ;************************** ポリラインを選択
  (defun C:ExtractIDPoly ( / Obj num)
  ;**************************2025/11/11
   (RegistRowsRate);行間隔調整サブルーチン
   ;+++++
   (princ "\n****  ポリラインを選択  ****")
   (setq Obj(ssget (list (cons 0 "LWPOLYLINE"))))
   (setq cnt 0)
   (setq num (sslength Obj))
   (Command "OsnapCoord" "1" "-Layer" "M" "FlagID" "")
   ;+++++
   (while (< cnt num);
    (setq MyEnt (Ssname Obj cnt))
    (setq Ent (Entget MyEnt))
    (if (= (cdr (assoc 0 Ent)) "LWPOLYLINE") ;選択図形が最適化ポリライン
      (progn ;図形が最適化ポリラインの時、処理
        (setq npsu (cdr (assoc 90 Ent)));頂点数
        (setq Pnt Ent)
        (setq nc 0)
        (repeat npsu
          (setq Pt (cdr (assoc 10 Pnt)));LWPOLYLINEの頂点座標を取得
          ;+++++++
          (setq Pt (trans Pt  MyEnt 0));OCS座標からWCS座標に変換
          (setq Pt (trans Pt  0 1));WCS座標からUCS座標に変換
          ;+++++素地
          (setq Xp (car Pt)
                  Yp (cadr Pt))		
          ;+++++作図単位による調整
          (setq Xp (rtos (* Xp (atof (Getenv "係数")))))
          (setq Yp (rtos (* Yp (atof (Getenv "係数")))))
          ;+++++小数点揃え
          (setq Xp (rtos (atof Xp) 2 (Atoi (Getenv "小数点"))))
          (setq Yp (rtos (atof Yp) 2 (Atoi (Getenv "小数点"))))
          ;+++++++	
          (setq Pt (strcat Xp "," Yp))
          ;+++++
          (Command "ID" Pt 
                  "Ucs" "w" "-MText" "@" "J" "ML" "L" "A" 行間隔 "@0,0" 
                  (Strcat "X=" Xp) (Strcat "Y=" Yp) ""
                  "Ucs" "p")
          ;+++++                    
          (setq MyPnt (assoc 10 Pnt))
          (setq Pnt (member MyPnt Pnt))
          (setq Pnt (cdr Pnt))
          (if (= nc 0)
            (setq LastPt (list Pt))
            (setq LastPt (append LastPt (list Pt)))
          );if
          ;+++++   
          (setq nc (+ nc 1))
        );repeat	
      );progn	
    );if
    (setq cnt (1+ cnt))
   );while	
   (princ)
  );---------------







  ;選択した円/円弧の中心座標値を書き出す
  ;*******************  円/円弧を選択
  (defun C:ExtractIDCircle ( / Obj UcsWE cnt num MyEnt Ent Cid PtX PtY Pt PtW)
  ;*******************2025/11/11
   (RegistRowsRate);行間隔調整サブルーチン
   ;+++++      	
   (princ "\n****  円/円弧を選択  ****")
   (setq Obj 
    (ssget 
      (list (cons -4 "<OR")
            (cons 0 "CIRCLE")
            (cons 0 "ARC")
            ;(cons 0 "LINE")
            ;(cons 0 "POLYLINE")
            ;(cons 0 "LWPOLYLINE")
            (cons -4 "OR>")
      )
    )
   )
   ;+++++
   (setq cnt 0)
   (setq num (sslength Obj))
   ;+++++
   (while (< cnt num);
    (setq MyEnt (ssname Obj cnt))
    (setq Ent (entget MyEnt))
    ;+++++
    (setq Pt (cdr(assoc 10 Ent)));円の中心座標を取得
    ;+++++++
    (setq Pt (trans Pt  MyEnt 0));OCS座標からWCS座標に変換
    (setq Pt (trans Pt  0 1));WCS座標からUCS座標に変換
    ;+++++素地
    (setq Xp (car Pt)
              Yp (cadr Pt))		
    ;+++++作図単位による調整
    (setq Xp (rtos (* Xp (atof (Getenv "係数")))))
    (setq Yp (rtos (* Yp (atof (Getenv "係数")))))
    ;+++++小数点揃え
    (setq Xp (rtos (atof Xp) 2 (Atoi (Getenv "小数点"))))
    (setq Yp (rtos (atof Yp) 2 (Atoi (Getenv "小数点"))))
    ;+++++++
    (setq Pt (strcat Xp "," Yp))
    ;+++++
    (Command 
        "OsnapCoord" "1" "-Layer" "M" "FlagID" ""
        "ID" Pt
        "Ucs" "w" "-MText" "@" "J" "ML" "L" "A" 行間隔 "@0,0" 
        (Strcat "X=" Xp) (Strcat "Y=" Yp) ""
        "Ucs" "p")
    ;+++++
    (setq cnt (1+ cnt))
   );while
   (princ)
  );------------









  ;仮測点名　MyHandle-n を追記
  ;*******************
  (Defun C:ExtractIDLinePlus ( / Obj UcsWE cnt num MyEnt Ent Cid PtX PtY Pt )
  ;*******************2025/11/11
    (RegistRowsRate);行間隔調整サブルーチン
	  ;---------------
    (princ "\n線分を選択")
    (Setq Obj (Ssget (List (Cons 0 "LINE"))))
    (Setq cnt 0)
    (Setq num (Sslength Obj))
    ;---------------
    (While (< cnt num);
      (setq MyEnt (Ssname Obj cnt))
      (setq Ent (Entget MyEnt))
      (setq MyHandle  (cdr (assoc 5 Ent)));ハンドル名
      ;=========== 
      ; 始点
      ;===========
      (setq MyPtName (Strcat MyHandle "-1" ))
      (setq Pt (Cdr(Assoc 10 Ent)))
      ;+++++++
      (setq Pt (trans Pt  MyEnt 0));OCS座標からWCS座標に変換
      (setq Pt (trans Pt  0 1));WCS座標からUCS座標に変換
      ;+++++素地
      (setq Xp (car Pt)
               Yp (cadr Pt))		
      ;+++++作図単位による調整
      (setq Xp (rtos (* Xp (atof (Getenv "係数")))))
      (setq Yp (rtos (* Yp (atof (Getenv "係数")))))
      ;+++++小数点揃え
      (setq Xp (rtos (atof Xp) 2 (Atoi (Getenv "小数点"))))
      (setq Yp (rtos (atof Yp) 2 (Atoi (Getenv "小数点"))))
		  ;+++++++
      (setq Pt (strcat Xp "," Yp))
		  ;---------------
  		(Command
            "OsnapCoord" "1" "-Layer" "M" "FlagID" ""
            "ID" Pt 
            "Ucs" "w" "-MText" "@" "J" "ML" "@0,0" 
              MyPtName (Strcat "X=" Xp) (Strcat "Y=" Yp) ""
            "Ucs" "p"
		  )
      ;=========== 
      ;終点
      ;===========
      (setq MyPtName (Strcat MyHandle "-2" ))
		  (setq Pt (Cdr(Assoc 11 Ent)))
      ;+++++++
      (setq Pt (trans Pt  MyEnt 0));OCS座標からWCS座標に変換
      (setq Pt (trans Pt  0 1));WCS座標からUCS座標に変換
      ;+++++素地
      (setq Xp (car Pt)
               Yp (cadr Pt))		
      ;+++++作図単位による調整
      (setq Xp (rtos (* Xp (atof (Getenv "係数")))))
      (setq Yp (rtos (* Yp (atof (Getenv "係数")))))
      ;+++++小数点揃え
      (setq Xp (rtos (atof Xp) 2 (Atoi (Getenv "小数点"))))
      (setq Yp (rtos (atof Yp) 2 (Atoi (Getenv "小数点"))))
		;+++++++
      (setq Pt (strcat Xp "," Yp))
		;---------------
  		(Command "ID" Pt "Ucs" "w" "-MText" "@" "J" "ML" "@0,0" 
               MyPtName (Strcat "X=" Xp) (Strcat "Y=" Yp) "")
      (Command "Ucs" "p")
      ;-------------------
      (setq cnt (1+ cnt))
	  );while
    ;---------------
    (princ)
  );---------------








  ;仮測点名　MyHandle-n を追記
  ;**************************
  (Defun C:ExtractIDPolyPlus ( / Obj num)
  ;**************************2025/11/11
    (RegistRowsRate);行間隔調整サブルーチン
    ;+++++
    (princ "\nLWPOLYLINEを選択")
    (setq Obj(ssget (list (cons 0 "LWPOLYLINE"))))
    (setq cnt 0)
    (setq num (sslength Obj))
    (command "OsnapCoord" "1" "-Layer" "M" "FlagID" "")
    ;---------------
    (While (< cnt num);
      (setq MyEnt (ssname Obj cnt))
      (setq Ent (entget MyEnt))
      ;++++++++++++++++++++++++++
      (if (= (cdr (assoc 0 Ent)) "LWPOLYLINE") ;選択図形が最適化ポリライン
        (progn ;図形が最適化ポリラインの時、処理
          (setq MyHandle  (cdr (assoc 5 Ent)));ハンドル名      
          (setq npsu (cdr (assoc 90 Ent)));頂点数
          (setq Pnt Ent)
          (setq nc 0)
          (repeat npsu
            (setq MyNum (+ nc 1))	
            (setq MyPtName (Strcat MyHandle "-" (rtos MyNum )))
            (setq Pt (cdr (assoc 10 Pnt)));LWPOLYLINEの頂点座標を取得
            ;+++++++
            (setq Pt (trans Pt  MyEnt 0));OCS座標からWCS座標に変換
            (setq Pt (trans Pt  0 1));WCS座標からUCS座標に変換
            ;+++++素地
            (setq Xp (car Pt)
                    Yp (cadr Pt))		
            ;+++++作図単位による調整
            (setq Xp (rtos (* Xp (atof (Getenv "係数")))))
            (setq Yp (rtos (* Yp (atof (Getenv "係数")))))
            ;+++++小数点揃え
            (setq Xp (rtos (atof Xp) 2 (Atoi (Getenv "小数点"))))
            (setq Yp (rtos (atof Yp) 2 (Atoi (Getenv "小数点"))))
            ;+++++++
            (setq Pt (strcat Xp "," Yp))
            ;-------------------		
            (Command "ID" Pt "Ucs" "w" "-MText" "@" "J" "ML" "@0,0" 
                    MyPtName (Strcat "X=" Xp) (Strcat "Y=" Yp) "")
            (Command "Ucs" "p")
            ;-------------------                   
            (setq MyPnt (assoc 10 Pnt))
            (setq Pnt (member MyPnt Pnt))
            (setq Pnt (cdr Pnt))
            (if (= nc 0)
              (setq LastPt (list Pt))
              (setq LastPt (append LastPt (list Pt)))
            );if
            ;-------------------
            (setq nc (+ nc 1))
          );repeat	
        );progn
      );if		
      ;-------------------
      (Setq cnt (1+ cnt))
      ;-------------------
    );while
    (princ)
  );defun







  ;仮測点名　MyHandle-n を追記
  ;*******************
  (Defun C:ExtractIDCirclePlus ( / Obj UcsWE cnt num 
                                  MyEnt Ent Cid PtX PtY Pt PtW)
  ;*******************2025/11/11
    (RegistRowsRate);行間隔調整サブルーチン
    ;+++++
    (princ "\n円/円弧を選択")
    (setq Obj
      (ssget
        (list (cons -4 "<OR")
              (cons 0 "CIRCLE")
              (cons 0 "ARC")
              ;(cons 0 "LINE")
              ;(cons 0 "POLYLINE")
              ;(cons 0 "LWPOLYLINE")
              (cons -4 "OR>")
        )
      )
    )
    ;---------------
    (Setq cnt 0)
    (Setq num (Sslength Obj))
    ;---------------
    (While (< cnt num);
      (Setq MyEnt (Ssname Obj cnt))
      (Setq Ent (Entget MyEnt))
      (setq MyHandle  (cdr (assoc 5 Ent)));ハンドル名
      (Setq Pt (Cdr(Assoc 10 Ent)));円の中心
      ;+++++++
      (setq Pt (trans Pt  MyEnt 0));OCS座標からWCS座標に変換
      (setq Pt (trans Pt  0 1));WCS座標からUCS座標に変換
      ;+++++素地
      (setq Xp (car Pt)
                Yp (cadr Pt))		
      ;+++++作図単位による調整
      (setq Xp (rtos (* Xp (atof (Getenv "係数")))))
      (setq Yp (rtos (* Yp (atof (Getenv "係数")))))
      ;+++++小数点揃え
      (setq Xp (rtos (atof Xp) 2 (Atoi (Getenv "小数点"))))
      (setq Yp (rtos (atof Yp) 2 (Atoi (Getenv "小数点"))))
      ;+++++++
      (setq Pt (strcat Xp "," Yp))
      ;---------------
      (Command 
          "OsnapCoord" "1" "-Layer" "M" "FlagID" ""
          "ID" Pt
          "Ucs" "w" "-MText" "@" "J" "ML" "@0,0" 
            MyHandle (Strcat "X=" Xp) (Strcat "Y=" Yp) ""
          "Ucs" "p"
      )
      ;---------------
      (Setq cnt (1+ cnt))
    )
    ;---------------
    (princ)
  );---------------




;*******************  ;単位調整サブルーチン



  ;******************* ;行間隔調整サブルーチン
  (Defun RegistRowsRate ( /   )
  ;*******************
    ;+++++++
    (setq 行間隔 (Getenv "行間隔"))
    (if (= 行間隔 nil);・・・Pn が nil のとき
      (progn
        (Setenv "行間隔" "0.75")
        (setq 行間隔 "0.75x")
      );progn
      (progn
        (if  (OR (< (atof 行間隔) 0.25) (> (atof 行間隔) 4.00))
          (progn
            (Setenv "行間隔" "0.75")
            (setq 行間隔 "0.75x")
          );progn
          (setq 行間隔 (strcat 行間隔 "x"))
        );if
      );progn
    );if
    ;+++++++
    (princ)
  );------------




