菜单式拖拽getpoint

dcl1214

1. (defun $getpoint-rec$ (msg1 msg2 LST / go pt1 pt2)
   
2. ;调用示例 ($getpoint-rec$  NIL  NIL  NIL)
   
3.   (OR msg1 (SETQ msg1 "请点击左键开始框选"))
   
4.   (OR msg2 (SETQ msg2 "请拖动鼠标按下左键"))
   
5.   (SETQ msg1 (strcat msg1 "\nA   菜单1\nF   菜单2\nS   设置"))
   
6.   (SETQ GO T)
   
7.   (while (AND GO (not pt1))
   
8.     (initget 39 "a f s")
   
9.     (setq
   
10.       pt1 (vl-catch-all-apply
    
11.       'getpoint
    
12.       (list msg1)
    
13.     )
    
14.     )
    
15.     (AND (vl-catch-all-error-p pt1) (setq pt1 nil))
    
16.     (cond
    
17.       ((and pt1 (= (type pt1) 'str) (member pt1 (list "a" "A")))
    
18.        (alert "按下了键盘字母A，开始执行($a$)")
    
19.        (SETQ PT1 NIL)
    
20.       )
    
21.       ((and pt1 (= (type pt1) 'str) (member pt1 (list "f" "F")))
    
22.        (alert "按下了键盘字母F，开始执行($f$)")
    
23.        (SETQ PT1 NIL)
    
24.       )
    
25.       ((and pt1 (= (type pt1) 'str) (member pt1 (list "s" "S")))
    
26.        (alert "按下了键盘字母S，开始执行选项设置($sz$)")
    
27.        (SETQ PT1 NIL)
    
28.       )
    
29.     )
    
30.     (AND pt1 (SETQ GO NIL))
    
31.   )
    
32.   (SETQ GO T)
    
33.   (while (AND GO (not pt2))
    
34.     (setq
    
35.       pt2 (vl-catch-all-apply
    
36.       'getcorner
    
37.       (list pt1 msg2)
    
38.     )
    
39.     )
    
40.     (AND (vl-catch-all-error-p pt2) (setq pt2 nil))
    
41.     (AND pt2 (SETQ GO NIL))
    
42.   )
    
43.   (SETQ XS (MAPCAR 'CAR (LIST PT1 PT2)))
    
44.   (SETQ YS (MAPCAR 'CADR (LIST PT1 PT2)))
    
45.   (SETQ PT1 (LIST (APPLY 'MIN XS) (APPLY 'MIN YS) 0))
    
46.   (SETQ PT2 (LIST (APPLY 'MAX XS) (APPLY 'MAX YS) 0))
    
47.   (list PT1 pt2)
    
48. )

(defun $getpoint-rec$ (msg1 msg2 LST / go pt1 pt2)<br /> ;调用示例 ($getpoint-rec$  NIL  NIL  NIL)<br />   (OR msg1 (SETQ msg1 "请点击左键开始框选"))<br />   (OR msg2 (SETQ msg2 "请拖动鼠标按下左键"))<br />   (SETQ msg1 (strcat msg1 "\nA   菜单1\nF   菜单2\nS   设置"))<br />   (SETQ GO T)<br />   (while (AND GO (not pt1))<br />     (initget 39 "a f s")<br />     (setq<br />       pt1 (vl-catch-all-apply<br />       'getpoint<br />       (list msg1)<br />     )<br />     )<br />     (AND (vl-catch-all-error-p pt1) (setq pt1 nil))<br />     (cond<br />       ((and pt1 (= (type pt1) 'str) (member pt1 (list "a" "A")))<br />        (alert "按下了键盘字母A，开始执行($a$)")<br />        (SETQ PT1 NIL)<br />       )<br />       ((and pt1 (= (type pt1) 'str) (member pt1 (list "f" "F")))<br />        (alert "按下了键盘字母F，开始执行($f$)")<br />        (SETQ PT1 NIL)<br />       )<br />       ((and pt1 (= (type pt1) 'str) (member pt1 (list "s" "S")))<br />        (alert "按下了键盘字母S，开始执行选项设置($sz$)")<br />        (SETQ PT1 NIL)<br />       )<br />     )<br />     (AND pt1 (SETQ GO NIL))<br />   )<br />   (SETQ GO T)<br />   (while (AND GO (not pt2))<br />     (setq<br />       pt2 (vl-catch-all-apply<br />       'getcorner<br />       (list pt1 msg2)<br />     )<br />     )<br />     (AND (vl-catch-all-error-p pt2) (setq pt2 nil))<br />     (AND pt2 (SETQ GO NIL))<br />   )<br />   (SETQ XS (MAPCAR 'CAR (LIST PT1 PT2)))<br />   (SETQ YS (MAPCAR 'CADR (LIST PT1 PT2)))<br />   (SETQ PT1 (LIST (APPLY 'MIN XS) (APPLY 'MIN YS) 0))<br />   (SETQ PT2 (LIST (APPLY 'MAX XS) (APPLY 'MAX YS) 0))<br />   (list PT1 pt2)<br /> )

atone

点赞收藏，牛

潘成祥2015

这种可以滚动的代码，
怎么上传的

zhangcan0515

潘成祥2015 发表于 2024-5-4 15:10
这种可以滚动的代码，
怎么上传的

笑脸旁边有个<>

moranyuyan

谢谢分享，收藏了

潘成祥2015

zhangcan0515 发表于 2024-5-4 16:17
笑脸旁边有个

谢谢