【思路求助】有趣的对话框程序！LISP能实现吗？

自贡黄明儒 · 发表于 2013-5-4 14:40:54

wowan1314 发表于 2013-5-4 13:59
DCL可以记忆上次位置，却不知道怎么根据鼠标位置改动？！

能否具体说明下？最好能举个例子。谢谢

G版说的,是不是可以类似这个http://bbs.mjtd.com/forum.php?mod=viewthread&tid=95767

tianyi1230 · 发表于 2013-5-4 21:33:49

强悍的工具箱啊，结构工程师的福音

davide888 · 发表于 2013-5-5 10:16:38

长见识了

x_s_s_1 · 发表于 2013-5-9 16:54:45

本帖最后由 x_s_s_1 于 2013-5-12 19:17 编辑

楼下程序的编制思路，慢慢添加
1、首先对话框要绘制在视口中，对话框的大小就需要考量，在视口中绘制的是矢量，要达到像素的效果，就要进行换算，如何换算呢？用了这句(setq v-s-sc (/ (getvar "viewsize") (cadr (getvar "screensize"))))。
2、对话框要与鼠标位置有固定的关系，那么对话框的初始插入点就要根据鼠标位置进行调整，本程序是对话框左上角点即为鼠标位置，用了这句(setq gr (grread t 15 1))(setq pt (cadr gr))，实际上本程序现阶段有个问题还没有解决，当鼠标点靠近窗口边的时候，绘制的对话框不能到屏幕外面去，这里要加个判断进行调整，该部分有时间再修改。
（先说到这里20130512 19:17）

x_s_s_1 · 发表于 2013-5-12 18:46:38

本帖最后由 x_s_s_1 于 2013-5-12 18:53 编辑

水平有限，按照古版的思路写了一个，有几个地方处理的有问题，1、变色部分写的混乱；2、当左键选择对话框外退出这部分写的不好；3、图层前置部分不想用command，问了好多人也没有好办法；4、整个程序的思路不是很顺畅5、多个对话框部分，在想着如何精简代码，比较忙，没有写注释，请见谅。有空再论。请大家加上容错函数和undo，希望高手们拍砖，且提出更好的代码，谢谢。

