dcl1214 发表于 2024-5-3 14:49:46

菜单式拖拽getpoint

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

atone 发表于 2024-5-4 13:52:05

点赞收藏，牛

潘成祥2015 发表于 2024-5-4 15:10:26

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

zhangcan0515 发表于 2024-5-4 16:17:50

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

笑脸旁边有个<>

moranyuyan 发表于 2024-5-6 07:39:40

谢谢分享，收藏了

潘成祥2015 发表于 2024-5-6 08:47:41

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

谢谢
页: [1]
查看完整版本: 菜单式拖拽getpoint