请高手帮忙修改一下源代码（文字打断）
本帖最后由 sz721 于 2012-4-30 16:33 编辑这是一段日本网站下载的文字打断源代码。功能：把单行文字在任意位置分割成两行（使用A和D键用于动态切换位置）。在测试纯数字时没有问题，但是用于中文字就不行了，会出现乱码现象。我想应该是日文字符的全角半角字符长度和中文字符的不同。请高手修改一下代码，谢谢！
(defun c:dd1 ( / ObjName ObjType)
(princ "\n 把单行文字列在任意位置分割成两行（A和D键用于切换位置）")
(setq *error* *myerror*)
(setq AcadVersion (getvar "acadver"))
(princ "\n AcadVersion :")(princ AcadVersion)
(while (null ObjName)
(setvar "ERRNO" 0)
(setq ObjName (car (entsel)))
(if ObjName (setq ObjType (cdr(assoc 0 (entget ObjName)))))
(cond ((= (getvar "ERRNO") 52) (exit))
((= ObjType "TEXT")(Procedure_814))
((/= ObjType "TEXT")(setq ObjName nil))
)
)
(setq *error* nil)
(princ)
)
(defun Procedure_814()
(princ "\n 键、改变分割移动的位置")
(setq Data1 (entget ObjName))
(entdel ObjName)
(setq Contents (cdr (assoc 1 Data1)))
(setq TextH (cdr (assoc 40 Data1)))
(setq Ang (cdr (assoc 50 Data1)))
(setq ContentsL (StringToList Contents))
(setq Len (length ContentsL))
(if (and (= (cdr (assoc 72 Data1)) 0)(= (cdr (assoc 73 Data1)) 0)) (setq Co 10)(setq Co 11))
(setq Loc1 (cdr (assoc Co Data1)))
(setq Delta (SD8446 (list0 (* -1.2 TextH)) '(0 0) Ang))
(setq SPt (fix (* 0.5 Len)))
(setq SepL (ListSeparate ContentsL SPt))
(setq StrL (mapcar 'ListToString SepL))
(setq Data1 (subst (cons 1 (car StrL))(assoc 1 Data1) Data1))
(if (entmake Data1)(setq ObjName1 (entlast)))
(setq Data2 (subst (cons1 (cadr StrL))(assoc 1 Data1) Data1))
(setq Data2 (subst (cons Co (mapcar '+ Loc1 Delta))(assoc Co Data2) Data2))
(if (entmake Data2)(setq ObjName2 (entlast)))
(setq PtX nil)
(while (and (/= (car PtX) 3)(/= (car PtX) 11))
(setq PtX (grread nil 2 0))
(setq KeyX (cadr PtX))
(cond((or (= KeyX 97)(= KeyX 65))
(if (/= SPt 1)(setq SPt (1- SPt)))
)
((or(= KeyX 100)(= KeyX 68))
(if (/= SPt (1- Len))(setq SPt (1+ SPt)))
)
)
(cond ((or (= KeyX 100)(= KeyX 97)(= KeyX 65)(= KeyX 68))
(setq SepL (ListSeparate ContentsL SPt))
(setq StrL (mapcar 'ListToString SepL))
(setq Data1 (subst (cons 1 (car StrL))(assoc 1 Data1) Data1))
(setq Data2 (subst (cons1 (cadr StrL))(assoc 1 Data2) Data2))
(if ObjName1 (entdel ObjName1))
(if ObjName2 (entdel ObjName2))
(if (entmake Data1)(setq ObjName1 (entlast)))
(if (entmake Data2)(setq ObjName2 (entlast)))
)
)
)
)
(defun StringToList ( SSS / A_DATA A_LIST)
(setq AcadVersion (getvar "acadver"))
(cond
((or (= 17.0 (atof (substr AcadVersion 1 4)))
(and (= 17.2 (atof (substr AcadVersion 1 4)))(/= (ver) "Visual LISP 2009 (en)")))
(while ( /= SSS "")
(setq A_DATA (logand 224 (ascii SSS)))
(setq A_LIST (append A_LIST (list (substr SSS 1 1))))
(setq SSS (substr SSS 2))
)
)
(T
(while ( /= SSS "")
(setq A_DATA (logand 224 (ascii SSS)))
(if (or (= A_DATA 224) (= A_DATA 128))
(progn(setq A_LIST (append A_LIST (list (substr SSS 1 2))))
(setq SSS (substr SSS 3))
)
(progn(setq A_LIST (append A_LIST (list (substr SSS 1 1))))
(setq SSS (substr SSS 2))
)
)
)
)
)
A_LIST
)
(defun ListToString ( LLL / NewString)
(setq NewString "")
(while (/= LLL nil)
(setq NewString (strcat NewString (car LLL)))
(setq LLL (cdr LLL))
)
NewString
)
(defun SD8446 ( PointA PointB Ang / XA YA XB YB PointC)
(setqXA2(- (car PointA) (car PointB))
YA2(- (cadr PointA) (cadr PointB))
)
(setq PointC (list (- (* XA2 (cos Ang))(* YA2 (sin Ang))) (+ (* XA2 (sin Ang))(* YA2 (cos Ang)))))
(setq PointC (mapcar '+ PointC PointB))
PointC
)
(defun ListSeparate(GivenList BreakPoint)
(setq i 0 L1 nil)
(repeat BreakPoint
(setq L1 (append L1 (list (nth i GivenList))))
(setq i (1+ i))
)
(setq i BreakPoint L2 nil)
(repeat (- (length GivenList) BreakPoint)
(setq L2 (append L2 (list (nth i GivenList))))
(setq i (1+ i))
)
(setq TheList (list L1 L2))
TheList
)
(princ)
看来郎兄出手了，顶一下 langjs 发表于 2012-5-1 01:52
**** 本内容被作者隐藏 ****
鼠标点击位置获取不准确，能帮忙调整下吗？谢谢。 还差个函数STRINGTOLIST
no function definition: STRINGTOLIST print1985 发表于 2012-4-30 14:27 static/image/common/back.gif
还差个函数STRINGTOLIST
no function definition: STRINGTOLIST
不好意思，少了两个函数，已经补上。请测试。 **** Hidden Message *****
StringToList有关于双字节处理的 感谢分享！ 谢谢分享，回复学习 看看版主是如何做到的