AutoLISPでも公開してみる。御宣託/ウェブリブログ

AutoLISPでも公開してみる。

<< 作成日時： 2007/03/13 21:10 >>

ずいぶん昔に作ったやつ。
今でも結構使ってます。
嗚呼、8年も前だったんだね。また作るとなると時間かかるよなぁ。

---------------------

;----------------------------------------------------------
; コマンド名:ADIM1 --- 円弧寸法記入
; 選択した円弧に対するアーク寸法
; Programed by A.T. 1999 Sept. 12
;----------------------------------------------------------

;円弧寸法記入
(defun C:ADIM1 (/ arc ent rad sang eang arcang arclen orgdim entdim)

(setq arc (entsel "\n円弧を選択：")) ;円弧の図形名と選択点を取得
(setq ent (entget (car arc))) ;円弧の図形データを取得

(if (= (cdr (assoc 0 ent)) "ARC") ;選択図形が円弧かどうかチェック
(progn ;図形が円弧の時、処理
(setq rad (cdr (assoc 40 ent))) ;円弧の半径を取得
(setq sang (cdr (assoc 50 ent))) ;円弧の始点角度を取得
(setq eang (cdr (assoc 51 ent))) ;円弧の終点角度を取得

(if (< sang eang) ;始点角度と終点角度のどちらが大きいかチェック

(setq arcang (abs (- eang sang))) ;終点角度が大きいとき
(setq arcang (+ (- (* 2 pi) sang) eang)) ;始点角度が大きいとき
)

(setq arclen (* (* (* 2 PI) rad) (/ arcang (* 2 pi)))) ;円弧の長さを計算
(setq arclen (rtos arclen 2 (getvar "DIMDEC"))) ;寸法スタイルの精度で小数点桁数を設定

(command "DIMANGULAR" arc pause) ;角度寸法を記入
(setq orgdim (entlast)) ;弧長を記入する。
; (print (entget orgdim))
(setq entdim (entget orgdim))
(setq entdim (subst (cons 1 arclen) (assoc 1 entdim) entdim))
(setq entdim (subst (cons 8 "DIM") (assoc 8 entdim) entdim)) ;寸法線レイヤーに移動
(entmod entdim)
)

(alert "円弧を選択して下さい。") ;図形が円弧以外の時、メッセージボックスを表示
)
(princ)
)

;----------------------------------------------------------
; コマンド名:ADIM2
; 入力したアークの寸法
; Programed by A.T. 1999 Sept. 12
;----------------------------------------------------------

;円弧寸法記入
(defun C:adim2
(/ name arc ent arcpt pt rad sang eang arcang arclen orgdim entdim)

(setvar "CMDECHO" 0)
(prompt "\n孤寸法の範囲を指定して下さい。(始点通過点終点)")

(command "ARC" pause pause pause)
(setq arc (entlast))
(setq ent (entget arc)) ;円弧の図形データを取得

(setq rad (cdr (assoc 40 ent))) ;円弧の半径を取得
(setq sang (cdr (assoc 50 ent))) ;円弧の始点角度を取得
(setq eang (cdr (assoc 51 ent))) ;円弧の終点角度を取得
(setq arcpt (cdr (assoc 10 ent))) ;円弧の中心点を取得
(setq pt (polar arcpt sang rad)) ;円弧上の点を指定

(if (< sang eang) ;角度計算
(setq arcang (abs (- eang sang))) ;終点角度が大きいとき
(setq arcang (+ (- (* 2 pi) sang) eang)) ;始点角度が大きいとき
)

(setq arclen (* (* (* 2 PI) rad) (/ arcang (* 2 pi)))) ;弧長計算
(setq arclen (rtos arclen 2 (getvar "DIMDEC"))) ;小数点桁数を設定

(setq name (list arc pt)) ;円弧指定用のリストの作成

(command "DIMANGULAR" name pause) ;角度寸法を記入
(setq orgdim (entlast))
(setq entdim (entget orgdim))
(setq entdim (subst (cons 1 arclen) (assoc 1 entdim) entdim)) ;弧長を記入
(setq entdim (subst (cons 8 "DIM") (assoc 8 entdim) entdim)) ;寸法線レイヤーに移動
(entmod entdim)

(entdel arc) ;円弧を削除
(setvar "CMDECHO" 1)
(princ)
)

