[LISP程序]：返回文本字符串各字符的坐标

lsjjm

返回文本字符串各字符的坐标
[php]
(defun c:test (/ ent str pp)
  (setq  el (entget (car (entsel))))
  (setq str (cdr (assoc 1 el)))
  (setq lst (mapcar 'chr (vl-string->list str)))
  (setq   p (cdr (assoc 10 el)))
  (setq  pp (list p))
  (repeat (strlen str)
    (if (> (strlen str) 1)
      (setq p (list (+ (car p)
                       (- (lenstr (substr str 1 2))
                          (lenstr (substr str 2 1))))
                    (cadr p))
           pp (append pp (list p)))
    )
    (setq str (substr str 2))
  )
  pp
)
(defun lenstr (ss)
  (setq tst (textbox (list (cons 1 ss))))
  (setq l (car (cadr tst)))
)
[/php]

梦断江南

好像没有对中文进行判断和处理

lsjjm

最初由 梦断江南 发布
[B]好像没有对中文进行判断和处理 [/B]

是的.
对不起, 我所有的程序都是在非中文环境下工作. 只共参考.

wkai

lsjjm 长老的程序不支持中文和有转角的TEXT
下面的可以，测测看[PHP];;;200409261213___________________________
;;;字符串转换为表_________________________
(defun text_to_lst (text / n char strlst)
  (setq n 1)
  (while (<= n (strlen text))
    (setq char (substr text n 1))
    (if        (> (ascii char) 159)
      (and (substr text (1+ n) 1)
           (setq strlst (cons (substr text n 2) strlst))
           (setq n (1+ n))
      )
      (setq strlst (cons char strlst))
    )
    (setq n (1+ n))
  )
  (reverse strlst)
)
;;;测量TEXT中的每个字的宽度___________________
(defun c:tt (/ el str ang p lst pts pp  n p0)
  (princ "\nWRITEN BY WKAI @ XDCAD.NET")
  (setq el (entget (car (entsel))))
  (mapcar '(lambda (x y) (set x (cdr (assoc y el))))
          '(str ang p)
          '(1 50 10)
  )
  (setq lst (text_to_lst str))
  (while lst
    (setq
      pts (append
            pts
            (list
              (cadr
                (textbox
                  (subst (cons 1 (apply 'strcat lst)) (assoc 1 el) el)
                )
              )
            )
          )
    )
    (setq lst (reverse (cdr (reverse lst))))
  )
  (setq pts (mapcar 'car pts))
  (setq pts (reverse pts))
  (setq p0 (polar p ang (caar (textbox el))))
  (setq pp (mapcar '(lambda (x) (polar p0 ang x)) pts))
  (foreach n (cons p pp) (command "._point" "non" n))
)
[/PHP]

ycao

4楼的程序非常不错。谢谢！

雪山飞狐(lzh)

上面是程序求出的点
下面是用陌生人的TEXT文本水平分解得到的
怎么点错位了?

梦断江南

wkai的程序确有错位的问题，希望再完善完善：）

wkai

上段代码求出的是字符的结束点
这个是字符的开始点
[PHP]
;;;200409281432___________________________
;;;字符串转换为表_________________________
(defun text_to_lst (text / n char strlst)
  (setq n 1)
  (while (<= n (strlen text))
    (setq char (substr text n 1))
    (if        (> (ascii char) 159)
      (and (substr text (1+ n) 1)
           (setq strlst (cons (substr text n 2) strlst))
           (setq n (1+ n))
      )
      (setq strlst (cons char strlst))
    )
    (setq n (1+ n))
  )
  strlst
)
;;;测量TEXT中的每个字的宽度___________________
(defun c:tt (/ el str ang p lst pts pp n p0 string len)
  (princ "\nWRITEN BY WKAI @ XDCAD.NET")
  (setq        el     (entget (car (entsel)))
        string ""
  )
  (mapcar '(lambda (x y) (set x (cdr (assoc y el))))
          '(str ang p)
          '(1 50 10)
  )
  (setq len (caadr (textbox el)))
  (setq p0 (polar p ang (caar (textbox el))))
  (setq lst (text_to_lst str))
  (foreach n lst
    (setq string (strcat n string))
    (setq pts (append pts(list(caadr(textbox(subst (cons 1 string)(assoc 1 el) el))))))
    )
  (setq pts (reverse (mapcar '(lambda (x) (- len x)) pts)))
  (setq pp (mapcar '(lambda (x) (polar p0 ang x)) pts))
  (foreach n (cons p pp) (command "._point" "non" n))
)

[/PHP]

eachy

中间空格的处理中文和西文不一样，仅西文的有返回点，中文TTF时中间空格没有点

它山之石

两问题
1、支持R14吗？
2、对齐方式有影响吗？

wkai

支持R14
对齐方式无影响

wkai

eachy兄所说的问题，找到解决办法了。
计算宽度时使用宽度和空格相同的字母替换空格。宽度和空格相同的字母t r f \等等都可以

2. 
   
3.   [FONT=courier new]
   
4. 
   
5. ;;;200409281432___________________________
   
6. ;;;字符串转换为表_________________________
   
7. (defun text_to_lst (text / n char strlst)
   
8.   (setq n 1)
   
9.   (while (<= n (strlen text))
   
10.     (setq char (substr text n 1))
    
11.     (if        (> (ascii char) 159)
    
12.       (and (substr text (1+ n) 1)
    
13.            (setq strlst (cons (substr text n 2) strlst))
    
14.            (setq n (1+ n))
    
15.       )
    
16.       (setq strlst (cons char strlst))
    
17.     )
    
18.     (setq n (1+ n))
    
19.   )
    
20.   (reverse strlst)
    
21. )
    
22. ;;;测量TEXT中的每个字的宽度___________________
    
23. (defun c:tt (/ el str ang p lst pts pp n p0 string len)
    
24.   (princ "\nWRITEN BY WKAI @ XDCAD.NET")
    
25.   (setq    el     (entget (car (entsel)))
    
26.     string ""
    
27.   )
    
28.   (mapcar '(lambda (x y) (set x (cdr (assoc y el))))
    
29.       '(str ang p)
    
30.       '(1 50 10)
    
31.   )
    
32.   (setq len (caadr (textbox el)))
    
33.   (setq p0 (polar p ang (caar (textbox el))))
    
34.   (setq lst (reverse(text_to_lst str)) )
    
35.   (foreach n lst
    
36. [color=blue]    (if (= " " n)(setq n "t"))[/color]
    
37.     (setq string (strcat n string))
    
38.     (setq pts (append pts(list(caadr(textbox(subst (cons 1 string)(assoc 1 el) el))))))
    
39.     )
    
40.   (setq pts (reverse (mapcar '(lambda (x) (- len x)) pts)))
    
41.   (setq pp (mapcar '(lambda (x) (polar p0 ang x)) pts))
    
42.   (foreach n (cons p pp) (command "._point" "non" n))
    
43. )
    
44. 
    
45.   [/FONT]
    

<br />   [FONT=courier new]<br /> <br /> ;;;200409281432___________________________ <br /> ;;;字符串转换为表_________________________ <br /> (defun text_to_lst (text / n char strlst)<br />   (setq n 1)<br />   (while (<= n (strlen text))<br />     (setq char (substr text n 1))<br />     (if        (> (ascii char) 159)<br />       (and (substr text (1+ n) 1)<br />            (setq strlst (cons (substr text n 2) strlst))<br />            (setq n (1+ n))<br />       )<br />       (setq strlst (cons char strlst))<br />     )<br />     (setq n (1+ n))<br />   )<br />   (reverse strlst)<br /> )<br /> ;;;测量TEXT中的每个字的宽度___________________ <br /> (defun c:tt (/ el str ang p lst pts pp n p0 string len) <br />   (princ "\nWRITEN BY WKAI @ XDCAD.NET") <br />   (setq    el     (entget (car (entsel))) <br />     string "" <br />   ) <br />   (mapcar '(lambda (x y) (set x (cdr (assoc y el)))) <br />       '(str ang p) <br />       '(1 50 10) <br />   ) <br />   (setq len (caadr (textbox el))) <br />   (setq p0 (polar p ang (caar (textbox el)))) <br />   (setq lst (reverse(text_to_lst str)) )<br />   (foreach n lst<br /> [color=blue]    (if (= " " n)(setq n "t"))[/color]<br />     (setq string (strcat n string)) <br />     (setq pts (append pts(list(caadr(textbox(subst (cons 1 string)(assoc 1 el) el)))))) <br />     ) <br />   (setq pts (reverse (mapcar '(lambda (x) (- len x)) pts))) <br />   (setq pp (mapcar '(lambda (x) (polar p0 ang x)) pts)) <br />   (foreach n (cons p pp) (command "._point" "non" n)) <br /> )<br /> <br />   [/FONT]<br />