grread模拟对话框

夏生生

在明经中有网友贴了一个很有意思的对话框截图，gu_xl版主提出了用grread模拟的思路，我尝试着写了一个，演示的原帖地址http://bbs.mjtd.com/thread-101224-1-1.html。由于个人水平及时间有限，写的很不顺畅，放上来大家讨论一下，暂时发现有几个地方处理的有问题:1、变色部分写的混乱；
2、当左键选择对话框外退出这部分写的不是那么合适；
3、图层前置部分不想用command，有好办法吗？我的2006不知道为什么vla-MoveTotop函数用不了；
4、整个程序的思路不是很顺畅，个人编程水平低下的原因；
5、多个对话框部分，不同的组件如何写法还在构思。大家有什么好的思路或代码一起讨论。
谢谢大家。


[pcode=lisp,true](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)
)
[/pcode]

st788796

是不是可以每个格仅用 Solid 作背景，而且 Solid 先行绘制完成后再写 Text，这样鼠标扫过的时候仅对 Solid 进行 Put-color 会方便

Lispboy

图层前置部分不想用command，有好办法吗？我的2006不知道为什么vla-MoveTotop函数用不了；

你试试 vla-SwapOrder  改变显示顺序。

st788796

用一个表记录 Solid Ent 及四角点, Grread 在哪个里面哪个变色

Lispboy

关于你说的在2006下面突然DRAWORDER不好用了，自己先用DRAWORDER命令调整一次，然后试试你的程序还好不，如果还不行，你试试删除下词典里面的 sortenttable表。

wowan1314

左键点在对话框外不退出，只有左键且在表格内才退出。
如果左键点击的是特殊的格子，那么删除原表格，原位置生成新表格，继续选择。