;------------------------------------------------
; コマンド名:nmb
; 既に配置された文字列に連番を記入する。
; Programed by A.T. Sep.15 1999
;------------------------------------------------
(defun c:nmb

(/ prestr pststr snum trgt enttrgt outtxt)
(setq snum (getint "開始番号:"))
(if <> snum "")
(progn
(setq prestr (getstring "先頭文字:"))
(setq pststr (getstring "後続文字:"))

(while (/= (setq trgt (entsel "文字を選択")) nill)
(setq enttrgt (entget (car trgt)))
(setq outtxt (strcat prestr (itoa snum) pststr))
(setq enttrgt (subst (cons 1 outtxt) (assoc 1 enttrgt) enttrgt))
(entmod enttrgt)
(setq snum (1+ snum))
)
)
(princ)
)

;------------------------------------------------
; コマンド名:same_txt
; 既に配置された文字列に同じ文字列をを記入する。
; Programed by A.T. Sep.15 1999
;------------------------------------------------
(defun c:same_txt

(/ instr trgt enttrgt)
(setq instr (getstring "文字列:"))
(if <> snum "")
(progn
(while (/= (setq trgt (entsel "文字を選択")) nill)
(setq enttrgt (entget (car trgt)))
(setq enttrgt (subst (cons 1 instr) (assoc 1 enttrgt) enttrgt))
(entmod enttrgt)
(print instr)
)
)
(princ)
)

;------------------------------------------------
; コマンド名:blnarrw
; 点から円までの矢印を引く
; Programed by A.T. Sep.26 1999
;------------------------------------------------
(defun c:blnarrw

(/ spoint epoint target enttarget ccen crad langle)
(setq spoint (getpoint "\n引出線の開始点:"))
(setq target (entsel "\n目標のバルーン:"))
(setq enttarget (entget (car target)))

(if (= (cdr (assoc 0 enttarget)) "CIRCLE")
(progn
(setq ccen (cdr (assoc 10 enttarget)))
(setq crad (cdr (assoc 40 enttarget)))

(setq langle (angle ccen spoint))

(setvar "CMDECHO" 0)
(setq epoint (polar ccen langle crad))
(command "_leader" spoint epoint "" "" "n")
(setvar "CMDECHO" 1)

)
(alert "円を指定して下さい。")
)
(princ)
)

;------------------------------------------------
; コマンド名:blnline
; 点から円までの直線を引く
; Programed by A.T. Sep.26 1999
;------------------------------------------------
(defun c:blnline

(/ spoint epoint target enttarget ccen crad langle)
(setq spoint (getpoint "\n引出線の開始点:"))
(setq target (entsel "\n目標のバルーン:"))
(setq enttarget (entget (car target)))

(if (= (cdr (assoc 0 enttarget)) "CIRCLE")
(progn
(setq ccen (cdr (assoc 10 enttarget)))
(setq crad (cdr (assoc 40 enttarget)))

(setq langle (angle ccen spoint))

(setvar "CMDECHO" 0)
(setq epoint (polar ccen langle crad))
(command "_line" spoint epoint "")
(setvar "CMDECHO" 1)

)
(alert "円を指定して下さい。")
)
(princ)
)

;------------------------------------------------
; コマンド名:arrw
; 点から点までの矢印を引く
; Programed by A.T. Aug.09 1999
;------------------------------------------------
(defun c:arrw

(/ spoint epoint)
(setq spoint (getpoint "\n引出線の開始点:"))
(setq epoint (getpoint spoint "\n引出線の開始点:"))

(setvar "CMDECHO" 0)
(command "_leader" spoint epoint "" "" "n")
(setvar "CMDECHO" 1)

(princ)
)

;------------------------------------------------
; コマンド名:RecW
; 指定点から指定の幅の正方形を書く
; Programed by A.T. Aug.09 1999
;------------------------------------------------
(defun c:RecW

(/ CenPoint CenX CenY RecWidth FPoint EPoint)
(setq CenPoint (getpoint "\n正方形の中心点:"))
(setq RecWidth (getreal "\n辺の長さ:"))

(setq CenX (car CenPoint))
(setq CenY (car (cdr CenPoint)))

(setq FPoint (list (- CenX (/ RecWidth 2)) (- CenY (/ RecWidth 2))))
(setq EPoint (list (+ CenX (/ RecWidth 2)) (+ CenY (/ RecWidth 2))))

(setvar "CMDECHO" 0)
(command "_rectangle" FPoint EPoint)
(setvar "CMDECHO" 1)
(princ)
)

;------------------------------------------------
; コマンド名:RecWH
; 指定点から指定の幅と高さの四角形を書く
; Programed by A.T. Aug.09 1999
;------------------------------------------------
(defun c:RecWH

(/ CenPoint CenX CenY RecWidth RecHeight FPoint EPoint)
(setq CenPoint (getpoint "\n四角形の中心点:"))
(setq RecWidth (getreal "\n幅(X):"))
(setq RecHeight (getreal "\n高さ(Y):"))

(setq CenX (car CenPoint))
(setq CenY (car (cdr CenPoint)))

(setq FPoint (list (- CenX (/ RecWidth 2)) (- CenY (/ RecHeight 2))))
(setq EPoint (list (+ CenX (/ RecWidth 2)) (+ CenY (/ RecHeight 2))))

(setvar "CMDECHO" 0)
(command "_rectangle" FPoint EPoint)
(setvar "CMDECHO" 1)
(princ)
)

