AutoCADマクロ屋本舗 掲示板

当方、ARES STANDARDを使用しています。こちらにあるマクロはほとんどしようできません。
簡単なLISPは作れますがこの切取りコピー　切取り削除の作成は無理でした。
どこかでソースレベル公開されていますか。コンパイルLISPはARESでは使用できません。
お願いします。

探してみましたが、コードが公開されているものは、ExpressToolsのEXTRIMを使ったものしか見つけられなかったので、それだとARESでは使えないでしょうから、マクロを参考にざっくり作ってみました。
ただし、点線など空隙のある線種のオブジェクトは切れたり切れなかったりします。ブロック・文字は境界線にかかるものはコピーの場合は対象、削除の場合は非対象としています。

コマンド名は[cpore]、コマンド実行→コピーか削除選択（Enterはコピー）→範囲指定です。

(defun c:cpore (/ pt1 pt2 bpt ss en_b ent pt_list gcpt sc cnt flg #osmode)
(initget "C D")
(or (setq flg (getkword "\n[コピー(C)/削除(D)] <コピー>:")) (setq flg "C"))

(setq pt1 (getpoint "\n一方のコーナーを指定:"))
(setq pt2 (getcorner pt1 "\nもう一方のコーナーを指定:"))
(if (= (strcase flg) "C")
(setq bpt (getpoint "\n基点を指定:"))
)

(command-s "undo" "be")
(setvar "cmdecho" 0)
(setq #osmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq ss (ssget "_C" pt1 pt2))
(command-s "isolateobjects" "p" "")
(command-s "rectang" pt1 pt2)
(setq en_b (entlast))
(setq gcpt (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) pt1 pt2))
(if (= (strcase flg) "C")
(setq sc 1.001)
(setq sc 0.999)
)

;トリムを4回繰り返す
(repeat 4
(command-s "scale" en_b "" gcpt "c" sc)
(setq ent (entget (entlast)))
(repeat 4
(setq pt_list (append pt_list (list (cdr (assoc 10 ent))))) ;頂点のリスト
(setq ent (cdr (member (assoc 10 ent) ent)))
)
(entdel (entlast))
(command "trim" en_b "" "f" (nth 0 pt_list) (nth 1 pt_list) "" "")
(command "trim" en_b "" "f" (nth 1 pt_list) (nth 2 pt_list) "" "")
(command "trim" en_b "" "f" (nth 2 pt_list) (nth 3 pt_list) "" "")
(command "trim" en_b "" "f" (nth 3 pt_list) (nth 0 pt_list) "" "")
(setq sc (* sc sc))
(setq pt_list nil)
)

(entdel en_b)
(setq ss (ssget "_C" pt1 pt2))

(if (= (strcase flg) "C")
(progn
(setq ss (ssget "_C" pt1 pt2))
(command-s "copybase" bpt ss "")
(command-s "undo" "e")
(command-s "undo" "1")
(command-s "pasteclip" pause)
)
(progn
(setq ss (ssget "_W" pt1 pt2))
(command-s "erase" ss "")
(command-s "unisolateobjects")
(setvar "OSMODE" #OSMODE)
(command-s "undo" "e")
)
)

(princ)

)

基本的なコマンドを使ったつもりですが、scaleのCオプションはあるんでしょうか・・・
なければ、その旨返信してください。

LUNE様　返信が遅くなり申し訳ありません。
早速のLISPありがとうございました。
特に1:1のスケールを想定していますのでオプションは大丈夫です。
ところで当方のaresで実行したところコピーでは、基点を指定後、また削除では枠指定後
*Cancel*«エラー»となります。こちらでもChatGPTやcopilot等で試行錯誤やってみましたが
やはりエラーが解消できませんでした。aresの内部コマンドの動きがAutocadとは異なるの
でしょうね？

aresで、
command-s　って関数有りますか？　
（一部の互換CADでは採用されているみたいですが）

isolateobjects , unisolateobjectsコマンドは有りますか？
（Aresのヘルプで検索しても出てこなかった）

Hamuさんご指摘の通り、command-sはないかもですね。
あと、オブジェクトの選択表示もないのか・・・
そうなるとレイアウト使うしかないのかな？

Hamuさん、LUNEさんありがとうございます。
isolateobjects , unisolateobjectsは私も見つけられませんでした。
command-sは確かに使用できないようですね。
地道にトリムを使用してやります。

SCALEコマンドのCオプションもないみたいですね。
ちょっと修正が必要なようです。

SCALEコマンドのCオプションをやめ、コピーの場合はレイアウトを使って処理することにしました。

処理用のレイアウトとして、tmpというレイアウトを作成します。
同名のレイアウトを使用している場合は、
(setq ln "tmp")
ここの tmp を別名にしてください。

(defun c:cpore (/ pt1 pt2 bpt ss en_b ent pt_list gcpt sc cnt flg #osmode ln pt3 pt4)
;ARES
(initget "C D")
(or (setq flg (getkword "\n[コピー(C)/削除(D)] <コピー>:")) (setq flg "C"))

(setq pt1 (getpoint "\n一方のコーナーを指定:"))
(setq pt2 (getcorner pt1 "\nもう一方のコーナーを指定:"))
(if (= (strcase flg) "C")
(setq bpt (getpoint "\n基点を指定:"))
)

(setq ln "tmp")
(command "undo" "be")
;(setvar "cmdecho" 0)
(setq #osmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq ss (ssget "_C" pt1 pt2))

(if (= (strcase flg) "C")
(progn
(setq sc 1.001)
(setq pt3 '(0 0 0))
(setq pt4 (mapcar '(lambda (x1 x2) (- x2 x1)) pt1 pt2))
;レイアウトへ移動
(command "copybase" pt1 ss "")
(command "-layout" "n" ln)
(setvar "ctab" ln)
(command "erase" "all" "")
(command "pasteclip" "0,0,0")
(command "zoom" "e")

)
(progn
(setq sc 0.999)
(setq pt3 pt1)
(setq pt4 pt2)
(setq ss (ssget "_W" pt1 pt2))
(command "erase" ss "")
)
)
(setq gcpt (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) pt3 pt4))
(command "rectang" pt3 pt4)
(setq en_b (entlast))

;トリムを4回繰り返す
(repeat 4
(command "rectang" pt3 pt4)
(command "scale" "l" "" gcpt sc)
(setq ent (entget (entlast)))
(repeat 4
(setq pt_list (append pt_list (list (cdr (assoc 10 ent))))) ;頂点のリスト
(setq ent (cdr (member (assoc 10 ent) ent)))
)
(entdel (entlast))
(command "trim" en_b "" "f" (nth 0 pt_list) (nth 1 pt_list) "" "")
(command "trim" en_b "" "f" (nth 1 pt_list) (nth 2 pt_list) "" "")
(command "trim" en_b "" "f" (nth 2 pt_list) (nth 3 pt_list) "" "")
(command "trim" en_b "" "f" (nth 3 pt_list) (nth 0 pt_list) "" "")
(setq sc (* sc sc))
(setq pt_list nil)
)

(entdel en_b)

(if (= (strcase flg) "C")
(progn
(setq ss (ssget "_C" pt3 pt4))
(command "copybase" pt3 ss "")
(command "undo" "e")
(command "undo" "1")
(command "ctab" "model")
(command "pasteclip" pause)
)
(progn
(command "undo" "e")
)
)
(setvar "OSMODE" #OSMODE)
(princ)

)

LUNEさん、
エラーもなく思い通りの結果が得られました。
私も含めこの時期からは、繁忙期となっています。
その忙しいなか検証を重ねていただき感謝です。
私と同じくARESを使用していられる方にも朗報だと思います。
本当にありがとうございました。

ARES18さん、返信ありがとうございます。
動作したとのことで、一安心です。

お世話になります
私もARESですがコピーの時エラーになり動いてくれません
レイアウト空間で止まります
削除は出来ます
簡単な線分だけでやっても出来ませんでした
どこかの設定とかでしょうか
判ることが有れば教えてください

私はARESを使ってないので、検証できないのですが、レイアウト空間で止まるとことですか、どの段階でしょうか？
レイアウトの名前はtmpになっていますか？
レイアウトにコピー対象のオブジェクトがコピーされていますか？
止まる際のコマンドラインはどうなっているでしょうか？

レイアウトの名前はtmpだったと思います
レイアウトには四角形が2つだけです
コマンドラインは覚えておりません

>レイアウトには四角形が２つだけ
この四角形は、ビューポートではなくポリラインですか？
四角形２つはどのような位置関係なのでしょうか？

返信が遅くなり申し訳ありません
2つの四角形は一つの四角形を二重線で書いた様な形でした
何故だか以前と状況が違ってきました
レイアウトで止まることがなくなりましたが別の問題があります
最後に貼り付けたものが四角形に切り取られていなかったり
四角形で切り取られる位置がずれていたりします
同じ位置を繰り返してやると２回目か３回目に成功します
切り取る場所を変えると切り取られていなかったりずれた位置になったりします
状況はこのようですが普通じゃないと感じています
これ以上のご迷惑はかけられませんのでこのまま使用します

おそらく、クリップボードに問題がありそうな気がするのですが・・・

Windowsの設定→システム→クリップボード　にて、クリップボードの履歴はオンですか？オフですか？

ご対応ありがとうございます
クリップボードの履歴がオフでしたのでオンにしました
何度やっても四角形に切り取られていないものが貼り付けられます
クリップボードの履歴はオフの方が良いです

ご確認ありがとうございます。オフならその影響もなさそうですね。

レイアウトに移動した後に、モデル空間でクリップボードにコピーしたオブジェクトが、うまく貼り付けられていないようです。

クリップボードからの貼り付けのタイミングに問題がありそうなので、
(setvar "ctab" ln)　のあとに
(command "delay" 1000)
を入れてみてもらえますか？

何度も申し訳ありません
ご指示の通りに(setvar "ctab" ln)のあとに
(command "delay" 1000)を入れましたが状況は同じです
クリップボードの履歴をオンにしても同じでした

うーん、そうなると原因が全く分かりませんね。
使えているケースもあるので、何らかの設定が関係しているのかもしれませんが・・・

うまくいかない理由は、
レイアウトへの貼付けが出来ていないか、レイアウトでトリムされた物がコピー出来ていない。
ではないだろうか？

という事で、モデル空間だけで処理するように変更してみました。
ARES CADは持っていませんので、動くかどうか。


(defun c:cpore (/ pt1 pt2 pta1 pta2 bpt flg pit1 pit2 RecA #OSNAPCOORD #LTSCALE)

(initget "C D")
(or (setq flg (getkword "\n[コピー(C)/削除(D)] <コピー>:")) (setq flg "C"))

(if (not (and (setq pt1 (getpoint "\n一方のコーナーを指定:"))
(setq pt2 (getcorner pt1 "\nもう一方のコーナーを指定:")))) (exit))

(setq pit1 (setq pit2 (* (distance pt1 pt2) 0.008)))
(setq pta1 (list (min (car pt1) (car pt2)) (min (cadr pt1) (cadr pt2))))
(setq pta2 (list (max (car pt1) (car pt2)) (max (cadr pt1) (cadr pt2))))

(if (= (strcase flg) "C")
(if (setq bpt (getpoint "\n基点を指定:"))
(setq pit1 (* pit1 -1))
(exit)
)
)

(defun Fence_Trim (pit a1 a2 RecA / b1 b2 pt1 pt2 pt3 pt4 RecB)
(setq b1 (list (+ (car a1) (* 2 pit)) (+ (cadr a1) (* 2 pit))))
(setq b2 (list (- (car a2) (* 2 pit)) (- (cadr a2) (* 2 pit))))
(command "rectang" b1 b2)
(setq RecB (entlast))
(setq pt1 (list (+ (car a1) pit) (+ (cadr a1) pit)))
(setq pt2 (list (- (car a2) pit) (+ (cadr a1) pit)))
(setq pt3 (list (- (car a2) pit) (- (cadr a2) pit)))
(setq pt4 (list (+ (car a1) pit) (- (cadr a2) pit)))
(command "trim" RecA RecB "" "f" pt1 pt2 "" "")
(command "trim" RecA RecB "" "f" pt2 pt3 "" "")
(command "trim" RecA RecB "" "f" pt3 pt4 "" "")
(command "trim" RecA RecB "" "f" pt4 pt1 "" "")
(entdel RecB)
)

(command "undo" "be")
(command "zoom" "w" pta1 pta2 "zoom" "s" "0.9x")
(setq #OSNAPCOORD (getvar "OSNAPCOORD"))
(setvar "OSNAPCOORD" 1)
(setq #LTSCALE (getvar "LTSCALE"))
(setvar "LTSCALE" 0.00000001);破線等の隙間を取りこぼさない対策

(command "rectang" pta1 pta2)
(setq RecA (entlast))
(repeat 4
(Fence_Trim pit1 pta1 pta2 RecA)
(setq pit1 (/ pit1 2)); トリム間隔を徐々に詰める
)
(entdel RecA)

(if (= (strcase flg) "C")
(command "copybase" bpt "c" pta1 pta2 "" "undo" "e" "u" "pasteclip")
(progn
(command "erase" "w"
(list (+ (car pta1) pit2) (+ (cadr pta1) pit2))
(list (- (car pta2) pit2) (- (cadr pta2) pit2))
"")
(setvar "OSNAPCOORD" #OSNAPCOORD)
(setvar "LTSCALE" #LTSCALE)
(command "zoom" "p" "zoom" "p" "undo" "e")
)
)
(princ)
)

今度のものは確実に切り取りできています
ありがとうございました
お忙しい中ご対応いただき恐悦です