LIST_BOX复选出现问题，请各位大神指点迷津

海盗曹 · 发表于 2015-4-16 09:41:13

本帖最后由海盗曹于 2015-4-16 09:44 编辑

复制代码

1.程序来源
   代码均来源于论坛，主要使用了自贡黄明儒大师的随图选择集程序，还有一些论坛里的其他代码。在此对无私奉献的大婶们表示婶婶的感谢。

2.程序意图
   希望按关键字提取当前图中所有单行文字，然后每组相同文字自动形成一个选择集，选择集名称即为此组文字内容。以便后续对每组的对象进行相应的调用、删除。

3.程序问题
   （1）在自己改装成复选模式之后，调用和删除功能就无法使用了。创建选择集功能则可正常运行。
   （2）选择集保存于当前激活的图形中，关闭cad后，再重新打开，原图中的选择集消失。即选择集未随图纸保存。

4.求助申请
   希望各位大神不吝赐教，指点优化，在此先感谢大婶们了！
5.程序源码及DCL文件如下。

(defun c:W_AHFG ()
(setq SSLists (Sub-SS-SSLists))
(dcl_contents SSLists)
)
(defun dcl_contents (SSLists / dcl_id S_D)
(sssetfirst)
(if (> (setq dcl_id (load_dialog "随图选择集")) 0)
(if (new_dialog "SuiTuSS" dcl_id) (progn
(start_list "SSList") ;_已有选择集列表
(mapcar 'add_list SSLists)
(end_list)
(action_tile "AddSS" "(done_dialog 2)")
(action_tile "ChsSS" "(done_dialog 3)")
(action_tile "DelSS" "(done_dialog 4)")
(action_tile "SSName" "(setq SSNam $value)")
(action_tile "accept" "(readata)(done_dailog 1)")
(action_tile "cancel" "(done_dialog 0)")
(setq S_D (start_dialog))
(cond
((= S_D 2) (Sub-SS-CreateSS SSNam))
((= S_D 3) (choosess))
((= S_D 4) (deletess))
)
(start_dialog)
(unload_dialog dcl_id)
)
(princ "\n无法显示对话框！")
)
(princ "\n无法加载对话框！")
)
(princ)
)
(defun readata ()
(setq nlst (get_tile "SSList"))
(setq slst (mapcar '(lambda (n) (nth (itoa n) SSLISTS)) nlst))
)
(defun strles (s1 s2 / a1 a2)
(setq a1 (ascii s1) a2 (ascii s2))
(cond
((and (<= 48 a1 57) (<= 48 a2 57)) (< (atoi s1) (atoi s2)))
((= a1 a2) (strles (substr s1 2) (substr s2 2)))
((< a1 a2) t)
(t nil)
)
)
(defun choosess (/ n ss ss1)
(setq ss1 (ssadd))
(setq n 0)
(repeat (length (read (strcat "(" (get_tile "SSList") ")")))
(setq ss (Sub-SS-ChooseSS (nth (nth n (read (strcat "(" (get_tile "SSList") ")"))) SSLists)))
(steq n (1+ n))
(ssadd ss ss1)
)
)
(defun deletess (/ n)
(setq n 0)
(repeat (length (read (strcat "(" (get_tile "SSList") ")")))
(Sub-SS-DelSS (nth (nth n (read (strcat "(" (get_tile "SSList") ")"))) SSLists))
(steq n (1+ n))
)
)
;;;================================================================================
(defun Sub-SS-CreateSS (SSNam / dcllist e el en index listxz lst n1 newlst s ss ss1 sslists sstemp txt x1)
(if SSNam (progn
(setq SS (ssget (list '(0 . "TEXT")(cons 1 (strcat "*" SSNam "*")))))
(setq sstemp ss)
(setq lst nil newlst nil x1 0)
(setq n (sslength ss))
(setq index 0)
(repeat n
(setq el (entget ( ssname ss index)))
(setq index ( + index 1))
(setq e (assoc 0 el))
(if (= "TEXT" (cdr e)) (progn
(setq txt (cdr (assoc 1 el)))
(setq lst(cons (append (list 1) (list txt))lst))
))
)
(while lst
(setq n 0)
(foreach i lst (if (= (cadar lst) (cadr i))(setq n (+ n (car i)))))
(setq newlst (append newlst (list (list n (cadar lst)))))
(setq newlst (vl-sort newlst (function (lambda (e1 e2) (strles (cadr e1) (cadr e2))))))
(setq lst(vl-remove-if '(lambda (x) (= (cadar lst) (cadr x))) lst))
)
(setq dcllist (mapcar 'cadr newlst))
(setq s 0)
(repeat (length dcllist)
(setq ss1 sstemp)
(command "._select" ss1 "")
(setq ss1 (ssget "P" (list '(0 . "TEXT")(cons 1 (nth s dcllist)))))
(setq n1 (sslength SS1))
(repeat n1
(setq en (ssname SS1 (setq n1 (1- n1))))
(setq listxz (append listxz (list (cdr (assoc 5 (entget en))))))
(VL-CATCH-ALL-APPLY 'vlax-ldata-put (list "SS-Data-SSXZJ" (nth s dcllist) listxz))
)
(setq listxz '())
(setq s (1+ s))
)
(setq SSLists (Sub-SS-SSLists))
;(dcl_contents SSLists)
))
)
;;调出选集
(defun Sub-SS-ChooseSS (SSNam / N1 RESULT SS1)
(setq result (VL-CATCH-ALL-APPLY 'vlax-ldata-get (list "SS-Data-SSXZJ" SSNam)))
(if (VL-CATCH-ALL-ERROR-P result)
nil
(progn
(setq ss1 (ssadd))
(repeat (length result)
(setq n1 (car result))
(setq result (cdr result))
(ssadd (handent n1) ss1)
)
))
(sssetfirst nil ss1)
)
(defun Sub-SS-DelSS (SSNAM / SSLists)
(VL-CATCH-ALL-APPLY 'vlax-ldata-delete (list "SS-Data-SSXZJ" SSNam)) ;_删除单个选择集
(setq SSLists (Sub-SS-SSLists))
(dcl_contents SSLists)
)
(defun Sub-SS-DelSSAll (/ SSLists)
(YX:Put-Dict-DelDict "SS-Data-SSXZJ") ;_删除词典，清空选择集
(setq SSLists (Sub-SS-SSLists))
(dcl_contents SSLists)
)
(defun Sub-SS-SSLists (/ LIS SSNAMS X)
(if (setq lis (vlax-ldata-list "SS-Data-SSXZJ"))
(setq SSNAMlst (mapcar '(lambda (x) (car x)) lis))
(setq SSNAMlst nil)
)
)
(princ "\n***>>>>>海盗曹按编号自动构造选择集=W_AHFG<<<<<***")
(princ "\nO(∩_∩)O用处自己想吧O(∩_∩)O")
(princ)
SuiTuSS:dialog {
label = "随图选择集" ;
:boxed_column {
:row {
:button {
label = "添加" ;
key = "AddSS" ;
}
:edit_box {
key = "SSName" ;
value = "Z" ;
}
}
:list_box {
key = "SSList" ;
label = "已有选择集" ;
multiple_select = true ;
}
:row {
:button {
label = "调用" ;
key = "ChsSS" ;
is_default = true ;
is_cancel = true ;
}
:button {
label = "删除" ;
key = "DelSS" ;
}
}
}
spacer_1;
cancel_button;
}

(defun c:W_AHFG () 
  (setq SSLists (Sub-SS-SSLists)) 
  (dcl_contents SSLists) 
) 
(defun dcl_contents (SSLists / dcl_id S_D) 
  (sssetfirst) 
  (if (> (setq dcl_id (load_dialog "随图选择集")) 0) 
    (if (new_dialog "SuiTuSS" dcl_id) (progn 
        (start_list "SSList") ;_已有选择集列表 
        (mapcar 'add_list SSLists) 
        (end_list) 
        (action_tile "AddSS" "(done_dialog 2)") 
        (action_tile "ChsSS" "(done_dialog 3)") 
        (action_tile "DelSS" "(done_dialog 4)") 
        (action_tile "SSName" "(setq SSNam $value)") 
        (action_tile "accept" "(readata)(done_dailog 1)") 
        (action_tile "cancel" "(done_dialog 0)") 
        (setq S_D (start_dialog)) 
        (cond 
          ((= S_D 2) (Sub-SS-CreateSS SSNam)) 
          ((= S_D 3) (choosess)) 
          ((= S_D 4) (deletess)) 
        ) 
        (start_dialog) 
        (unload_dialog dcl_id) 
      ) 
      (princ "\n无法显示对话框！") 
    ) 
    (princ "\n无法加载对话框！") 
  ) 
  (princ) 
) 
(defun readata () 
  (setq nlst (get_tile "SSList")) 
  (setq slst (mapcar '(lambda (n) (nth (itoa n) SSLISTS)) nlst)) 
) 
(defun strles (s1 s2 / a1 a2) 
  (setq a1 (ascii s1) a2 (ascii s2)) 
  (cond 
    ((and (<= 48 a1 57) (<= 48 a2 57)) (< (atoi s1) (atoi s2))) 
    ((= a1 a2) (strles (substr s1 2) (substr s2 2))) 
    ((< a1 a2) t) 
    (t nil) 
  ) 
) 
(defun choosess (/ n ss ss1) 
  (setq ss1 (ssadd)) 
  (setq n 0) 
  (repeat (length (read (strcat "(" (get_tile "SSList") ")"))) 
    (setq ss (Sub-SS-ChooseSS (nth (nth n (read (strcat "(" (get_tile "SSList") ")"))) SSLists))) 
    (steq n (1+ n)) 
    (ssadd ss ss1) 
  ) 
) 
(defun deletess (/ n) 
  (setq n 0) 
  (repeat (length (read (strcat "(" (get_tile "SSList") ")"))) 
    (Sub-SS-DelSS (nth (nth n (read (strcat "(" (get_tile "SSList") ")"))) SSLists)) 
    (steq n (1+ n)) 
  ) 
) 
;;;================================================================================ 
(defun Sub-SS-CreateSS (SSNam / dcllist e el en index listxz lst n1 newlst s ss ss1 sslists sstemp txt x1) 
  (if SSNam (progn 
      (setq SS (ssget (list '(0 . "TEXT")(cons 1 (strcat "*" SSNam "*"))))) 
      (setq sstemp ss) 
      (setq lst nil  newlst nil x1 0) 
      (setq n (sslength ss)) 
      (setq index 0) 
      (repeat n 
        (setq el (entget ( ssname ss index))) 
        (setq index ( + index 1)) 
        (setq e (assoc 0 el)) 
        (if (= "TEXT" (cdr e)) (progn 
            (setq txt (cdr (assoc 1 el))) 
            (setq lst(cons (append  (list 1) (list txt))lst)) 
        )) 
      ) 
      (while lst 
        (setq n 0) 
        (foreach i lst (if (= (cadar lst) (cadr i))(setq n (+ n (car i))))) 
        (setq newlst (append newlst (list (list n (cadar lst))))) 
        (setq newlst (vl-sort newlst (function (lambda (e1 e2) (strles (cadr e1) (cadr e2)))))) 
        (setq lst(vl-remove-if '(lambda (x) (= (cadar lst) (cadr x))) lst)) 
      ) 
      (setq dcllist (mapcar 'cadr newlst)) 
      (setq s 0) 
      (repeat (length dcllist) 
        (setq ss1 sstemp) 
        (command "._select" ss1 "") 
        (setq ss1 (ssget "P" (list '(0 . "TEXT")(cons 1 (nth s dcllist))))) 
        (setq n1 (sslength SS1)) 
        (repeat n1 
          (setq en (ssname SS1 (setq n1 (1- n1)))) 
          (setq listxz (append listxz (list (cdr (assoc 5 (entget en)))))) 
          (VL-CATCH-ALL-APPLY 'vlax-ldata-put (list "SS-Data-SSXZJ" (nth s dcllist) listxz)) 
        ) 
        (setq listxz '()) 
        (setq s (1+ s)) 
      ) 
      (setq SSLists (Sub-SS-SSLists)) 
      ;(dcl_contents SSLists) 
  )) 
) 
;;调出选集 
(defun Sub-SS-ChooseSS (SSNam / N1 RESULT SS1) 
  (setq result (VL-CATCH-ALL-APPLY 'vlax-ldata-get (list "SS-Data-SSXZJ" SSNam))) 
  (if (VL-CATCH-ALL-ERROR-P result) 
    nil 
    (progn 
      (setq ss1 (ssadd)) 
      (repeat (length result) 
        (setq n1 (car result)) 
        (setq result (cdr result)) 
        (ssadd (handent n1) ss1) 
      ) 
  )) 
  (sssetfirst nil ss1) 
) 
(defun Sub-SS-DelSS (SSNAM / SSLists) 
  (VL-CATCH-ALL-APPLY 'vlax-ldata-delete (list "SS-Data-SSXZJ" SSNam)) ;_删除单个选择集 
  (setq SSLists (Sub-SS-SSLists)) 
  (dcl_contents SSLists) 
) 
(defun Sub-SS-DelSSAll (/ SSLists) 
  (YX:Put-Dict-DelDict "SS-Data-SSXZJ") ;_删除词典，清空选择集 
  (setq SSLists (Sub-SS-SSLists)) 
  (dcl_contents SSLists) 
) 
(defun Sub-SS-SSLists (/ LIS SSNAMS X) 
  (if (setq lis (vlax-ldata-list "SS-Data-SSXZJ")) 
    (setq SSNAMlst (mapcar '(lambda (x) (car x)) lis)) 
    (setq SSNAMlst nil) 
  ) 
) 
(princ "\n***>>>>>海盗曹按编号自动构造选择集=W_AHFG<<<<<***") 
(princ "\nO(∩_∩)O用处自己想吧O(∩_∩)O") 
(princ) 
 
 
 
 
 
SuiTuSS:dialog { 
    label = "随图选择集" ; 
    :boxed_column { 
        :row { 
            :button { 
                label = "添加" ; 
                key = "AddSS" ; 
            } 
            :edit_box { 
                key = "SSName" ; 
                value = "Z" ; 
            } 
        } 
        :list_box { 
            key = "SSList" ; 
            label = "已有选择集" ; 
            multiple_select = true ; 
        } 
        :row { 
            :button { 
                label = "调用" ; 
                key = "ChsSS" ; 
                is_default = true ; 
                is_cancel = true ; 
            } 
            :button { 
                label = "删除" ; 
                key = "DelSS" ; 
            } 
        } 
    } 
    spacer_1; 
    cancel_button; 
}

海盗曹 · 发表于 2015-4-16 13:03:15

看来大神们很忙。。。

海盗曹 · 发表于 2015-4-17 10:44:42

复选问题已解决，随图问题待解

海盗曹 · 发表于 2015-4-24 10:28:28

(VL-CATCH-ALL-APPLY 'vlax-ldata-put (list "SS-Data-SSXZJ" "1.图中未标注剪力墙均为Q1,其平面位置均为轴线居中布置." "data"))
(vlax-ldata-list "SS-Data-SSXZJ")
请问各位，vlax-ldata-list为何读不出呢？
是因为"1.图中未标注剪力墙均为Q1,其平面位置均为轴线居中布置."格式问题？

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

[提问] LIST_BOX复选出现问题，请各位大神指点迷津

本帖子中包含更多资源