;------------------------------------------------
; コマンド名:nmb_plc
; 既に配置された文字列に連番を記入する。
; Programed by A.T. Feb.21 2000
;------------------------------------------------
(defun c:nmb_plc

(/ prestr pststr snum NumTxt TNum NumAll NumAllLen trgt enttrgt OutTxt)
(setq snum (getint "開始番号:")) ;開始番号を入力
(if <> snum "") ;空の入力の場合終了
(progn
(setq TNum (getint "数字桁数:")) ;数字部分の桁数を入力
(setq prestr (getstring "先頭文字:")) ;数字の手前の文字列を入力
(setq pststr (getstring "後続文字:")) ;数字の後ろの文字列を入力

(while (/= (setq trgt (entsel "文字を選択")) nill) ;空の選択の場合終了
(setq enttrgt (entget (car trgt))) ;リスト取得

(setq NumAll (strcat "000000000" (itoa snum))) ;"0"を付加する。
(setq NumAllLen (strlen NumAll)) ;全文字列の長さを計算
(setq NumTxt (substr NumAll (- NumAllLen (- TNum 1)))) ;数字部分を抽出
(setq OutTxt (strcat prestr NumTxt pststr)) ;手前と後ろの文字列を付加
(setq enttrgt (subst (cons 1 OutTxt) (assoc 1 enttrgt) enttrgt)) ;文字部分の呼出し
(entmod enttrgt) ;文字の代入
(setq snum (1+ snum)) ;インクリメント
)
)
(princ)
)

;------------------------------------------------
; コマンド名:StringCopy.lsp
; 選択した文字列の内容を別の文字列にコピーする。
; Programed by A.T. Mar.24 2000
;------------------------------------------------
(defun c:StringCopy

(/ InTrgt OutTrgt entInTrgt entOutTrgtouttxt)
(setq InTrgt (entsel "\n(1) コピー元文字列を選択")) ;コピー元文字列を選択
(setq entInTrgt (entget (car Intrgt))) ;コピー元文字列を取得

(while (= 1 1)
(setq OutTrgt (entsel "\n(2) コピー先文字列を選択")) ;コピー先文字列を選択
(setq entOutTrgt (entget (car OutTrgt))) ;コピー先文字列を取得

(setq entOutTrgt (subst (assoc 1 entInTrgt) (assoc 1 entOutTrgt) entOutTrgt))

(entmod entOutTrgt)
)

(princ)
)

;------------------------------------------------
; コマンド名:StringMerge.lsp
; 選択した二つの文字列の内容を元の文字列にコピーする。
; Programed by A.T. Mar.24 2000
;------------------------------------------------
(defun c:StringMerge

(/ InTrgt1 InTrgt2 entInTrgt1 entInTrgt2 InText1 InText2 OutText)

(setq InTrgt1 (entsel "\n元の文字列を選択:"))
(setq entInTrgt1 (entget (car InTrgt1)))
(setq InTrgt2 (entsel "\n結合する文字列を選択:"))
(setq entInTrgt2 (entget (car InTrgt2)))

(setq InText1 (cdr (assoc 1 entInTrgt1)))
(setq InText2 (cdr (assoc 1 entInTrgt2)))

(setq OutText (strcat InText1 InText2))

(setq entInTrgt1 (subst (cons 1 OutText) (assoc 1 entInTrgt1) entInTrgt1))

(entmod entInTrgt1)

(princ)
)

;------------------------------------------------
; コマンド名:nmb_step
; 指定した刻み幅の連番を記入する。
; Programed by A.T. Mar.18 2002
;------------------------------------------------
(defun c:nmb_step
(/ prestr pststr snum step trgt enttrgt outtxt)
(setq snum (getreal "開始番号:"))
(setq step (getreal "刻み幅:"))
(if <> snum "")
(progn
(setq prestr (getstring "先頭文字:"))
(setq pststr (getstring "後続文字:"))

(while (/= (setq trgt (entsel (strcat"\n" prestr (rtos snum) pststr ":文字を選択"))) nill)
(setq enttrgt (entget (car trgt)))
(setq outtxt (strcat prestr (rtos snum) pststr))
(setq enttrgt (subst (cons 1 outtxt) (assoc 1 enttrgt) enttrgt))
(entmod enttrgt)
(setq snum (+ step snum))
)
)
(princ)
)