;2点間に文字がフィットするように幅縮尺を調節し、位置を移動する ;文字、マルチテキストに対応 ;斜め文字、UCSにも対応(←苦労した） ;Shusei Hayashi ;OffshoreCad&Management Inc. ;10F Jaka Bldg., 6780 Ayala Ave., ;Makati, Philippines ;http://www.offshorecad.com.ph/ ;http://www.offshore-management.com.ph/ (defun c:SD_510 ( / ObjSet Pt1 Pt2 X_Dist m i ObjName ObjData AngU Pt0) (if (= SD:Lang "E") (princ "\n Fit and move Text and MText") (princ "\n 2点間に文字、マルチテキストがフィットするように幅縮尺を調節し、位置を移動する") ) (princ "\n **********************************") (setq *error* *myerror*) (SD1028) (setvar "OSMODE" 545) (while (= ObjSet nil) (setq ObjSet (ssget '((-4 . "")))) ) (if (= SD:Lang "E") (progn (setq Pt1 (getpoint "\n 1st point to Fit") Pt2 (getpoint "\n 2nd point to Fit") )) (progn (setq Pt1 (getpoint "\n フィットの1点目") Pt2 (getpoint "\n フィットの2点目") )) ) ; (checkcircle Pt1 0.1 "A81") ; (checkcircle Pt2 0.1 "A03") (setvar "OSMODE" 0) (setq AngU (angle '(0 0) (getvar "UCSXDIR"))) (setq m (sslength ObjSet)) (setq i 0) (repeat m (setq ObjName (ssname ObjSet i)) (setq ObjData (entget ObjName)) (cond ((= (cdr(assoc 0 ObjData)) "TEXT") (Fit_Text ObjName Pt1 Pt2) ;@TEXTの基点変更 ) ( (= (cdr(assoc 0 ObjData)) "MTEXT") (Fit_MText ObjName Pt1 Pt2) ) ) (setq i (1+ i)) ) (SD2056) (setq *error* nil) (princ) ) ;@TEXTのFIT+++++++++++++++++++++++++++++++++++++++++++++++++++ (defun Fit_Text (ObjName Pt1 Pt2 / Data TBase Ang Ang2 TBox1 TBox2 TBaseU TBox1U TBox2U Pt1O Pt2O MinX X_Dist BoxWidth WidthValue Delta) (setq Data (entget ObjName)) (setq TBase (cdr (assoc 10 Data))) ;挿入基点WCS (setq Ang (cdr (assoc 50 Data))) ;オブジェクトの角度 (setq Ang2 (- Ang AngU)) ;オブジェクトの角度とUCSの角度との差 (setq TBox1 (mapcar '+ TBase (SD8446 (car (textbox Data)) '(0 0) Ang))) ;対角点1 WCS(文字回転を考慮） (setq TBox2 (mapcar '+ TBase (SD8446 (cadr (textbox Data)) '(0 0) Ang))) ;対角点2 WCS(文字回転を考慮） (setq TBaseU (trans TBase 0 1)) ;UCS上に移す (setq TBox1U (trans TBox1 0 1)) ;UCS上に移す (setq TBox2U (trans TBox2 0 1)) ;UCS上に移す ; (checkcircle TBox1U 0.5 "A21") ; (checkcircle TBox2U 0.5 "A21") (setq Pt1O (SD1862 Pt1 Ang2)) ;指示した2点をオブジェクトに平行な座標系に投影 (setq Pt2O (SD1862 Pt2 Ang2)) ;指示した2点をオブジェクトに平行な座標系に投影 (setq MinX (Min (car Pt1O)(car Pt2O))) ;Xの差を取るこれが目標幅 (setq X_Dist (abs (- (car Pt1O) (car Pt2O)))) (setq BoxWidth (abs (- (caar (textbox Data))(caadr (textbox Data))))) ;BOXの幅 (setq WidthValue (cdr ( assoc 41 Data))) ;現在の幅係数 (setq WidthValue (abs (* (/ X_Dist BoxWidth) WidthValue))) ;横に何倍にすればよいか ;幅係数を変更し、いったん作図 (setq Data (subst (cons 41 WidthValue) ( assoc 41 Data) Data)) (entmod Data) ;データ取り直し (setq Data (entget ObjName)) (setq TBox (textbox Data)) (setq TBase (cdr (assoc 10 Data))) ;挿入基点WCS (setq TBox1 (mapcar '+ TBase (SD8446 (car (textbox Data)) '(0 0) Ang))) ;対角点1 WCS(文字回転を考慮） (setq TBox2 (mapcar '+ TBase (SD8446 (cadr (textbox Data)) '(0 0) Ang))) ;対角点2 WCS(文字回転を考慮） (setq TBox1U (trans TBox1 0 1)) ;UCS上に移す (setq TBox2U (trans TBox2 0 1)) ;UCS上に移す ; (checkcircle TBox1U 0.5 "A51") ; (checkcircle TBox2U 0.5 "A51") ;オブジェクトの角度にそった移動距離 (setq Delta (- MinX (car (SD1862 TBox1U Ang2)))) ;移動ベクトルをUCSにもどす (setq Delta (SD8446 (list Delta 0) '(0 0) Ang2)) ;移動 (command "move" ObjName "" "0,0" Delta) ) ;AMTEXTのFIT+++++++++++++++++++++++++++++++++++++++++++++++++++ (defun Fit_MText (ObjName Pt1 Pt2 / Data X_Dist TBase W_42 OldIP X_Old OldVal A_List Y_Loc W_Loc Sep_Loc W_Value NewW NewString Data Dist Delta_Move) ; (print "Fit_MText") (setq Data (entget ObjName)) (setq TBase (cdr (assoc 10 Data))) ;挿入基点WCS (setq Ang2 (cdr (assoc 50 Data))) ;オブジェクトの角度UCS (setq Pt1O (SD1862 Pt1 Ang2)) ;指示した2点をオブジェクトに平行な座標系に投影 (setq Pt2O (SD1862 Pt2 Ang2)) ;指示した2点をオブジェクトに平行な座標系に投影 (setq MinX (Min (car Pt1O)(car Pt2O))) ;Xの差を取るこれが目標幅 (setq X_Dist (abs (- (car Pt1O) (car Pt2O)))) (setq W_42 (cdr (assoc 42 Data))) ;幅 (setq OldIP (cdr (assoc 71 Data))) ;挿入起点記号 (setq X_Old (- (+ OldIP 2) (* (fix ( / (+ OldIP 2) 3)) 3))) ;X方向 何列目へ (setq TBaseU (trans TBase 0 1)) ;UCS上に移す ;幅係数を変更し、いったん作図 (setq OldVal (cdr (assoc 1 Data))) ;書き込み (setq A_List (StringToList_000 OldVal)) (setq Y_Loc (NthAtomList "\\" A_List)) (setq W_Loc (NthAtomList "W" A_List)) (setq Sep_Loc (NthAtomList ";" A_List)) (if (and (< Y_Loc W_Loc Sep_Loc)(= W_Loc (1+ Y_Loc))) (setq W_Value (read (substr OldVal ( + W_Loc 2) (- Sep_Loc W_Loc 1)))) (setq W_Value 1.0) ) (setq NewW ( * W_Value ( / X_Dist W_42))) (if (< 10 NewW) (progn (setq NewW 10.0) (if (= SD:Lang "E") (princ "\n Some Text is more than 10.0 width") (princ "\n いくつかの文字は幅係数が10を超えていたので10に調整されました") ) ) ) (setq NewW (abs NewW)) ;";"より前を切り飛ばす (if (/= (member ";" A_List) nil) (setq A_List (cdr (member ";" A_List))) ) (if (/= NewW 1.0) (setq A_List (append (list "\\W" (rtos NewW 2) ";") A_List)) ) (setq NewString (ListToString_000 A_List)) (setq Data (subst (cons 1 NewString) (assoc 1 Data) Data)) (entmod Data) ;データ取り直し (setq Data (entget ObjName)) (setq W_42 (cdr (assoc 42 Data))) ;幅 ;オブジェクトの角度にそった移動距離 (setq Delta (- MinX (car (SD1862 TBaseU Ang2)) (* -0.5 X_Old W_42 ))) ;移動ベクトルをUCSにもどす (setq Delta (SD8446 (list Delta 0) '(0 0) Ang2)) (command "move" ObjName "" "0,0" Delta) ) ;**************************************************** ;リスト内で、ある要素が何番目にあるか+++++++++++++;; (defun NthAtomList ( Factor B_List / N M) (setq N (length B_List)) (setq M (length (member Factor B_List))) (setq R (- N M)) R ) ;**************************************************** ;座標系変換（Angだけ原点周りに回転した座標系で表現する (defun SD1862 (OldPt Ang / NewCs) (setq NewCs (SD8446 '(1 0) '(0 0) Ang)) (setq NewPt (trans OldPt 0 NewCs)) (setq NewPt (list (nth 2 NewPt)(nth 0 NewPt))) NewPt ) ;;;---------Rotate---------------------------- ;;;点Aを点Bを中心にαだけ回転させた座標 ;;;【引き数】点A 中心 角度α ;;;【戻り値】点C (defun SD8446 ( PointA PointB Ang / XA YA XB YB PointC) (setq XA2(- (car PointA) (car PointB)) YA2(- (cadr PointA) (cadr PointB)) ) (setq PointC (list (- (* XA2 (cos Ang))(* YA2 (sin Ang))) (+ (* XA2 (sin Ang))(* YA2 (cos Ang))))) (setq PointC (mapcar '+ PointC PointB)) PointC ) ;共通コマンド (defun SD1028 () (setq OldCmdEcho (getvar "CMDECHO")) (setvar "CMDECHO" 0) (command "undo" "be") (setq OldOsmode (getvar "OSMODE")) (setq OldLayer (getvar "CLAYER")) (setq OldLType (getvar "CeLType")) (setq OldCeLWeight (getvar "CeLWeight")) (setq OldColor (getvar "CeColor")) (setq OldOrtho (getvar "ORTHOMODE")) (setq OldDStyle (getvar "DIMSTYLE")) (setq OldExpert (getvar "Expert")) (setvar "EXPERT" 0) (setq Path_Lang "HKEY_CURRENT_USER\\Software\\SpeedDraftLT") (if (vl-registry-read Path_Lang "SD_Language" ) (setq SD:Lang (vl-registry-read Path_Lang "SD_Language" )) (progn (setq SD:Lang "J") (vl-registry-write Path_Lang "SD_Language" "J") ) ) (princ) ) ;******************************** (defun SD2056 () (setvar "OSMODE" OldOsmode) (command "undo" "end") (setvar "CLAYER" OldLayer) (setvar "CeLType" OldLType) (setvar "CeLWeight" OldCeLWeight) (setvar "CeColor" OldColor) (setvar "ORTHOMODE" OldOrtho) (setvar "Expert" OldExpert) (if (and (/= (getvar "DIMSTYLE") OldDStyle)(tblsearch "DIMSTYLE" OldDStyle)) (command "-dimstyle" "Restore" OldDStyle) ) (princ "\n (C)OffshoreCad&Management") (setvar "CMDECHO" OldCmdEcho) (princ) ) (if (= SD:Lang "E") (princ "\n Command Name: SD_510 \n") (princ "\n コマンド名：SD_510 \n") ) (princ)