[LISP程序]：已修改的字符串合并程序

urljit

从前，我发过的一个小程序，感谢众多网友的建议，今作改正，还请指教：ｕｒ１５１７＠ｉｎｈｅ．ｎｅｔ

字符合并

2. 
   
3. (defun ctjerr (s)
   
4.   (if (/= s "Function cancelled")
   
5.     (princ (strcat "\n字符合并Error: " s))
   
6.   )
   
7.   (setq *error* olderr)
   
8.   (princ)
   
9. )
   
10. (defun c:zfhb (/        i         sel          L           elist    e1
    
11.                e2        strall         strpos          strlayer strpt10  str40
    
12.                str50        style4         style3          strstyle str41
    
13.               )
    
14.   
    
15.   (princ "\n字符合并   删除前导空格请使用程序:DBA.lsp   ")
    
16.   (command "undo" "begin")
    
17.   (setq        olderr        *error*
    
18.         *error*        ctjerr
    
19.         i        0
    
20.   )
    
21.   (setvar "cmdecho" 0)
    
22.   (setq sel nil)
    
23.   (while (= nil sel)
    
24.     (princ "请按顺序选择文字:")
    
25.     (SETQ SEL (SSGET (LIST (CONS 0 "TEXT"))))
    
26.   )
    
27.   (SETQ L (SSLENGTH SEL))
    
28.   (setq        style3 "abcdefg"
    
29.         style4 ""
    
30.         i      0
    
31.   )
    
32.   (setq strpos nil)
    
33.   (while (< i L)
    
34.     (setq elist (ENTGET (SSNAME SEL i)))
    
35.     (setq strpos
    
36.            (append
    
37.              strpos
    
38.              (list (list (cdr (assoc 1 elist)) (cdr (assoc 10 elist)))
    
39.              )
    
40.            )
    
41.     )
    
42.     (if
    
43.       (and (= "" style4)
    
44.            (/= "TTF" (strcase (substr style3 (- (strlen style3) 2) 3)))
    
45.       )
    
46.        ;;将选择集的第一个汉字字符串的有关字体定义作为新字符串的字体定义;否则以最后的字符串为模板
    
47.        (progn
    
48.          (setq strstyle (cdr (assoc 7 elist)))
    
49.          (setq style3 (cdr (assoc 3 (tblsearch "STYLE" strstyle))))
    
50.          (setq style4 (cdr (assoc 4 (tblsearch "STYLE" strstyle))))
    
51.          (setq strlayer (cdr (assoc 8 elist)))
    
52.          (setq strpt10 (cdr (assoc 10 elist)))
    
53.          (setq str40 (cdr (assoc 40 elist)))
    
54.          (setq str41 (cdr (assoc 41 elist)))
    
55.          (setq str50 (cdr (assoc 50 elist)))
    
56.        )
    
57.     )
    
58.     (setq i (1+ i))
    
59.   )
    
60.   ;;while
    
61.   (setq        strpos
    
62.          (vl-sort strpos
    
63.                   (function (lambda (e1 e2) (< (caadr e1) (caadr e2))))
    
64.          )
    
65.   )
    
66.   ;;根据x坐标对strpos排序               ???不知道为什么不能把相同位置相同字符虑掉，帮助里说能　网友，您看呢？
    
67.   (setq        i 0
    
68.         strall ""
    
69.   )
    
70.   (repeat (length strpos)
    
71.     (setq strall (strcat strall (car (nth i strpos))))
    
72.     (setq i (1+ i))
    
73.   )
    
74.   ;;取出字符串的合
    
75.   (setq strpt10 (polar strpt10 1.57 (* 2.4 str40)))
    
76.   (entmake (list (cons 0 "TEXT")
    
77.                  (cons 1 strall)
    
78.                  (cons 7 strstyle)
    
79.                  (cons 8 strlayer)
    
80.                  (cons 10 strpt10)
    
81.                  (cons 40 str40)
    
82.                  (cons 41 str41)
    
83.                  (cons 50 str50)
    
84.                  (cons 71 0)
    
85.                  (cons 72 0)
    
86.                  (cons 73 0)
    
87.            )
    
88.   )
    
89. ;;;  (princ "\n 如果不想移动，请按Esc键。")
    
90.   (command "move" "l" "" strpt10 pause)
    
91.   (setq i 0)
    
92.   (while (< i L)
    
93.     (entdel (ssname sel i))
    
94.     (setq i (1+ i))
    
95.   )
    
96.   (setq *error* olderr)
    
97.   (command "undo" "end")
    
98.   (princ)
    
99. )
    
100. 
     
101. ;;;--------------------------------------
     
