老代码，字符串分解列表等

狂刀lxx · 发表于 2011-5-11 00:06:50

注：此为老代码，老手稿。自从后来用了正则表达式，我再也不写字符串处理函数了，因为基本上所有的字符串问题，用一个正则表达式函数就解决了，...... 无聊吧？

;;(x-txt2lst e) ＝ text文本以单个文字列表输出.
;;(x-str2lst str) = 字符串分解列表.
;|
(x-txt2lst e) ＝ text文本以单个文字列表输出-------------------lxx.2004.8
(x-txt2lst (ssname (ssget ":s" '((0 . "TEXT"))) 0))
"cad总平面－规划图" -> ("c" "a" "d" "总" "平" "面" "－" "规" "划" "图")
|;
(defun x-txt2lst (e / txt st stl)
(setq txt (cdr(assoc 1 (entget e))) stl T);(x-getdxf e 1);;
(mapcar 'vl-list->string
(vl-remove-if 'null
(mapcar '(lambda(x)
(cond
((< x 160) (list x)) ;; 一般汉字编码 > 160. 英文符号<128.!!!
(T (if stl (setq st x stl nil)(setq stl (list st x))));;写法:确保返回值并设开关.
)
) (vl-string->list txt)
)
)
)
)
;(x-str2lst str) = 字符串分解列表.------ok!--------------------lxx.2004.7
;测试: (x-str2lst "1asd,+测试1e99") -> ("1" "a" "s" "d" "," "+" "测" "试" "1" "e" "9" "9")
(defun x-str2lst (str / i k s lst)
(setq i 0 k (chr 160))
(while (/= "" (setq s (substr str (setq i (1+ i)) 1)))
(if (< s k)
(setq lst (cons s lst))
(setq lst (cons (substr str i 2) lst)
i (1+ i))
)
)(reverse lst)
)
;| by lzh
偶也来发个Lisp处理汉字的，：）
;转换字符串为字符表，相当与VB.Net的ToChar －by 雪山飞狐.
;;(str2chrs "1asd,+测试1e99") -> ("1asd,+测试1e" "99") ????
(defun Str2Chrs (strA / pAsc)
(setq pAsc (if (< (ascii strA) 128)12))
(cond ((> (strlen strA) pAsc)
(cons (substr strA 1 pAsc)
(str2Chrs (substr strA (1+ pAsc))) ;;递归!
)
)
((list (substr strA 1 pAsc)))
)
)
;合并字符表，并加入分隔符，相当与VB的同名函数－by 雪山飞狐.
;;(join '("并字符" "dd1" "分隔" "1" ",") ";") -> "并字符;dd1;分隔;1;,"
(defun Join (Chrs fchr / pStr)
(setq pStr "")
(foreach i Chrs (setq pStr (strcat pStr i fchr)))
(substr pStr 1 (- (strlen pStr) (strlen fchr)))
)
|;
;| ********************************************* text字符串分解－垂直排列 vba ok!! *****************************************************
;; ********************************************* text字符串分解－水平排列 vba ok!! *****************************************************
'text字符串分解－垂直排列修改by陌生人.
'修改 from lzh
Public Sub Textexv()
Dim pText As AcadEntity
Dim pnt
ThisDrawing.Utility.GetEntity pText, pnt
Dim str As String
str = pText.TextString
Dim pStr As String
Dim Txth As Double
Txth = pText.Height
Dim inspt As ACAD_POINT
inspt = pText.InsertionPoint
Dim polarPnt As ACAD_POINT
polarPnt = ThisDrawing.Utility.PolarPoint(inspt, (pText.Rotation + 1.57079), Txth)
Do While Len(str) <> 0
pStr = pStr & Left(str, 1) & "\P"
str = Right(str, Len(str) - 1)
Loop
Set mT = ThisDrawing.ModelSpace.AddMText(polarPnt, 0, pStr)
mT.Height = Txth
mT.Rotation = pText.Rotation
mT.StyleName = pText.StyleName
ThisDrawing.SendCommand "Explode" & vbCr & "l" & vbCr & vbCr
pText.Delete
End Sub
'text字符串分解－水平排列 by陌生人.
'位置有偏差!???
'还不能真实还原，只能对宽度比例1:1的文本.
Public Sub Textexh()
Dim pText As AcadEntity
Dim pnt
ThisDrawing.Utility.GetEntity pText, pnt
Dim str As String
str = pText.TextString
Dim pStr As String
Dim Txth As Double
Txth = pText.Height
Dim inspt As ACAD_POINT
inspt = pText.InsertionPoint
Dim polarPnt As ACAD_POINT
polarPnt = ThisDrawing.Utility.PolarPoint(inspt, (pText.Rotation + 1.57079), Txth)
Do While Len(str) <> 0
pStr = pStr & Left(str, 1) & "\H1X"
str = Right(str, Len(str) - 1)
Loop
Set mT = ThisDrawing.ModelSpace.AddMText(polarPnt, 0, pStr)
mT.Height = Txth
mT.Rotation = pText.Rotation
mT.StyleName = pText.StyleName
ThisDrawing.SendCommand "Explode" & vbCr & "l" & vbCr & vbCr
pText.Delete
End Sub
|;
;;(mapcar '(lambda(x)(set x nil))(list 'ent 'lst 'st 'p0 'h 'w 'ang 'sty 'st2 'mtxt))
;| (x-txt2m e) = text转换为可炸散的mtext 文本.--------ok!!!----------------------------lxx.2004.8.28
测试: (x-txt2m (car(entsel))) -> ok!!! 错位?!!
需要调用: dxf系列，x-begin 函数.
|;
(defun x-txt2m (e / ent lst st p0 h w ang sty st2 mtxt)
(setq ent (entget e)
lst (x-getdxfs ent '(1 10 40 41 50 7 ))) ;; (文本内容第一对齐点字高高宽比倾角) ;;dxf 系列函数.
;; -> ("saa12到奥斯丁偶发.,3" (15124.4 9862.36 0.0) 1501.02 0.573312 0.207712)
(mapcar 'set (list 'st 'p0 'h 'w 'ang 'sty ) lst)
(setq ;h (abs (- (caar (textbox ent)) (caadr (textbox ent))))
p1 (polar p0 (+ (/ PI 2) ang) h)
st2 (apply 'strcat (cons (strcat "[url=file://\\W]\\W[/url]" (rtos w 2 4) ";")(mapcar '(lambda(x)(strcat x "[url=file://\\H1X]\\H1X[/url];")) (x-str2lst st)))));;加[url=file://\\H1X]\\H1X[/url]用于以后炸开!!
(setq mtxt (vla-addmtext *ms (vlax-3d-point p1) 0 st2)) ;; *ms ＝ modelspace 全局.
(mapcar '(lambda(x y)(vlax-put mtxt x y)) (list 'height 'rotation 'stylename 'color)(list h ang sty (x-get e 'color)))
(entlast)
)
;; 炸开text文本为单个字符，支持汉字.---ok!!!------------lxx.2004.8
;; 支持ucs.
(defun c:xttx ( / ucsfl e)
(setq ucsfl (getvar "ucsfollow"))
(setvar "ucsfollow" 0)
(vl-cmdf ".undo" "be" ".ucs" "")
(vl-cmdf ".explode" (x-txt2m (setq e (ssname (ssget ":s" '((0 . "TEXT"))) 0))) "")
(entdel e)
(vl-cmdf ".ucs" "p" ".undo" "e")
(setvar "ucsfollow" ucsfl)
(princ)
)
;; >>>>>>>>>>> 配合 txt2m 使用!!! 可以得，求并编辑点击所在文字的程序.!!!!!!>>>>>>>
;(vl-cmdf ".explode" (entlast) "")
;;求文本总宽度: (list(cons 41 (abs (- (caar (textbox ent)) (caadr (textbox ent))))))
;|
;; 利用menucmd 调用 DIESEL 字符宏命令.
(menucmd "M=$(+,10.2,33.004,55,34.02)") ;->"132.224" －》!!!特性：返回文本并保持小数位数(去0尾).
(menucmd "M=$(+,10 2)") ;;-> "10"
|;
;;;-----------------------------------------------------------------------------------;
;| (x$-cal do st1 st2 fuzz) = 两个数字字符的数学运算------------lxx.2004.8
do = 支持的diesel运算.
st1 st2 ＝参与运算的字符.
fuzz = 精度。为nil时候去尾0.
支持diesel表达式中:+ - * / < > >= <= != or xor and .
返回:计算结果的数字字符串.
测试:(x$-cal '+ "3" "4.25" nil) -> "7.25"
(x$-cal '+ "3" "4.25" 1) -> "7.3" ;;四舍五入!!!
(x$-cal '+ "3" "4.24" 1) -> "7.2"
(x$-cal '+ "3" "4.26" 1) -> "7.3"
(x$-cal '* "-2" "4.25" nil) -> "-8.5"
(x$-cal '* "-2" "4.25" 2) -> "-8.50"
(x$-cal '* "4e18" "4.25" nil) -> "1.70000000E+19"
(x$-cal '* "555555" "555" nil) -> "308333025" !!!!!ok!!!!
对比: (cal CAL "555555*555") ->错误: 无效的数据类型或数据溢出: #<SUBR @0348244c <EXRXSUBR>>
命令行下: cal
>> 表达式: 555555*555
>> 错误: 整数必须介于 -32768 和 32767 之间.)
(x$-cal '> "22" "0.3" nil) -> "1" (为真)
(x$-cal '= "22" "0.3" nil) -> "0" (为假)
参: menucmd调用DIESEL方法取得系统中文日期时间.lsp
|;
(defun x$-cal (do st1 st2 fuzz)
(setq str (menucmd (strcat "M=$(" (vl-symbol-name do) "," st1 "," st2 ")")))
(if fuzz (rtos (distof str) 2 fuzz) str)
)
;| 附录:
DIESEL 函数目录
状态的检索、计算和显示均由 DIESEL 函数执行。所有的函数最多只能包含 10 个参数,
包括函数名本身。如果超出此限制，将得到一条 DIESEL 错误信息.!!!!(限制!!!!)
+（加）
-（减）
*（乘）
/（除）
=（等于）
<（小于）
>（大于）
!=（不等于）
<=（小于或等于）
>=（大于或等于）
and
angtos
edtime
eq
eval
fix
getenv
getvar
if
index
nth
or
rtos
strlen
substr
upper
xor
|;
;;;-----------------------------------------------------------------------------------;

;;(x-txt2lst e) ＝ text文本以单个文字列表输出. 
;;(x-str2lst str) = 字符串分解列表. 
;| 
(x-txt2lst e) ＝ text文本以单个文字列表输出-------------------lxx.2004.8 
(x-txt2lst (ssname (ssget ":s" '((0 . "TEXT"))) 0)) 
"cad总平面－规划图" -> ("c" "a" "d" "总" "平" "面" "－" "规" "划" "图") 
|; 
(defun x-txt2lst (e / txt st stl) 
  (setq txt (cdr(assoc 1 (entget e))) stl T);(x-getdxf e 1);; 
  (mapcar 'vl-list->string 
    (vl-remove-if 'null 
      (mapcar '(lambda(x) 
    (cond 
      ((< x 160) (list x)) ;; 一般 汉字编码 > 160. 英文符号<128.!!! 
      (T (if stl (setq st x stl nil)(setq stl (list st x))));;写法:确保返回值并设开关. 
     ) 
  ) (vl-string->list txt) 
      ) 
    ) 
  ) 
) 
 
;(x-str2lst str) = 字符串分解列表.------ok!--------------------lxx.2004.7 
;测试: (x-str2lst "1asd,+测试1e99") -> ("1" "a" "s" "d" "," "+" "测" "试" "1" "e" "9" "9") 
(defun x-str2lst (str / i k s lst) 
  (setq i 0 k (chr 160)) 
  (while (/= "" (setq s (substr str (setq i (1+ i)) 1))) 
    (if (< s k) 
      (setq lst (cons s lst)) 
      (setq lst (cons (substr str i 2) lst) 
     i (1+ i)) 
    ) 
  )(reverse lst) 
) 
;| by lzh 
偶也来发个Lisp处理汉字的，：） 
;转换字符串为字符表，相当与VB.Net的ToChar －by 雪山飞狐. 
;;(str2chrs "1asd,+测试1e99") -> ("1asd,+测试1e" "99") ???? 
(defun Str2Chrs (strA / pAsc) 
  (setq pAsc (if (< (ascii strA) 128)12)) 
  (cond ((> (strlen strA) pAsc) 
  (cons (substr strA 1 pAsc) 
        (str2Chrs (substr strA (1+ pAsc)))  ;;递归! 
  ) 
 ) 
 ((list (substr strA 1 pAsc))) 
  ) 
) 
 
;合并字符表，并加入分隔符，相当与VB的同名函数 －by 雪山飞狐. 
;;(join '("并字符" "dd1" "分隔" "1" ",") ";") -> "并字符;dd1;分隔;1;," 
(defun Join (Chrs fchr / pStr) 
  (setq pStr "") 
  (foreach i Chrs (setq pStr (strcat pStr i fchr))) 
  (substr pStr 1 (- (strlen pStr) (strlen fchr))) 
) 
|; 
;| ********************************************* text字符串分解－垂直排列 vba ok!! ***************************************************** 
;; ********************************************* text字符串分解－水平排列 vba ok!! ***************************************************** 
'text字符串分解－垂直排列   修改by陌生人. 
'修改 from lzh 
Public Sub Textexv() 
Dim pText As AcadEntity 
Dim pnt 
ThisDrawing.Utility.GetEntity pText, pnt 
Dim str As String 
str = pText.TextString 
Dim pStr As String 
Dim Txth As Double 
Txth = pText.Height 
Dim inspt As ACAD_POINT 
inspt = pText.InsertionPoint 
Dim polarPnt As ACAD_POINT 
polarPnt = ThisDrawing.Utility.PolarPoint(inspt, (pText.Rotation + 1.57079), Txth) 
Do While Len(str) <> 0 
pStr = pStr & Left(str, 1) & "\P" 
str = Right(str, Len(str) - 1) 
Loop 
Set mT = ThisDrawing.ModelSpace.AddMText(polarPnt, 0, pStr) 
mT.Height = Txth 
mT.Rotation = pText.Rotation 
mT.StyleName = pText.StyleName 
ThisDrawing.SendCommand "Explode" & vbCr & "l" & vbCr & vbCr 
pText.Delete 
End Sub 
 
'text字符串分解－水平排列  by陌生人. 
'位置有偏差!??? 
'还不能真实还原，只能对宽度比例1:1的文本. 
Public Sub Textexh() 
Dim pText As AcadEntity 
Dim pnt 
ThisDrawing.Utility.GetEntity pText, pnt 
Dim str As String 
str = pText.TextString 
Dim pStr As String 
Dim Txth As Double 
Txth = pText.Height 
Dim inspt As ACAD_POINT 
inspt = pText.InsertionPoint 
Dim polarPnt As ACAD_POINT 
polarPnt = ThisDrawing.Utility.PolarPoint(inspt, (pText.Rotation + 1.57079), Txth) 
Do While Len(str) <> 0 
pStr = pStr & Left(str, 1) & "\H1X" 
str = Right(str, Len(str) - 1) 
Loop 
Set mT = ThisDrawing.ModelSpace.AddMText(polarPnt, 0, pStr) 
mT.Height = Txth 
mT.Rotation = pText.Rotation 
mT.StyleName = pText.StyleName 
ThisDrawing.SendCommand "Explode" & vbCr & "l" & vbCr & vbCr 
pText.Delete 
End Sub 
|; 
;;(mapcar '(lambda(x)(set x nil))(list 'ent 'lst 'st 'p0 'h 'w 'ang 'sty 'st2 'mtxt)) 
 
;| (x-txt2m e) = text转换为可炸散的mtext 文本.--------ok!!!----------------------------lxx.2004.8.28 
测试: (x-txt2m (car(entsel))) -> ok!!! 错位?!! 
需要调用: dxf系列，x-begin 函数. 
|; 
(defun x-txt2m (e / ent lst st p0 h w ang sty st2 mtxt) 
  (setq ent (entget e) 
 lst (x-getdxfs ent '(1 10 40 41 50 7 ))) ;; (文本内容 第一对齐点 字高 高宽比 倾角)  ;;dxf 系列函数. 
  ;; -> ("saa12到奥斯丁偶发.,3" (15124.4 9862.36 0.0) 1501.02 0.573312 0.207712) 
  (mapcar 'set (list 'st 'p0 'h 'w 'ang 'sty ) lst) 
  (setq ;h  (abs (- (caar (textbox ent)) (caadr (textbox ent)))) 
        p1 (polar p0 (+ (/ PI 2) ang) h) 
 st2 (apply 'strcat (cons (strcat "[url=file://\\W]\\W[/url]" (rtos w 2 4) ";")(mapcar '(lambda(x)(strcat x "[url=file://\\H1X]\\H1X[/url];")) (x-str2lst st)))));;加[url=file://\\H1X]\\H1X[/url]用于以后炸开!! 
  (setq mtxt (vla-addmtext *ms (vlax-3d-point p1) 0 st2)) ;; *ms ＝ modelspace 全局. 
  (mapcar '(lambda(x y)(vlax-put mtxt x y)) (list 'height 'rotation 'stylename 'color)(list h ang sty (x-get e 'color))) 
  (entlast) 
) 
;; 炸开text文本为单个字符，支持汉字.---ok!!!------------lxx.2004.8 
;; 支持ucs. 
(defun c:xttx ( / ucsfl e) 
  (setq ucsfl (getvar "ucsfollow")) 
  (setvar "ucsfollow" 0) 
  (vl-cmdf ".undo" "be" ".ucs" "") 
  (vl-cmdf ".explode" (x-txt2m (setq e (ssname (ssget ":s" '((0 . "TEXT"))) 0)))  "") 
  (entdel e) 
  (vl-cmdf ".ucs" "p" ".undo" "e") 
  (setvar "ucsfollow" ucsfl) 
  (princ) 
) 
;; >>>>>>>>>>> 配合 txt2m 使用!!!  可以得，求并编辑点击所在文字的程序.!!!!!!>>>>>>> 
;(vl-cmdf ".explode" (entlast) "") 
;;求文本总宽度: (list(cons 41 (abs (- (caar (textbox ent)) (caadr (textbox ent)))))) 
;| 
;; 利用menucmd 调用 DIESEL 字符宏命令. 
(menucmd "M=$(+,10.2,33.004,55,34.02)") ;->"132.224" －》!!!特性：返回文本并保持小数位数(去0尾). 
(menucmd "M=$(+,10 2)") ;;-> "10" 
|; 
;;;-----------------------------------------------------------------------------------; 
;| (x$-cal do st1 st2 fuzz) = 两个数字字符的数学运算------------lxx.2004.8 
do = 支持的diesel运算. 
st1 st2 ＝ 参与运算的字符. 
fuzz = 精度。为nil时候去尾0. 
支持diesel表达式中:+ - * / < > >= <= != or xor and . 
返回:计算结果的数字字符串. 
测试:(x$-cal '+ "3" "4.25" nil) -> "7.25" 
     (x$-cal '+ "3" "4.25" 1)  -> "7.3" ;;四舍五入!!! 
     (x$-cal '+ "3" "4.24" 1)  -> "7.2" 
     (x$-cal '+ "3" "4.26" 1)  -> "7.3" 
     (x$-cal '* "-2" "4.25" nil) -> "-8.5" 
     (x$-cal '* "-2" "4.25" 2) -> "-8.50" 
     (x$-cal '* "4e18" "4.25" nil) -> "1.70000000E+19" 
     (x$-cal '* "555555" "555" nil) -> "308333025" !!!!!ok!!!! 
     对比: (cal CAL "555555*555") ->错误: 无效的数据类型或数据溢出: #<SUBR @0348244c <EXRXSUBR>> 
     命令行下: cal 
     >> 表达式: 555555*555 
     >> 错误: 整数必须介于 -32768 和 32767 之间.) 
     (x$-cal '> "22" "0.3" nil) -> "1" (为真) 
     (x$-cal '= "22" "0.3" nil) -> "0" (为假) 
参: menucmd调用DIESEL方法取得系统中文日期时间.lsp 
|; 
(defun x$-cal (do st1 st2 fuzz) 
  (setq str (menucmd (strcat "M=$(" (vl-symbol-name do) "," st1 "," st2 ")"))) 
  (if fuzz (rtos (distof str) 2 fuzz) str) 
) 
;| 附录: 
DIESEL 函数目录   
状态的检索、计算和显示均由 DIESEL 函数执行。所有的函数最多只能包含 10 个参数, 
包括函数名本身。如果超出此限制，将得到一条 DIESEL 错误信息.!!!!(限制!!!!) 
+（加） 
-（减） 
*（乘） 
/（除） 
=（等于） 
<（小于） 
>（大于） 
!=（不等于） 
<=（小于或等于） 
>=（大于或等于） 
and 
angtos 
edtime 
eq 
eval 
fix 
getenv 
getvar 
if 
index 
nth 
or 
rtos 
strlen 
substr 
upper 
xor 
|; 
;;;-----------------------------------------------------------------------------------;

461045462 · 发表于 2011-5-11 08:13:34

谢谢楼主的分享
先收藏了,慢慢看学习学习
谢谢

pizg · 发表于 2011-5-13 09:12:15

樓主好樣的~~~支持源碼分享
頂一下

crazylsp · 发表于 2011-5-13 10:15:51

还是觉得老的就是好。

jxphklibin · 发表于 2011-6-15 18:16:43

呵呵，厉害，我也写过，正则表达式用的不多

yjr111 · 发表于 2011-10-7 21:46:46

本帖最后由 yjr111 于 2011-10-7 22:00 编辑

玩的就是心跳，我才不看正则表达式呢，不然lsp都不要玩了忘了说了：谢谢楼主的代码，正用得上！

qq973569511 · 发表于 2015-4-30 10:48:30

yjr111 发表于 2011-10-7 21:46
玩的就是心跳，我才不看正则表达式呢，不然lsp都不要玩了忘了说了：谢谢楼主的代码，正用得上！

x-getdxfs函数没有定义

zst1978 · 发表于 2020-8-24 10:43:56

刀刀厉害啊

xyp1964 · 发表于 2022-3-1 15:12:34

qq973569511 发表于 2015-4-30 10:48
x-getdxfs函数没有定义

(defun x-getdxfs (ent lst / aa x)
 (setq aa (vl-remove-if-not '(lambda (x) (member (car x) lst)) ent)
aa (vl-sort aa'(lambda (x y)(< (vl-position (car x) lst) (vl-position (car y) lst))))
 )
 (mapcar 'cdr aa)
)

magicheno · 发表于 2022-11-19 02:13:22

感谢大佬分享

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

[函数] 老代码，字符串分解列表等