【源码分享】完美版框选剪切与延伸 for 2004

wowan1314 · 发表于 2017-4-4 16:54:37

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 newer 于 2017-4-4 17:24 编辑

CAD2006以下的版本，无法框选剪切与延伸，起初对lsp的结缘也源于此诉求。
论坛上其他框选剪切与延伸都无法实现对块内实体作为剪切边的功能，本程序完美的解决了此问题，与之后的CAD版本的剪切命令完全一样。

主程序如下，供参考思路。

;;;============{ 框选剪切延伸 }====;;;
;;;功能：可以点选和框选的修剪和延伸命令 ;;;
;;; BY wowan1314 2013.6 ;;;
;;;===========================;;;
(if (< (atof (substr (getvar "acadver") 1 4)) 16.2)
(progn
(defun c:w () (trim&extend1314 t))
(defun c:z () (trim&extend1314 nil))
;;主函数
(defun trim&extend1314
(yy:cmd / snap s1 trimb p1
p2 trimdx pt1 xx p3 p4 vectors
pt3 pt4 zhuj1 zhuj2 cmd
)
(if yy:cmd
(setq cmd "_.trim"
zhuj1 "\n选择剪切边...<右键全部>:"
zhuj2 "\n选择要修剪的对象，或按住 Shift 键选择要延伸的对象，或 [投影(P)/边(E)/栏选(F)/放弃(Z)]:"
)
(setq cmd "_.extend"
zhuj1 "\n选择边界的边...<右键全部>:"
zhuj2 "\n选择要延伸的对象，或按住 Shift 键选择要剪切的对象，或 [投影(P)/边(E)/栏选(F)/放弃(Z)]:"
)
)
(setq snap (getvar "osmode"))
(if (cadr (ssgetfirst))
(if
(setq s1
(ssget ":S"
'((-4 . "<AND")
(0 . "~DIMENSION")
(0 . "~INSERT")
(-4 . "AND>")
)
)
)
nil
(princ "\n不是有效边界")
)
)
(if s1
(vl-cmdf cmd s1)
(progn
(setq trimb
(vl-catch-all-apply
'(lambda (/ p1 p2 p3 p4)
(vl-cmdf cmd)
(setq p1 1314)(setvar "osmode" 0)
(while p1
(princ zhuj1)
(if (setq p1 (yy:kuanzi '(t 12 2)))
(if (listp p1)
(if (ssget p1 '((0 . "~DIMENSION")))
(progn (setq p2 (pickbox p1) p1 (car p2) p2 (cadr p2));
(vl-cmdf "C" p1 p2)
)
(if p1
(progn
(setq
p2 (yy:getcorner p1 "指定对角点:" 1314 nil)
)
(vl-cmdf (if (minusp (cadr p2))
"_c"
"_w"
)
)
(vl-cmdf p1 (car p2))
)
)
)
)
(setq p1 nil)
)
)
)
)
)
)
)
(if (vl-catch-all-error-p trimb)
(setq s1 nil
trimb nil
)
(setq trimb 1314)
)
(if (or trimb s1)
(progn
(vl-cmdf "")
(setq
trimdx
(vl-catch-all-apply
'(lambda (/ p1 p2 p3 p4)
(setq p1 1314)
(setvar "osmode" 0)
(while p1
(princ zhuj2)
(if (setq p1 (yy:kuanzi '(t 12 2)))
(cond
;;分支零下一：栏选"F"
((or (= p1 "F") (= p1 "f"))
(progn
(setq pt1 (vectors))
(apply 'command
(append (list "F") pt1 (list ""))
)
(redraw)
)
)
;;分支二：投影选项设置"P"
((or (= p1 "P") (= p1 "p"))
(progn
(initget 4)
(setq
xx
(getint
(strcat
"\n输入投影选项 [无(0)/UCS(1)/视图(2)] <"
(itoa (getvar "PROJMODE"))
">:"
)
)
)
(if (or (= xx 0) (= xx 1) (= xx 2))
(setvar "PROJMODE" xx)
)
)
)
;;分支三：边延伸选项设置"E"
((or (= p1 "E") (= p1 "e"))
(progn
(initget 4)
(setq xx
(getint
(strcat
"\n输入隐含边延伸模式 [不延伸(0)/延伸(1)] <"
(itoa (getvar "EDGEMODE"))
">:"
)
)
)
(if (or (= xx 0) (= xx 1))
(setvar "EDGEMODE" xx)
)
)
)
;;分支四：撤销上一步操作"U"
((or (= p1 "Z") (= p1 "z"))
(command "U")
)
;;分支五：正常操作
((listp p1)
(if (nentselp p1)
(progn ;(SETQ P2 (osnap P1 "_near"))
(vl-cmdf p1)
)
(progn
(setq p2
(car
(yy:getcorner
p1
"指定对角点:"
1314
1
)
)
)
(setq pt3 (trans p1 1 2)
pt4 (trans p2 1 2)
)
(setq p3 (list (car pt3) (cadr pt4))
p3 (trans p3 2 1)
)
(setq p4 (list (car pt4) (cadr pt3))
p4 (trans p4 2 1)
)
;(GRVECS (LIST 1 P1 P3 1 P3 P2 1 P2 P4 1 P4 P1))
(vl-cmdf "F" p1 p3 p2 p4 p1 "")
)
)
)
)
)
)
)
)
)
(if (vl-catch-all-error-p trimdx)
(progn (vl-cmdf "")
(setvar "osmode" snap)
(redraw)
(princ "*取消*")
)
(vl-cmdf "")
)
)
(progn (vl-cmdf "" "") (redraw) (princ "*取消*"))
)
(setvar "osmode" snap)
(princ)
)
)
)
;;;动态选择点顺序记录
(defun vectors (/ pt ptlist)
(setq ptlist (list (setq pt (getpoint "\n 选择栏选起点 "))))
(princ "\n 选择栏选下一点 ")
(princ)
(while
(setq pt
(progn
(while
(and (setq pt (grread 5 12 0))
(= (car pt) 5)
)
(redraw)
(mapcar
(function
(lambda (x1 x2)
(grdraw x1 x2 6 5)
)
)
(cons (cadr pt) ptlist)
ptlist
)
)
(if (listp (cadr pt))(cadr pt))
)
)
(setq ptlist (cons pt ptlist))
)
)
;;;点变框子的对角点函数
(defun pickbox (pt / si cv)
(setq si (* (/ (getvar "pickbox") (cadr (getvar "screensize"))) (getvar "viewsize") 0.5)
cv (list si si 0)
)
(list (mapcar '+ pt cv) (mapcar '- pt cv))
)
;;;=========={ 选择点鼠标变成框子程序,返回左键点击后坐标点,右键为nil }==========;; 选择点变框子的公共函数
;;;返回值右键返回nil,左键返回点表,按键返回按键的值(分大小写)
(DEFUN YY:KUANZI (LST / LOOP CODE);;;鼠标变框子函数
(setq loop T)
(while loop
(setq code (APPLY 'grread LST))
(cond
((= (car code) 5) NIL ) ;;; 鼠标移动
((= (car code) 3) (SETQ LOOP NIL CODE (CADR CODE))) ;;; 鼠标左键
((= (car code) 11) (SETQ LOOP NIL CODE NIL)) ;;; 鼠标右键，右键设置为回车时
((= (car code) 25) (SETQ LOOP NIL CODE NIL)) ;;; 鼠标右键，右键设置为屏幕菜单时
((equal code '(2 0)) (SETQ LOOP NIL CODE "CTRL-@")) ;;; CTRL-@
((equal code '(2 1)) (SETQ LOOP NIL CODE "CTRL-A")) ;;; CTRL-A
((equal code '(2 2)) (SETQ LOOP NIL CODE "CTRL-B或F9")) ;;; CTRL-B或F9
((equal code '(2 3)) (SETQ LOOP NIL CODE "CTRL-C或F12")) ;;; CTRL-C或F12
((equal code '(2 4)) (SETQ LOOP NIL CODE "CTRL-D或F6")) ;;; CTRL-D或F6
((equal code '(2 5)) (SETQ LOOP NIL CODE "CTRL-E或F5")) ;;; CTRL-E或F5
((equal code '(2 6)) (SETQ LOOP NIL CODE "CTRL-F或F3")) ;;; CTRL-F或F3
((equal code '(2 7)) (SETQ LOOP NIL CODE "CTRL-G或F7")) ;;; CTRL-G或F7
((equal code '(2 8)) (SETQ LOOP NIL CODE "CTRL-H或退格")) ;;; CTRL-H或退格
((equal code '(2 9)) (SETQ LOOP NIL CODE "CTRL-I或TAB")) ;;; CTRL-I或Tab
((equal code '(2 10)) (SETQ LOOP NIL CODE "CTRL-J")) ;;; CTRL-J
((equal code '(2 11)) (SETQ LOOP NIL CODE "CTRL-K")) ;;; CTRL-K
((equal code '(2 12)) (SETQ LOOP NIL CODE "CTRL-L")) ;;; CTRL-L
((equal code '(2 13)) (SETQ LOOP NIL CODE "CTRL-M或回车")) ;;; CTRL-M或回车
((equal code '(2 14)) (SETQ LOOP NIL CODE "CTRL-N")) ;;; CTRL-N
((equal code '(2 15)) (SETQ LOOP NIL CODE "CTRL-O或F8")) ;;; CTRL-O或F8
((equal code '(2 16)) (SETQ LOOP NIL CODE "CTRL-P")) ;;; CTRL-P
((equal code '(2 17)) (SETQ LOOP NIL CODE "CTRL-Q")) ;;; CTRL-Q
((equal code '(2 18)) (SETQ LOOP NIL CODE "CTRL-R")) ;;; CTRL-R
((equal code '(2 19)) (SETQ LOOP NIL CODE "CTRL-S")) ;;; CTRL-S
((equal code '(2 20)) (SETQ LOOP NIL CODE "CTRL-I或F4")) ;;; CTRL-T或F4
((equal code '(2 21)) (SETQ LOOP NIL CODE "CTRL-U或F10")) ;;; CTRL-U或F10
((equal code '(2 22)) (SETQ LOOP NIL CODE "CTRL-V")) ;;; CTRL-V
((equal code '(2 23)) (SETQ LOOP NIL CODE "CTRL-W或F11")) ;;; CTRL-W或F11
((equal code '(2 24)) (SETQ LOOP NIL CODE "CTRL-X")) ;;; CTRL-X
((equal code '(2 25)) (SETQ LOOP NIL CODE "CTRL-Y")) ;;; CTRL-Y
((equal code '(2 26)) (SETQ LOOP NIL CODE "CTRL-Z")) ;;; CTRL-Z
((equal code '(2 27)) (SETQ LOOP NIL CODE "CTRL-[或ESC")) ;;; CTRL-[或ESC
((equal code '(2 28)) (SETQ LOOP NIL CODE "CTRL-反斜杠")) ;;; CTRL-\
((equal code '(2 29)) (SETQ LOOP NIL CODE "CTRL-]")) ;;; CTRL-]
((equal code '(2 30)) (SETQ LOOP NIL CODE "CTRL-^")) ;;; CTRL-^
((equal code '(2 31)) (SETQ LOOP NIL CODE "CTRL-_")) ;;; CTRL-_
((equal code '(2 32)) (SETQ LOOP NIL CODE "空格")) ;;; 空格键
((equal code '(2 33)) (SETQ LOOP NIL CODE "!")) ;;; !键
((equal code '(2 34)) (SETQ LOOP NIL CODE "双引号")) ;;; "键
((equal code '(2 35)) (SETQ LOOP NIL CODE "#")) ;;; #键
((equal code '(2 36)) (SETQ LOOP NIL CODE "$")) ;;; $键
((equal code '(2 37)) (SETQ LOOP NIL CODE "%")) ;;; %键
((equal code '(2 38)) (SETQ LOOP NIL CODE "&")) ;;; &键
((equal code '(2 39)) (SETQ LOOP NIL CODE "单引号")) ;;; '键
((equal code '(2 40)) (SETQ LOOP NIL CODE "(")) ;;; (键
((equal code '(2 41)) (SETQ LOOP NIL CODE ")")) ;;; )键
((equal code '(2 42)) (SETQ LOOP NIL CODE "星号")) ;;; *键
((equal code '(2 43)) (SETQ LOOP NIL CODE "+")) ;;; +键
((equal code '(2 44)) (SETQ LOOP NIL CODE ",")) ;;; ,键
((equal code '(2 45)) (SETQ LOOP NIL CODE "-")) ;;; -键
((equal code '(2 46)) (SETQ LOOP NIL CODE "点")) ;;; .键
((equal code '(2 47)) (SETQ LOOP NIL CODE "/")) ;;; /键
((equal code '(2 48)) (SETQ LOOP NIL CODE "0")) ;;; 0键
((equal code '(2 49)) (SETQ LOOP NIL CODE "1")) ;;; 1键
((equal code '(2 50)) (SETQ LOOP NIL CODE "2")) ;;; 2键
((equal code '(2 51)) (SETQ LOOP NIL CODE "3")) ;;; 3键
((equal code '(2 52)) (SETQ LOOP NIL CODE "4")) ;;; 4键
((equal code '(2 53)) (SETQ LOOP NIL CODE "5")) ;;; 5键
((equal code '(2 54)) (SETQ LOOP NIL CODE "6")) ;;; 6键
((equal code '(2 55)) (SETQ LOOP NIL CODE "7")) ;;; 7键
((equal code '(2 56)) (SETQ LOOP NIL CODE "8")) ;;; 8键
((equal code '(2 57)) (SETQ LOOP NIL CODE "9")) ;;; 9键
((equal code '(2 58)) (SETQ LOOP NIL CODE "冒号")) ;;; :键
((equal code '(2 59)) (SETQ LOOP NIL CODE "分号")) ;;; ;键
((equal code '(2 60)) (SETQ LOOP NIL CODE "小于号")) ;;; <键
((equal code '(2 61)) (SETQ LOOP NIL CODE "等号")) ;;; =键
((equal code '(2 62)) (SETQ LOOP NIL CODE "大于号")) ;;; >键
((equal code '(2 63)) (SETQ LOOP NIL CODE "问号")) ;;; ?键
((equal code '(2 64)) (SETQ LOOP NIL CODE "@")) ;;; @键
((equal code '(2 65)) (SETQ LOOP NIL CODE "A")) ;;; A键
((equal code '(2 66)) (SETQ LOOP NIL CODE "B")) ;;; B键
((equal code '(2 67)) (SETQ LOOP NIL CODE "C")) ;;; C键
((equal code '(2 68)) (SETQ LOOP NIL CODE "D")) ;;; D键
((equal code '(2 69)) (SETQ LOOP NIL CODE "E")) ;;; E键
((equal code '(2 70)) (SETQ LOOP NIL CODE "F")) ;;; F键
((equal code '(2 71)) (SETQ LOOP NIL CODE "G")) ;;; G键
((equal code '(2 72)) (SETQ LOOP NIL CODE "H")) ;;; H键
((equal code '(2 73)) (SETQ LOOP NIL CODE "I")) ;;; I键
((equal code '(2 74)) (SETQ LOOP NIL CODE "J")) ;;; J键
((equal code '(2 75)) (SETQ LOOP NIL CODE "K")) ;;; K键
((equal code '(2 76)) (SETQ LOOP NIL CODE "L")) ;;; L键
((equal code '(2 77)) (SETQ LOOP NIL CODE "M")) ;;; M键
((equal code '(2 78)) (SETQ LOOP NIL CODE "N")) ;;; N键
((equal code '(2 79)) (SETQ LOOP NIL CODE "O")) ;;; O键
((equal code '(2 80)) (SETQ LOOP NIL CODE "P")) ;;; P键
((equal code '(2 81)) (SETQ LOOP NIL CODE "Q")) ;;; Q键
((equal code '(2 82)) (SETQ LOOP NIL CODE "R")) ;;; R键
((equal code '(2 83)) (SETQ LOOP NIL CODE "S")) ;;; S键
((equal code '(2 84)) (SETQ LOOP NIL CODE "T")) ;;; T键
((equal code '(2 85)) (SETQ LOOP NIL CODE "U")) ;;; U键
((equal code '(2 86)) (SETQ LOOP NIL CODE "V")) ;;; V键
((equal code '(2 87)) (SETQ LOOP NIL CODE "W")) ;;; W键
((equal code '(2 88)) (SETQ LOOP NIL CODE "X")) ;;; X键
((equal code '(2 89)) (SETQ LOOP NIL CODE "Y")) ;;; Y键
((equal code '(2 90)) (SETQ LOOP NIL CODE "Z")) ;;; Z键
((equal code '(2 91)) (SETQ LOOP NIL CODE "[")) ;;; [键
((equal code '(2 92)) (SETQ LOOP NIL CODE "反斜杠")) ;;; \键
((equal code '(2 93)) (SETQ LOOP NIL CODE "]")) ;;; ]键
((equal code '(2 94)) (SETQ LOOP NIL CODE "^")) ;;; ^键
((equal code '(2 95)) (SETQ LOOP NIL CODE "_")) ;;; _键
((equal code '(2 96)) (SETQ LOOP NIL CODE "单引号")) ;;; `键
((equal code '(2 97)) (SETQ LOOP NIL CODE "a")) ;;; a键
((equal code '(2 98)) (SETQ LOOP NIL CODE "b")) ;;; b键
((equal code '(2 99)) (SETQ LOOP NIL CODE "c")) ;;; c键
((equal code '(2 100))(SETQ LOOP NIL CODE "d")) ;;; d键
((equal code '(2 101))(SETQ LOOP NIL CODE "e")) ;;; e键
((equal code '(2 102))(SETQ LOOP NIL CODE "f")) ;;; f键
((equal code '(2 103))(SETQ LOOP NIL CODE "g")) ;;; g键
((equal code '(2 104))(SETQ LOOP NIL CODE "h")) ;;; h键
((equal code '(2 105))(SETQ LOOP NIL CODE "i")) ;;; i键
((equal code '(2 106))(SETQ LOOP NIL CODE "j")) ;;; j键
((equal code '(2 107))(SETQ LOOP NIL CODE "k")) ;;; k键
((equal code '(2 108))(SETQ LOOP NIL CODE "l")) ;;; l键
((equal code '(2 109))(SETQ LOOP NIL CODE "m")) ;;; m键
((equal code '(2 110))(SETQ LOOP NIL CODE "n")) ;;; n键
((equal code '(2 111))(SETQ LOOP NIL CODE "o")) ;;; o键
((equal code '(2 112))(SETQ LOOP NIL CODE "p")) ;;; p键
((equal code '(2 113))(SETQ LOOP NIL CODE "q")) ;;; q键
((equal code '(2 114))(SETQ LOOP NIL CODE "r")) ;;; r键
((equal code '(2 115))(SETQ LOOP NIL CODE "s")) ;;; s键
((equal code '(2 116))(SETQ LOOP NIL CODE "t")) ;;; t键
((equal code '(2 117))(SETQ LOOP NIL CODE "u")) ;;; u键
((equal code '(2 118))(SETQ LOOP NIL CODE "v")) ;;; v键
((equal code '(2 119))(SETQ LOOP NIL CODE "w")) ;;; w键
((equal code '(2 120))(SETQ LOOP NIL CODE "x")) ;;; x键
((equal code '(2 121))(SETQ LOOP NIL CODE "y")) ;;; y键
((equal code '(2 122))(SETQ LOOP NIL CODE "z")) ;;; z键
((equal code '(2 123))(SETQ LOOP NIL CODE "大开括号")) ;;; {键
((equal code '(2 124))(SETQ LOOP NIL CODE "|")) ;;; |键
((equal code '(2 125))(SETQ LOOP NIL CODE "大闭括号")) ;;; }键
((equal code '(2 126))(SETQ LOOP NIL CODE "~")) ;;; ~键
((equal code '(2 127))(SETQ LOOP NIL CODE "删除键")) ;;; Delete键
)
)
CODE
) ;;;END 框子

;;;============{ 框选剪切延伸 }====;;; 
;;;功能：可以点选和框选的修剪和延伸命令    ;;; 
;;;       BY wowan1314  2013.6           ;;; 
;;;===========================;;; 
(if (< (atof (substr (getvar "acadver") 1 4)) 16.2) 
    (progn 
        (defun c:w () (trim&extend1314 t)) 
        (defun c:z () (trim&extend1314 nil)) 
        ;;主函数 
        (defun trim&extend1314 
            (yy:cmd / snap s1 trimb p1 
                p2 trimdx pt1 xx p3 p4 vectors 
                pt3 pt4 zhuj1 zhuj2 cmd 
            ) 
 
            (if yy:cmd 
                (setq cmd "_.trim" 
                    zhuj1 "\n选择剪切边...<右键全部>:" 
                    zhuj2 "\n选择要修剪的对象，或按住 Shift 键选择要延伸的对象，或 [投影(P)/边(E)/栏选(F)/放弃(Z)]:" 
                ) 
                (setq cmd "_.extend" 
                    zhuj1 "\n选择边界的边...<右键全部>:" 
                    zhuj2 "\n选择要延伸的对象，或按住 Shift 键选择要剪切的对象，或 [投影(P)/边(E)/栏选(F)/放弃(Z)]:" 
                ) 
            ) 
            (setq snap (getvar "osmode")) 
            (if (cadr (ssgetfirst)) 
                (if 
                    (setq s1 
                        (ssget ":S" 
                            '((-4 . "<AND") 
                                (0 . "~DIMENSION") 
                                (0 . "~INSERT") 
                                (-4 . "AND>") 
                            ) 
                        ) 
                    ) 
                    nil 
                    (princ "\n不是有效边界") 
                ) 
            ) 
            (if s1 
                (vl-cmdf cmd s1) 
                (progn 
                    (setq trimb 
                        (vl-catch-all-apply 
                            '(lambda (/ p1 p2 p3 p4) 
                                (vl-cmdf cmd) 
                                (setq p1 1314)(setvar "osmode" 0) 
                                (while p1 
                                    (princ zhuj1) 
                                    (if (setq p1 (yy:kuanzi '(t 12 2))) 
                                        (if (listp p1) 
                                            (if (ssget p1 '((0 . "~DIMENSION"))) 
                                                (progn (setq p2 (pickbox p1) p1 (car p2) p2 (cadr p2)); 
                                                    (vl-cmdf "C" p1 p2) 
                                                ) 
                                                (if p1 
                                                    (progn 
                                                        (setq 
                                                            p2 (yy:getcorner p1 "指定对角点:" 1314 nil) 
                                                        ) 
                                                        (vl-cmdf (if (minusp (cadr p2)) 
                                                                "_c" 
                                                                "_w" 
                                                            ) 
                                                        ) 
                                                        (vl-cmdf p1 (car p2)) 
                                                    ) 
                                                ) 
                                            ) 
                                        ) 
                                        (setq p1 nil) 
                                    ) 
                                ) 
                            ) 
                        ) 
                    ) 
                ) 
            ) 
            (if (vl-catch-all-error-p trimb) 
                (setq s1 nil 
                    trimb nil 
                ) 
                (setq trimb 1314) 
            ) 
            (if (or trimb s1) 
                (progn 
                    (vl-cmdf "") 
                    (setq 
                        trimdx 
                        (vl-catch-all-apply 
                            '(lambda (/ p1 p2 p3 p4) 
                                (setq p1 1314) 
                                (setvar "osmode" 0) 
                                (while p1 
                                    (princ zhuj2) 
                                    (if (setq p1 (yy:kuanzi '(t 12 2))) 
                                        (cond 
                                            ;;分支零下一：栏选"F" 
                                            ((or (= p1 "F") (= p1 "f")) 
                                                (progn 
                                                    (setq pt1 (vectors)) 
                                                    (apply 'command 
                                                        (append (list "F") pt1 (list "")) 
                                                    ) 
                                                    (redraw) 
                                                ) 
                                            ) 
                                            ;;分支二：投影选项设置"P" 
                                            ((or (= p1 "P") (= p1 "p")) 
                                                (progn 
                                                    (initget 4) 
                                                    (setq 
                                                        xx 
                                                        (getint 
                                                            (strcat 
                                                                "\n输入投影选项 [无(0)/UCS(1)/视图(2)] <" 
                                                                (itoa (getvar "PROJMODE")) 
                                                                ">:" 
                                                            ) 
                                                        ) 
                                                    ) 
                                                    (if (or (= xx 0) (= xx 1) (= xx 2)) 
                                                        (setvar "PROJMODE" xx) 
                                                    ) 
                                                ) 
                                            ) 
                                            ;;分支三：边延伸选项设置"E" 
                                            ((or (= p1 "E") (= p1 "e")) 
                                                (progn 
                                                    (initget 4) 
                                                    (setq xx 
                                                        (getint 
                                                            (strcat 
                                                                "\n输入隐含边延伸模式 [不延伸(0)/延伸(1)] <" 
                                                                (itoa (getvar "EDGEMODE")) 
                                                                ">:" 
                                                            ) 
                                                        ) 
                                                    ) 
                                                    (if (or (= xx 0) (= xx 1)) 
                                                        (setvar "EDGEMODE" xx) 
                                                    ) 
                                                ) 
                                            ) 
                                            ;;分支四：撤销上一步操作"U" 
                                            ((or (= p1 "Z") (= p1 "z")) 
                                                (command "U") 
                                            ) 
                                            ;;分支五：正常操作 
                                            ((listp p1) 
                                                (if (nentselp p1) 
                                                    (progn ;(SETQ P2 (osnap P1 "_near")) 
                                                        (vl-cmdf p1) 
                                                    ) 
                                                    (progn 
                                                        (setq p2 
                                                            (car 
                                                                (yy:getcorner 
                                                                    p1 
                                                                    "指定对角点:" 
                                                                    1314 
                                                                    1 
                                                                ) 
                                                            ) 
                                                        ) 
                                                        (setq pt3 (trans p1 1 2) 
                                                            pt4 (trans p2 1 2) 
                                                        ) 
                                                        (setq p3 (list (car pt3) (cadr pt4)) 
                                                            p3 (trans p3 2 1) 
                                                        ) 
                                                        (setq p4 (list (car pt4) (cadr pt3)) 
                                                            p4 (trans p4 2 1) 
                                                        ) 
                                                        ;(GRVECS (LIST 1 P1 P3 1 P3 P2 1 P2 P4 1 P4 P1)) 
                                                        (vl-cmdf "F" p1 p3 p2 p4 p1 "") 
                                                    ) 
                                                ) 
                                            ) 
                                        ) 
                                    ) 
                                ) 
                            ) 
                        ) 
                    ) 
                    (if (vl-catch-all-error-p trimdx) 
                        (progn (vl-cmdf "") 
                            (setvar "osmode" snap) 
                            (redraw) 
                            (princ "*取消*") 
                        ) 
                        (vl-cmdf "") 
                    ) 
                ) 
                (progn (vl-cmdf "" "") (redraw) (princ "*取消*")) 
            ) 
            (setvar "osmode" snap) 
            (princ) 
        ) 
    ) 
) 
            ;;;动态选择点顺序记录 
            (defun vectors (/ pt ptlist) 
                (setq ptlist (list (setq pt (getpoint "\n 选择栏选起点  ")))) 
                (princ "\n 选择栏选下一点  ") 
                (princ) 
                (while 
                    (setq pt 
                        (progn 
                            (while 
                                (and (setq pt (grread 5 12 0)) 
                                    (= (car pt) 5) 
                                ) 
                                (redraw) 
                                (mapcar 
                                    (function 
                                        (lambda (x1 x2) 
                                            (grdraw x1 x2 6 5) 
                                        ) 
                                    ) 
                                    (cons (cadr pt) ptlist) 
                                    ptlist 
                                ) 
                            ) 
                            (if (listp (cadr pt))(cadr pt)) 
                        ) 
                    ) 
                    (setq ptlist (cons pt ptlist)) 
                ) 
            ) 
;;;点变框子的对角点函数 
  (defun pickbox (pt / si cv) 
    (setq si (* (/ (getvar "pickbox") (cadr (getvar "screensize"))) (getvar "viewsize") 0.5) 
          cv (list si si 0) 
    ) 
    (list (mapcar '+ pt cv) (mapcar '- pt cv)) 
  ) 
;;;=========={  选择点鼠标变成框子程序,返回左键点击后坐标点,右键为nil  }==========;; 选择点变框子的公共函数 
;;;返回值 右键返回nil,左键返回点表,按键返回按键的值(分大小写) 
(DEFUN YY:KUANZI (LST / LOOP CODE);;;鼠标变框子函数 
 (setq loop T) 
 (while loop 
  (setq code (APPLY 'grread LST)) 
  (cond 
    ((= (car code) 5)     NIL )                                       ;;; 鼠标移动 
    ((= (car code) 3)     (SETQ LOOP NIL CODE (CADR CODE)))           ;;; 鼠标左键 
    ((= (car code) 11)    (SETQ LOOP NIL CODE NIL))                   ;;; 鼠标右键，右键设置为回车时 
    ((= (car code) 25)    (SETQ LOOP NIL CODE NIL))                   ;;; 鼠标右键，右键设置为屏幕菜单时 
    ((equal code '(2 0))  (SETQ LOOP NIL CODE "CTRL-@"))              ;;; CTRL-@ 
    ((equal code '(2 1))  (SETQ LOOP NIL CODE "CTRL-A"))              ;;; CTRL-A 
    ((equal code '(2 2))  (SETQ LOOP NIL CODE "CTRL-B或F9"))          ;;; CTRL-B或F9 
    ((equal code '(2 3))  (SETQ LOOP NIL CODE "CTRL-C或F12"))         ;;; CTRL-C或F12 
    ((equal code '(2 4))  (SETQ LOOP NIL CODE "CTRL-D或F6"))          ;;; CTRL-D或F6 
    ((equal code '(2 5))  (SETQ LOOP NIL CODE "CTRL-E或F5"))          ;;; CTRL-E或F5 
    ((equal code '(2 6))  (SETQ LOOP NIL CODE "CTRL-F或F3"))          ;;; CTRL-F或F3 
    ((equal code '(2 7))  (SETQ LOOP NIL CODE "CTRL-G或F7"))          ;;; CTRL-G或F7 
    ((equal code '(2 8))  (SETQ LOOP NIL CODE "CTRL-H或退格"))        ;;; CTRL-H或退格 
    ((equal code '(2 9))  (SETQ LOOP NIL CODE "CTRL-I或TAB"))         ;;; CTRL-I或Tab 
    ((equal code '(2 10)) (SETQ LOOP NIL CODE "CTRL-J"))              ;;; CTRL-J 
    ((equal code '(2 11)) (SETQ LOOP NIL CODE "CTRL-K"))              ;;; CTRL-K 
    ((equal code '(2 12)) (SETQ LOOP NIL CODE "CTRL-L"))              ;;; CTRL-L 
    ((equal code '(2 13)) (SETQ LOOP NIL CODE "CTRL-M或回车"))        ;;; CTRL-M或回车 
    ((equal code '(2 14)) (SETQ LOOP NIL CODE "CTRL-N"))              ;;; CTRL-N 
    ((equal code '(2 15)) (SETQ LOOP NIL CODE "CTRL-O或F8"))          ;;; CTRL-O或F8 
    ((equal code '(2 16)) (SETQ LOOP NIL CODE "CTRL-P"))              ;;; CTRL-P 
    ((equal code '(2 17)) (SETQ LOOP NIL CODE "CTRL-Q"))              ;;; CTRL-Q 
    ((equal code '(2 18)) (SETQ LOOP NIL CODE "CTRL-R"))              ;;; CTRL-R 
    ((equal code '(2 19)) (SETQ LOOP NIL CODE "CTRL-S"))              ;;; CTRL-S 
    ((equal code '(2 20)) (SETQ LOOP NIL CODE "CTRL-I或F4"))          ;;; CTRL-T或F4 
    ((equal code '(2 21)) (SETQ LOOP NIL CODE "CTRL-U或F10"))         ;;; CTRL-U或F10 
    ((equal code '(2 22)) (SETQ LOOP NIL CODE "CTRL-V"))              ;;; CTRL-V 
    ((equal code '(2 23)) (SETQ LOOP NIL CODE "CTRL-W或F11"))         ;;; CTRL-W或F11 
    ((equal code '(2 24)) (SETQ LOOP NIL CODE "CTRL-X"))              ;;; CTRL-X 
    ((equal code '(2 25)) (SETQ LOOP NIL CODE "CTRL-Y"))              ;;; CTRL-Y 
    ((equal code '(2 26)) (SETQ LOOP NIL CODE "CTRL-Z"))              ;;; CTRL-Z 
    ((equal code '(2 27)) (SETQ LOOP NIL CODE "CTRL-[或ESC"))         ;;; CTRL-[或ESC 
    ((equal code '(2 28)) (SETQ LOOP NIL CODE "CTRL-反斜杠"))         ;;; CTRL-\ 
    ((equal code '(2 29)) (SETQ LOOP NIL CODE "CTRL-]"))              ;;; CTRL-] 
    ((equal code '(2 30)) (SETQ LOOP NIL CODE "CTRL-^"))              ;;; CTRL-^ 
    ((equal code '(2 31)) (SETQ LOOP NIL CODE "CTRL-_"))              ;;; CTRL-_ 
    ((equal code '(2 32)) (SETQ LOOP NIL CODE "空格"))                ;;; 空格键 
    ((equal code '(2 33)) (SETQ LOOP NIL CODE "!"))                   ;;; !键 
    ((equal code '(2 34)) (SETQ LOOP NIL CODE "双引号"))              ;;; "键 
    ((equal code '(2 35)) (SETQ LOOP NIL CODE "#"))                   ;;; #键 
    ((equal code '(2 36)) (SETQ LOOP NIL CODE "$"))                   ;;; $键 
    ((equal code '(2 37)) (SETQ LOOP NIL CODE "%"))                          ;;; %键 
    ((equal code '(2 38)) (SETQ LOOP NIL CODE "&"))                   ;;; &键 
    ((equal code '(2 39)) (SETQ LOOP NIL CODE "单引号"))              ;;; '键 
    ((equal code '(2 40)) (SETQ LOOP NIL CODE "("))                   ;;; (键 
    ((equal code '(2 41)) (SETQ LOOP NIL CODE ")"))                          ;;; )键 
    ((equal code '(2 42)) (SETQ LOOP NIL CODE "星号"))                ;;; *键 
    ((equal code '(2 43)) (SETQ LOOP NIL CODE "+"))                   ;;; +键 
    ((equal code '(2 44)) (SETQ LOOP NIL CODE ","))                   ;;; ,键 
    ((equal code '(2 45)) (SETQ LOOP NIL CODE "-"))                   ;;; -键 
    ((equal code '(2 46)) (SETQ LOOP NIL CODE "点"))                  ;;; .键 
    ((equal code '(2 47)) (SETQ LOOP NIL CODE "/"))                   ;;; /键 
    ((equal code '(2 48)) (SETQ LOOP NIL CODE "0"))                   ;;; 0键 
    ((equal code '(2 49)) (SETQ LOOP NIL CODE "1"))                   ;;; 1键 
    ((equal code '(2 50)) (SETQ LOOP NIL CODE "2"))                   ;;; 2键 
    ((equal code '(2 51)) (SETQ LOOP NIL CODE "3"))                   ;;; 3键 
    ((equal code '(2 52)) (SETQ LOOP NIL CODE "4"))                   ;;; 4键 
    ((equal code '(2 53)) (SETQ LOOP NIL CODE "5"))                   ;;; 5键 
    ((equal code '(2 54)) (SETQ LOOP NIL CODE "6"))                   ;;; 6键 
    ((equal code '(2 55)) (SETQ LOOP NIL CODE "7"))                   ;;; 7键 
    ((equal code '(2 56)) (SETQ LOOP NIL CODE "8"))                   ;;; 8键 
    ((equal code '(2 57)) (SETQ LOOP NIL CODE "9"))                   ;;; 9键 
    ((equal code '(2 58)) (SETQ LOOP NIL CODE "冒号"))                ;;; :键 
    ((equal code '(2 59)) (SETQ LOOP NIL CODE "分号"))                ;;; ;键 
    ((equal code '(2 60)) (SETQ LOOP NIL CODE "小于号"))              ;;; <键 
    ((equal code '(2 61)) (SETQ LOOP NIL CODE "等号"))                ;;; =键 
    ((equal code '(2 62)) (SETQ LOOP NIL CODE "大于号"))              ;;; >键 
    ((equal code '(2 63)) (SETQ LOOP NIL CODE "问号"))                ;;; ?键 
    ((equal code '(2 64)) (SETQ LOOP NIL CODE "@"))                   ;;; @键 
    ((equal code '(2 65)) (SETQ LOOP NIL CODE "A"))                   ;;; A键 
    ((equal code '(2 66)) (SETQ LOOP NIL CODE "B"))                   ;;; B键 
    ((equal code '(2 67)) (SETQ LOOP NIL CODE "C"))                   ;;; C键 
    ((equal code '(2 68)) (SETQ LOOP NIL CODE "D"))                   ;;; D键 
    ((equal code '(2 69)) (SETQ LOOP NIL CODE "E"))                   ;;; E键 
    ((equal code '(2 70)) (SETQ LOOP NIL CODE "F"))                   ;;; F键 
    ((equal code '(2 71)) (SETQ LOOP NIL CODE "G"))                   ;;; G键 
    ((equal code '(2 72)) (SETQ LOOP NIL CODE "H"))                   ;;; H键 
    ((equal code '(2 73)) (SETQ LOOP NIL CODE "I"))                   ;;; I键 
    ((equal code '(2 74)) (SETQ LOOP NIL CODE "J"))                   ;;; J键 
    ((equal code '(2 75)) (SETQ LOOP NIL CODE "K"))                   ;;; K键 
    ((equal code '(2 76)) (SETQ LOOP NIL CODE "L"))                   ;;; L键 
    ((equal code '(2 77)) (SETQ LOOP NIL CODE "M"))                   ;;; M键 
    ((equal code '(2 78)) (SETQ LOOP NIL CODE "N"))                   ;;; N键 
    ((equal code '(2 79)) (SETQ LOOP NIL CODE "O"))                   ;;; O键 
    ((equal code '(2 80)) (SETQ LOOP NIL CODE "P"))                   ;;; P键 
    ((equal code '(2 81)) (SETQ LOOP NIL CODE "Q"))                   ;;; Q键 
    ((equal code '(2 82)) (SETQ LOOP NIL CODE "R"))                   ;;; R键 
    ((equal code '(2 83)) (SETQ LOOP NIL CODE "S"))                   ;;; S键 
    ((equal code '(2 84)) (SETQ LOOP NIL CODE "T"))                   ;;; T键 
    ((equal code '(2 85)) (SETQ LOOP NIL CODE "U"))                   ;;; U键 
    ((equal code '(2 86)) (SETQ LOOP NIL CODE "V"))                   ;;; V键 
    ((equal code '(2 87)) (SETQ LOOP NIL CODE "W"))                   ;;; W键 
    ((equal code '(2 88)) (SETQ LOOP NIL CODE "X"))                   ;;; X键 
    ((equal code '(2 89)) (SETQ LOOP NIL CODE "Y"))                   ;;; Y键 
    ((equal code '(2 90)) (SETQ LOOP NIL CODE "Z"))                   ;;; Z键 
    ((equal code '(2 91)) (SETQ LOOP NIL CODE "["))                   ;;; [键 
    ((equal code '(2 92)) (SETQ LOOP NIL CODE "反斜杠"))              ;;; \键 
    ((equal code '(2 93)) (SETQ LOOP NIL CODE "]"))                      ;;; ]键 
    ((equal code '(2 94)) (SETQ LOOP NIL CODE "^"))                   ;;; ^键 
    ((equal code '(2 95)) (SETQ LOOP NIL CODE "_"))                   ;;; _键 
    ((equal code '(2 96)) (SETQ LOOP NIL CODE "单引号"))              ;;; `键 
    ((equal code '(2 97)) (SETQ LOOP NIL CODE "a"))                   ;;; a键 
    ((equal code '(2 98)) (SETQ LOOP NIL CODE "b"))                   ;;; b键 
    ((equal code '(2 99)) (SETQ LOOP NIL CODE "c"))                   ;;; c键 
    ((equal code '(2 100))(SETQ LOOP NIL CODE "d"))                   ;;; d键 
    ((equal code '(2 101))(SETQ LOOP NIL CODE "e"))                   ;;; e键 
    ((equal code '(2 102))(SETQ LOOP NIL CODE "f"))                   ;;; f键 
    ((equal code '(2 103))(SETQ LOOP NIL CODE "g"))                   ;;; g键 
    ((equal code '(2 104))(SETQ LOOP NIL CODE "h"))                   ;;; h键 
    ((equal code '(2 105))(SETQ LOOP NIL CODE "i"))                   ;;; i键 
    ((equal code '(2 106))(SETQ LOOP NIL CODE "j"))                   ;;; j键 
    ((equal code '(2 107))(SETQ LOOP NIL CODE "k"))                   ;;; k键 
    ((equal code '(2 108))(SETQ LOOP NIL CODE "l"))                   ;;; l键 
    ((equal code '(2 109))(SETQ LOOP NIL CODE "m"))                   ;;; m键 
    ((equal code '(2 110))(SETQ LOOP NIL CODE "n"))                   ;;; n键 
    ((equal code '(2 111))(SETQ LOOP NIL CODE "o"))                   ;;; o键 
    ((equal code '(2 112))(SETQ LOOP NIL CODE "p"))                   ;;; p键 
    ((equal code '(2 113))(SETQ LOOP NIL CODE "q"))                   ;;; q键 
    ((equal code '(2 114))(SETQ LOOP NIL CODE "r"))                   ;;; r键 
    ((equal code '(2 115))(SETQ LOOP NIL CODE "s"))                   ;;; s键 
    ((equal code '(2 116))(SETQ LOOP NIL CODE "t"))                   ;;; t键 
    ((equal code '(2 117))(SETQ LOOP NIL CODE "u"))                   ;;; u键 
    ((equal code '(2 118))(SETQ LOOP NIL CODE "v"))                   ;;; v键 
    ((equal code '(2 119))(SETQ LOOP NIL CODE "w"))                   ;;; w键 
    ((equal code '(2 120))(SETQ LOOP NIL CODE "x"))                   ;;; x键 
    ((equal code '(2 121))(SETQ LOOP NIL CODE "y"))                   ;;; y键 
    ((equal code '(2 122))(SETQ LOOP NIL CODE "z"))                   ;;; z键 
    ((equal code '(2 123))(SETQ LOOP NIL CODE "大开括号"))            ;;; {键 
    ((equal code '(2 124))(SETQ LOOP NIL CODE "|"))                      ;;; |键 
    ((equal code '(2 125))(SETQ LOOP NIL CODE "大闭括号"))            ;;; }键 
    ((equal code '(2 126))(SETQ LOOP NIL CODE "~"))                   ;;; ~键 
    ((equal code '(2 127))(SETQ LOOP NIL CODE "删除键"))              ;;; Delete键 
  ) 
 ) 
 CODE 
)      ;;;END 框子

通过编写此程序，额外的发现了一些TRIM命令的妙用。比如框选块内实体然后进行删除复制等，完全没必要矩阵来矩阵去的转换坐标系。
利用好trim命令即可，同时还可以对框选块内的实体达到亮显得作用，以前测试十分成功，可惜测试代码没保存。
理应编写个如何利用trim命令达到框选复制块内实体的程序，但欲编已忘言（lsp忘差不多了）。
有兴趣的自行测试吧。

PS: lsp已与我说再见了，所以对于程序不解释，也不改动。仅供参考。

yoyoho · 发表于 2017-4-5 08:21:37

啥也不说了，感谢wowan1314楼主分享！

sh_h · 发表于 2017-4-5 12:55:07

确实是难得好帖啊，顶先

kqqt6236 · 发表于 2017-4-6 00:08:35

黄瓜哥耐不住寂寞又出山了啊

青梅煮茶 · 发表于 2017-4-6 08:37:42

啥也不说了，感谢楼主分享哇！

yjch · 发表于 2017-4-6 10:27:15

啥也不说了，感谢楼主、谢分享。好好学习天天向上

栋梁 · 发表于 2018-8-17 21:37:32

怎么加载不了2014

小帥 · 发表于 2019-12-7 08:38:51

感謝大大分享我會好好利用的

账号		自动登录	找回密码
密码			立即注册

[原创] 【源码分享】完美版框选剪切与延伸 for 2004

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分