102. (princ "  ZFHB V1.2已加载。以ZFHB启动命令。")
     
103. (princ)

<br /> (defun ctjerr (s)<br />   (if (/= s "Function cancelled")<br />     (princ (strcat "\n字符合并Error: " s))<br />   )<br />   (setq *error* olderr)<br />   (princ)<br /> )<br /> (defun c:zfhb (/        i         sel          L           elist    e1<br />                e2        strall         strpos          strlayer strpt10  str40<br />                str50        style4         style3          strstyle str41<br />               )<br />   <br />   (princ "\n字符合并   删除前导空格请使用程序:DBA.lsp   ")<br />   (command "undo" "begin")<br />   (setq        olderr        *error*<br />         *error*        ctjerr<br />         i        0<br />   )<br />   (setvar "cmdecho" 0)<br />   (setq sel nil)<br />   (while (= nil sel)<br />     (princ "请按顺序选择文字:")<br />     (SETQ SEL (SSGET (LIST (CONS 0 "TEXT"))))<br />   )<br />   (SETQ L (SSLENGTH SEL))<br />   (setq        style3 "abcdefg"<br />         style4 ""<br />         i      0<br />   )<br />   (setq strpos nil)<br />   (while (< i L)<br />     (setq elist (ENTGET (SSNAME SEL i)))<br />     (setq strpos<br />            (append<br />              strpos<br />              (list (list (cdr (assoc 1 elist)) (cdr (assoc 10 elist)))<br />              )<br />            )<br />     )<br />     (if<br />       (and (= "" style4)<br />            (/= "TTF" (strcase (substr style3 (- (strlen style3) 2) 3)))<br />       )<br />        ;;将选择集的第一个汉字字符串的有关字体定义作为新字符串的字体定义;否则以最后的字符串为模板<br />        (progn<br />          (setq strstyle (cdr (assoc 7 elist)))<br />          (setq style3 (cdr (assoc 3 (tblsearch "STYLE" strstyle))))<br />          (setq style4 (cdr (assoc 4 (tblsearch "STYLE" strstyle))))<br />          (setq strlayer (cdr (assoc 8 elist)))<br />          (setq strpt10 (cdr (assoc 10 elist)))<br />          (setq str40 (cdr (assoc 40 elist)))<br />          (setq str41 (cdr (assoc 41 elist)))<br />          (setq str50 (cdr (assoc 50 elist)))<br />        )<br />     )<br />     (setq i (1+ i))<br />   )<br />   ;;while<br />   (setq        strpos<br />          (vl-sort strpos<br />                   (function (lambda (e1 e2) (< (caadr e1) (caadr e2))))<br />          )<br />   )<br />   ;;根据x坐标对strpos排序               ???不知道为什么不能把相同位置相同字符虑掉，帮助里说能　网友，您看呢？<br />   (setq        i 0<br />         strall ""<br />   )<br />   (repeat (length strpos)<br />     (setq strall (strcat strall (car (nth i strpos))))<br />     (setq i (1+ i))<br />   )<br />   ;;取出字符串的合<br />   (setq strpt10 (polar strpt10 1.57 (* 2.4 str40)))<br />   (entmake (list (cons 0 "TEXT")<br />                  (cons 1 strall)<br />                  (cons 7 strstyle)<br />                  (cons 8 strlayer)<br />                  (cons 10 strpt10)<br />                  (cons 40 str40)<br />                  (cons 41 str41)<br />                  (cons 50 str50)<br />                  (cons 71 0)<br />                  (cons 72 0)<br />                  (cons 73 0)<br />            )<br />   )<br /> ;;;  (princ "\n 如果不想移动，请按Esc键。")<br />   (command "move" "l" "" strpt10 pause)<br />   (setq i 0)<br />   (while (< i L)<br />     (entdel (ssname sel i))<br />     (setq i (1+ i))<br />   )<br />   (setq *error* olderr)<br />   (command "undo" "end")<br />   (princ)<br /> )<br /> <br /> ;;;--------------------------------------<br /> (princ "  ZFHB V1.2已加载。以ZFHB启动命令。")<br /> (princ)

cy956

vl-sor在子表排序中对同大小子元素不删除，对单层表的相同子元素删除。

tuger

试一下这个比vl-sort好用
;;;对一个数字表排序，重复的程序自动忽略
(defun zx_px(a / b c d)
(setq c (apply 'min a) c (- c 1000.0))
(while (> (setq d (apply 'max a)) c)
(setq b (cons d b) a (subst c d a)) )
b)

wlz088

文本文件是表格，CAD按行读入后，能不能按空格分解字符串，形成表格。

urljit

如果有兴趣，可联系、交流lsp心得，不过，我有时间时才能回复。