;選択したオブジェクトの座標値を書き出す(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 tmpl ed Cid Pt )
;*******************
   (RegistRowsRate);行間隔調整サブルーチン
   ;+++++
   (princ "\n****  線分を選択  ****")   
   (setq Obj (Ssget (List (Cons 0 "LINE"))))
   (setq cnt 0)
   (setq num (Sslength Obj))
   ;+++++
   (while (< cnt num);
      (setq tmpl (Ssname Obj cnt))
      (setq ed (Entget tmpl))
      ;=========== 
      ; 始点
      ;===========
      (setq Pt (Cdr(Assoc 10 ed)))
      ;+++++++
      (setq Pt (trans Pt  tmpl 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 ed)))
      ;+++++++
      (setq Pt (trans Pt  tmpl 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)
;**************************
   (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 tmpl (Ssname Obj cnt))
      (setq ent (Entget tmpl))
      (if (= (cdr (assoc 0 ent)) "LWPOLYLINE") ;選択図形が最適化ポリライン
         (progn ;図形が最適化ポリラインの時、処理
            (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 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 ppnl (assoc 10 pstl))
               (setq pstl (member ppnl pstl))
               (setq pstl (cdr pstl))
               (if (= nc 0)
                  (setq lppnt (list ppnt))
                  (setq lppnt (append lppnt (list ppnt)))
               );if
               ;+++++   
               (setq nc (+ nc 1))
            );repeat	
         );progn	
      );if
      (setq cnt (1+ cnt))
   );while	
   (princ)
);---------------







;選択した円/円弧の中心座標値を書き出す
;*******************  円/円弧を選択
(defun C:ExtractIDCircle ( / Obj UcsWE cnt num tmpl ed Cid PtX PtY Pt PtW)
;*******************
   (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 tmpl (ssname Obj cnt))
      (setq ed (entget tmpl))
      ;+++++
      (setq Pt (cdr(assoc 10 ed)));円の中心座標を取得
	   ;+++++++
	   (setq Pt (trans Pt  tmpl 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)
);----------------










;*******************
(Defun C:ExtractIDLinePlus ( / Obj UcsWE cnt num tmpl ed Cid PtX PtY Pt )
;*******************
   (RegistRowsRate);行間隔調整サブルーチン
	;---------------
	(princ "\n線分を選択")
      (Setq Obj (Ssget (List (Cons 0 "LINE"))))
      (Setq cnt 0)
      (Setq num (Sslength Obj))
	;---------------
	(While (< cnt num);
      (setq tmpl (Ssname Obj cnt))
      (setq ed (Entget tmpl))
      (setq MyHandle  (cdr (assoc 5 ed)));ハンドル名
      ;=========== 
      ; 始点
      ;===========
      (setq MyPtName (Strcat MyHandle "-1" ))
		(setq Pt (Cdr(Assoc 10 ed)))
		;+++++++
		(setq Pt (trans Pt  tmpl 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 ed)))
		;+++++++
		(setq Pt (trans Pt  tmpl 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)
);---------------









;**************************
(Defun C:ExtractIDPolyPlus ( / Obj num)
;**************************
   (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 tmpl (ssname Obj cnt))
      (setq ent (entget tmpl))
      ;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      (if (= (cdr (assoc 0 ent)) "LWPOLYLINE") ;選択図形が最適化ポリライン
         (progn ;図形が最適化ポリラインの時、処理
            (setq MyHandle  (cdr (assoc 5 ent)));ハンドル名      
            (setq npsu (cdr (assoc 90 ent)));頂点数
            (setq pstl ent)
            (setq nc 0)
            (repeat npsu
               (setq MyNum (+ nc 1))	
               (setq MyPtName (Strcat MyHandle "-" (rtos MyNum )))
               (setq Pt (cdr (assoc 10 pstl)));LWPOLYLINEの頂点座標を取得
               ;+++++++
               (setq Pt (trans Pt  tmpl 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 ppnl (assoc 10 pstl))
               (setq pstl (member ppnl pstl))
               (setq pstl (cdr pstl))
               (if (= nc 0)
                  (setq lppnt (list ppnt))
                  (setq lppnt (append lppnt (list ppnt)))
               );if
               ;-------------------
               (setq nc (+ nc 1))
            );repeat	
         );progn
      );if		
      ;-------------------
      (Setq cnt (1+ cnt))
      ;-------------------
   );while
   (princ)
);defun








;*******************
;(defun C:cc()
(Defun C:ExtractIDCirclePlus ( / Obj UcsWE cnt num tmpl ed Cid PtX PtY Pt PtW)
;*******************
   (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 tmpl (Ssname Obj cnt))
		(Setq ed (Entget tmpl))
		(setq MyHandle  (cdr (assoc 5 ed)));ハンドル名
		(Setq Pt (Cdr(Assoc 10 ed)));円の中心
      ;+++++++
      (setq Pt (trans Pt  tmpl 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)
);------------