(defun get_dxf (ent n /)
(if (eq (type ent) 'ename)
(setq ent (entget ent))
)
(cdr (assoc n ent))
)
(defun X_SS->List (ss vla / i lst)
(if (eq (type ss) 'PICKSET)
(if vla
(repeat (setq i (sslength ss))
(setq
lst
(cons (vlax-ename->vla-object (ssname ss (setq i (1- i))))
lst
)
)
)
(repeat (setq i (sslength ss))
(setq lst (cons (ssname ss (setq i (1- i))) lst))
)
)
(princ "您输入的ss不是选择集")
)
)
(defun ch_dxf_ss (ss num ch / ssl en ent new_num old_num x y)
(cond
((eq (type ss) 'PICKSET) (setq ssl (X_SS->List ss nil)))
((eq (type ss) 'ENAME) (setq ssl (list ss)))
((eq (type ss) 'VLA-OBJECT)
(setq ssl (list (vlax-vla-object->ename ss)))
)
)
(cond
((eq (type num) 'INT) (setq num (list num)))
)
(cond
((null (eq (type ch) 'LIST)) (setq ch (list ch)))
)
(if (/= (length num) (length ch))
(princ "组码表与修改表数目不等")
(foreach en ssl
(mapcar '(lambda (x y)
(setq ent (entget en)
new_num (cons x y)
old_num (assoc x ent)
)
(if old_num
(entmod (subst new_num old_num ent))
(entmod (reverse (cons new_num (reverse ent))))
)
)
num
ch
)
)
)
ss
)
;; entmakex-hatch By ElpanovEvgeniy
;; L - list of list point. like ((pt11 pt12 pt13)(pt21 pt22 pt23))
;; A - angle hatch
;; N - name pattern
;; S - scale
;; returne - hatch ename
(defun entmakex-hatch (L a n s)
(entmakex
(apply
'append
(list
(list '(0 . "HATCH")
'(100 . "AcDbEntity")
'(410 . "Model")
'(100 . "AcDbHatch")
'(10 0.0 0.0 0.0)
'(210 0.0 0.0 1.0)
(cons 2 n)
(if (= n "SOLID")
'(70 . 1)
'(70 . 0)
)
'(71 . 0)
(cons 91 (length l))
)
(apply
'append
(mapcar '(lambda (a)
(apply 'append
(list (list '(92 . 7)
'(72 . 0)
'(73 . 1)
(cons 93 (length a))
)
(mapcar '(lambda (b) (cons 10 b)) a)
'((97 . 0))
)
)
)
l
)
)
(if (= n "SOLID")
(list '(75 . 0)
'(76 . 1)
'(47 . 1.)
'(98 . 2)
'(10 0. 0. 0.0)
'(10 0. 0. 0.0)
'(450 . 0)
'(451 . 0)
'(460 . 0.0)
'(461 . 0.0)
'(452 . 0)
'(462 . 0.0)
'(453 . 2)
'(463 . 0.0)
'(63 . 256)
'(463 . 1.0)
'(63 . 256)
'(470
.
"LINEAR"
)
)
(list '(75 . 0)
'(76 . 1)
(cons 52 a)
(cons 41 s)
'(77 . 0)
'(78 . 1)
(cons 53 a)
'(43 . 0.)
'(44 . 0.)
'(45 . 1.)
'(46 . 1.)
'(79 . 0)
'(47 . 1.)
'(98 . 2)
'(10 0. 0. 0.0)
'(10 0. 0. 0.0)
'(470 . "LINEAR")
)
)
)
)
)
)
(defun pick_lst (pt w h mid /)
(if mid
(list (mapcar '- pt (list (/ w 2) (/ h 2)))
(mapcar '+ pt (list (/ w 2) (- (/ h 2))))
(mapcar '+ pt (list (/ w 2) (/ h 2)))
(mapcar '+ pt (list (- (/ w 2)) (/ h 2)))
)
(list pt
(polar pt 0 w)
(mapcar '+ pt (list w h))
(polar pt (/ pi 2) h)
)
)
)
(defun c:tt
(/ lay gr v-s-sc pt b_pl b_hatch b_txt en loop mouse_pic ss
b ent oi)
(if (null (tblobjname "LAYER" "my_对话框"))
(setq lay (entmakex (list
'(0 . "LAYER")
'(100
.
"AcDbSymbolTableRecord"
)
'(100
.
"AcDbLayerTableRecord"
)
'(6 . "continuous")
'(62 . 7)
'(70 . 0)
'(2 . "my_对话框")
)
)
)
)
(setq gr (grread t 15 1))
(setq v-s-sc (/ (getvar "viewsize") (cadr (getvar "screensize"))))
(setq pt (cadr gr))
(setq
mouse_pic (entmakex
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 3)
'(70 . 0)
(cons 10 pt)
'(40 . 0.0)
(cons 41 (* (* 10 v-s-sc)))
'(42 . 0.0)
(cons 10 (polar pt (* 1.75 pi) (* 12.5 v-s-sc)))
(cons 40 (* (* 3 v-s-sc)))
(cons 41 (* (* 7.5 v-s-sc)))
'(42 . 0.194617)
(cons 10 (polar pt (* 1.85 pi) (* 27.5 v-s-sc)))
(cons 40 (* (* 7.5 v-s-sc)))
(cons 41 (* (* 7.5 v-s-sc)))
'(42 . -0.309442)
)
)
)
(ch_dxf_ss mouse_pic '(8 62) '("my_对话框" 1))
(setq b_pl
(entmakex
(append
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 43 (* 3 v-s-sc))
)
(mapcar '(lambda (x) (cons 10 x))
(pick_lst pt (* 100 v-s-sc) (* 50 v-s-sc) nil)
)
)
)
)
(ch_dxf_ss b_pl '(8 62) '("my_对话框" 90))
(setq b_hatch (ENTMAKEX-HATCH
(list (mapcar 'cdr
(vl-remove-if-not
'(lambda (x) (= 10 (car x)))
(entget b_pl)
)
)
)
0
"solid"
1
)
)
(ch_dxf_ss b_hatch '(8 62) '("my_对话框" 8))
(setq b_txt (entmakex (list '(0 . "text")
(cons 10 pt)
(cons 1 "画圈圈")
(cons 40 (* 30 v-s-sc))
'(41 . 0.8)
'(7 . "standard")
)
)
)
(ch_dxf_ss
b_txt
'(8 62 72 73 11)
(list "my_对话框"
6
4
0
(polar (polar pt 0 (* 50 v-s-sc)) (/ pi 2) (* 25 v-s-sc))
)
)
(command "_.DRAWORDER" b_hatch "" "f")
(command "_.DRAWORDER" b_pl "" "f")
(command "_.DRAWORDER" b_txt "" "f")
(command "_.DRAWORDER" mouse_pic "" "f")
(setq loop t)
(while loop
(setq gr (grread t 15 1))
(cond
((= 5 (car gr))
(setq
v-s-sc (/ (getvar "viewsize") (cadr (getvar "screensize")))
)
(setq pt (cadr gr))
(setq en (reverse (vl-member-if
(function (lambda (x) (= 39 (car x))))
(reverse (entget mouse_pic))
)
)
)
(entmod
(append en
(list (cons 10 pt)
'(40 . 0.0)
(cons 41 (* (* 10 v-s-sc)))
'(42 . 0.0)
(cons 10 (polar pt (* 1.75 pi) (* 12.5 v-s-sc)))
(cons 40 (* (* 3 v-s-sc)))
(cons 41 (* (* 7.5 v-s-sc)))
'(42 . 0.194617)
(cons 10 (polar pt (* 1.85 pi) (* 27.5 v-s-sc)))
(cons 40 (* (* 7.5 v-s-sc)))
(cons 41 (* (* 7.5 v-s-sc)))
'(42 . -0.309442)
)
)
)
(setq b (getvar "pickbox"))
(if (setq ss (ssget "cp"
(pick_lst pt (* v-s-sc b) (* v-s-sc b) t)
'((0 . "TEXT") (8 . "my_对话框"))
)
)
(progn
(setq ent (car (X_SS->List ss nil)))
(if (and (= "TEXT" (get_dxf ent 0))
(= "my_对话框" (get_dxf ent 8))
)
(ch_dxf_ss ent 62 2)
)
)
(progn (ch_dxf_ss ent 62 6) (setq ent nil))
;这里个人感觉不顺畅
)
)
((= (car gr) 3)
(if ent
(setq oi (get_dxf ent 1))
)
(entdel b_hatch)
(entdel b_txt)
(entdel b_pl)
(entdel mouse_pic)
(cond ((= oi "画圈圈")
(entmake (list '(0 . "circle")
(cons 10 (getpoint "\n选择圆心："))
(cons 40 (getreal "\n输入半径："))
)
)
)
)
(setq loop nil)
)
)
)
(vla-delete (vlax-ename->vla-object lay))
(princ)
)

(defun get_dxf (ent n /) 
  (if (eq (type ent) 'ename) 
    (setq ent (entget ent)) 
  ) 
  (cdr (assoc n ent)) 
) 
(defun X_SS->List (ss vla / i lst) 
  (if (eq (type ss) 'PICKSET) 
    (if  vla 
      (repeat (setq i (sslength ss)) 
  (setq 
    lst 
     (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) 
     lst 
     ) 
  ) 
      ) 
      (repeat (setq i (sslength ss)) 
  (setq lst (cons (ssname ss (setq i (1- i))) lst)) 
      ) 
    ) 
    (princ "您输入的ss不是选择集") 
  ) 
) 
(defun ch_dxf_ss (ss num ch / ssl en ent new_num old_num x y) 
  (cond 
    ((eq (type ss) 'PICKSET) (setq ssl (X_SS->List ss nil))) 
    ((eq (type ss) 'ENAME) (setq ssl (list ss))) 
    ((eq (type ss) 'VLA-OBJECT) 
     (setq ssl (list (vlax-vla-object->ename ss))) 
    ) 
  ) 
  (cond 
    ((eq (type num) 'INT) (setq num (list num))) 
  ) 
  (cond 
    ((null (eq (type ch) 'LIST)) (setq ch (list ch))) 
  ) 
  (if (/= (length num) (length ch)) 
    (princ "组码表与修改表数目不等") 
    (foreach en  ssl 
      (mapcar '(lambda (x y) 
     (setq ent     (entget en) 
           new_num (cons x y) 
           old_num (assoc x ent) 
     ) 
     (if old_num 
       (entmod (subst new_num old_num ent)) 
       (entmod (reverse (cons new_num (reverse ent)))) 
     ) 
         ) 
        num 
        ch 
      ) 
    ) 
  ) 
  ss 
) 
;; entmakex-hatch By ElpanovEvgeniy 
;; L - list of list point. like ((pt11 pt12 pt13)(pt21 pt22 pt23)) 
;; A - angle hatch 
;; N - name pattern 
;; S - scale 
;; returne - hatch ename 
(defun entmakex-hatch (L a n s) 
  (entmakex 
    (apply 
      'append 
      (list 
  (list '(0 . "HATCH") 
        '(100 . "AcDbEntity") 
        '(410 . "Model") 
        '(100 . "AcDbHatch") 
        '(10 0.0 0.0 0.0) 
        '(210 0.0 0.0 1.0) 
        (cons 2 n) 
        (if (= n "SOLID") 
    '(70 . 1) 
    '(70 . 0) 
        ) 
        '(71 . 0) 
        (cons 91 (length l)) 
  ) 
  (apply 
    'append 
    (mapcar '(lambda (a) 
         (apply 'append 
          (list (list  '(92 . 7) 
          '(72 . 0) 
          '(73 . 1) 
          (cons 93 (length a)) 
          ) 
          (mapcar '(lambda (b) (cons 10 b)) a) 
          '((97 . 0)) 
          ) 
         ) 
       ) 
      l 
    ) 
  ) 
  (if (= n "SOLID") 
    (list  '(75 . 0) 
    '(76 . 1) 
    '(47 . 1.) 
    '(98 . 2) 
    '(10 0. 0. 0.0) 
    '(10 0. 0. 0.0) 
    '(450 . 0) 
    '(451 . 0) 
    '(460 . 0.0) 
    '(461 . 0.0) 
    '(452 . 0) 
    '(462 . 0.0) 
    '(453 . 2) 
    '(463 . 0.0) 
    '(63 . 256) 
    '(463 . 1.0) 
    '(63 . 256) 
    '(470 
      . 
      "LINEAR" 
     ) 
    ) 
    (list  '(75 . 0) 
    '(76 . 1) 
    (cons 52 a) 
    (cons 41 s) 
    '(77 . 0) 
    '(78 . 1) 
    (cons 53 a) 
    '(43 . 0.) 
    '(44 . 0.) 
    '(45 . 1.) 
    '(46 . 1.) 
    '(79 . 0) 
    '(47 . 1.) 
    '(98 . 2) 
    '(10 0. 0. 0.0) 
    '(10 0. 0. 0.0) 
    '(470 . "LINEAR") 
    ) 
  ) 
      ) 
    ) 
  ) 
) 
(defun pick_lst  (pt w h mid /) 
  (if mid 
    (list (mapcar '- pt (list (/ w 2) (/ h 2))) 
    (mapcar '+ pt (list (/ w 2) (- (/ h 2)))) 
    (mapcar '+ pt (list (/ w 2) (/ h 2))) 
    (mapcar '+ pt (list (- (/ w 2)) (/ h 2))) 
    ) 
    (list pt 
    (polar pt 0 w) 
    (mapcar '+ pt (list w h)) 
    (polar pt (/ pi 2) h) 
    ) 
  ) 
) 
(defun c:tt 
      (/ lay gr v-s-sc pt  b_pl b_hatch b_txt en loop mouse_pic ss 
       b ent oi) 
  (if (null (tblobjname "LAYER" "my_对话框")) 
    (setq lay (entmakex  (list 
        '(0 . "LAYER") 
        '(100 
          . 
          "AcDbSymbolTableRecord" 
         ) 
        '(100 
          . 
          "AcDbLayerTableRecord" 
         ) 
        '(6 . "continuous") 
        '(62 . 7) 
        '(70 . 0) 
        '(2 . "my_对话框") 
      ) 
        ) 
    ) 
  ) 
  (setq gr (grread t 15 1)) 
  (setq v-s-sc (/ (getvar "viewsize") (cadr (getvar "screensize")))) 
  (setq pt (cadr gr)) 
  (setq 
    mouse_pic (entmakex 
    (list '(0 . "LWPOLYLINE") 
          '(100 . "AcDbEntity") 
          '(100 . "AcDbPolyline") 
          '(90 . 3) 
          '(70 . 0) 
          (cons 10 pt) 
          '(40 . 0.0) 
          (cons 41 (* (* 10 v-s-sc))) 
          '(42 . 0.0) 
          (cons 10 (polar pt (* 1.75 pi) (* 12.5 v-s-sc))) 
          (cons 40 (* (* 3 v-s-sc))) 
          (cons 41 (* (* 7.5 v-s-sc))) 
          '(42 . 0.194617) 
          (cons 10 (polar pt (* 1.85 pi) (* 27.5 v-s-sc))) 
          (cons 40 (* (* 7.5 v-s-sc))) 
          (cons 41 (* (* 7.5 v-s-sc))) 
          '(42 . -0.309442) 
    ) 
        ) 
  ) 
  (ch_dxf_ss mouse_pic '(8 62) '("my_对话框" 1)) 
  (setq  b_pl 
   (entmakex 
     (append 
       (list 
         '(0 . "LWPOLYLINE") 
         '(100 . "AcDbEntity") 
         '(100 . "AcDbPolyline") 
         '(90 . 4) 
         '(70 . 1) 
         (cons 43 (* 3 v-s-sc)) 
       ) 
       (mapcar '(lambda (x) (cons 10 x)) 
         (pick_lst pt (* 100 v-s-sc) (* 50 v-s-sc) nil) 
       ) 
     ) 
   ) 
  ) 
  (ch_dxf_ss b_pl '(8 62) '("my_对话框" 90)) 
  (setq  b_hatch  (ENTMAKEX-HATCH 
      (list  (mapcar  'cdr 
        (vl-remove-if-not 
          '(lambda (x) (= 10 (car x))) 
          (entget b_pl) 
        ) 
      ) 
      ) 
      0 
      "solid" 
      1 
    ) 
  ) 
  (ch_dxf_ss b_hatch '(8 62) '("my_对话框" 8)) 
  (setq  b_txt (entmakex  (list '(0 . "text") 
            (cons 10 pt) 
            (cons 1 "画圈圈") 
            (cons 40 (* 30 v-s-sc)) 
            '(41 . 0.8) 
            '(7 . "standard") 
      ) 
        ) 
  ) 
  (ch_dxf_ss 
    b_txt 
    '(8 62 72 73 11) 
    (list "my_对话框" 
    6 
    4 
    0 
    (polar (polar pt 0 (* 50 v-s-sc)) (/ pi 2) (* 25 v-s-sc)) 
    ) 
  ) 
  (command "_.DRAWORDER" b_hatch "" "f") 
  (command "_.DRAWORDER" b_pl "" "f") 
  (command "_.DRAWORDER" b_txt "" "f") 
  (command "_.DRAWORDER" mouse_pic "" "f") 
  (setq loop t) 
  (while loop 
    (setq gr (grread t 15 1)) 
    (cond 
      ((= 5 (car gr)) 
       (setq 
   v-s-sc  (/ (getvar "viewsize") (cadr (getvar "screensize"))) 
       ) 
       (setq pt (cadr gr)) 
       (setq en  (reverse (vl-member-if 
         (function (lambda (x) (= 39 (car x)))) 
         (reverse (entget mouse_pic)) 
       ) 
    ) 
       ) 
       (entmod 
   (append en 
     (list (cons 10 pt) 
           '(40 . 0.0) 
           (cons 41 (* (* 10 v-s-sc))) 
           '(42 . 0.0) 
           (cons 10 (polar pt (* 1.75 pi) (* 12.5 v-s-sc))) 
           (cons 40 (* (* 3 v-s-sc))) 
           (cons 41 (* (* 7.5 v-s-sc))) 
           '(42 . 0.194617) 
           (cons 10 (polar pt (* 1.85 pi) (* 27.5 v-s-sc))) 
           (cons 40 (* (* 7.5 v-s-sc))) 
           (cons 41 (* (* 7.5 v-s-sc))) 
           '(42 . -0.309442) 
     ) 
   ) 
       ) 
       (setq b (getvar "pickbox")) 
       (if (setq ss (ssget "cp" 
         (pick_lst pt (* v-s-sc b) (* v-s-sc b) t) 
         '((0 . "TEXT") (8 . "my_对话框")) 
        ) 
     ) 
   (progn 
     (setq ent (car (X_SS->List ss nil))) 
     (if (and (= "TEXT" (get_dxf ent 0)) 
        (= "my_对话框" (get_dxf ent 8)) 
         ) 
       (ch_dxf_ss ent 62 2) 
     ) 
   ) 
   (progn (ch_dxf_ss ent 62 6) (setq ent nil)) 
          ;这里个人感觉不顺畅 
       ) 
      ) 
      ((= (car gr) 3) 
       (if ent 
   (setq oi (get_dxf ent 1)) 
       ) 
       (entdel b_hatch) 
       (entdel b_txt) 
       (entdel b_pl) 
       (entdel mouse_pic) 
       (cond ((= oi "画圈圈") 
        (entmake (list '(0 . "circle") 
           (cons 10 (getpoint "\n选择圆心：")) 
           (cons 40 (getreal "\n输入半径：")) 
           ) 
        ) 
       ) 
       ) 
       (setq loop nil) 
      ) 
    ) 
  ) 
  (vla-delete (vlax-ename->vla-object lay)) 
  (princ) 
)

wowan1314 · 发表于 2013-5-12 19:14:07

x_s_s_1 发表于 2013-5-12 18:46
水平有限，按照古版的思路写了一个，有几个地方处理的有问题，1、变色部分写的混乱；2、当左键选择对话框外 ...

不错哦！最近没时间搞！不过想象了下！还是用wipeout作底，solid作为选中文字的底！所有点应该计算完后再按顺序生成各个部件！避免重新生成影响速度！还有格子出现的位置不能超出屏幕否则重新计算！

edsion24 · 发表于 2013-5-13 09:59:45

这软件太霸气了。。。。擦。。。。。。

野狼谷/〈M〉 · 发表于 2013-6-12 00:07:04

这就是lisp的境界。。。

happysheep · 发表于 2014-4-3 09:52:01

太牛逼了，要是能有这个就好了

czcxxx · 发表于 2015-10-27 14:57:15

太牛逼了，要是能有这个就好了！！！

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

[讨论] 【思路求助】有趣的对话框程序！LISP能实现吗？

点评

本帖子中包含更多资源

点评