设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 请高手帮忙修改一下源代码（文字打断）
12345678910... 21下一页
返回列表 发新帖
查看: 24037|回复: 202

请高手帮忙修改一下源代码（文字打断）

  [复制链接]
sz721
发表于 2012-4-30 12:18:39 | 显示全部楼层 |阅读模式
本帖最后由 sz721 于 2012-4-30 16:33 编辑

这是一段日本网站下载的文字打断源代码。功能：把单行文字在任意位置分割成两行（使用A和D键用于动态切换位置）。在测试纯数字时没有问题，但是用于中文字就不行了，会出现乱码现象。我想应该是日文字符的全角半角字符长度和中文字符的不同。请高手修改一下代码，谢谢！

  3. (defun c:dd1 ( / ObjName ObjType)
  4.   (princ "\n 把单行文字列在任意位置分割成两行（A和D键用于切换位置）")
  5. (setq *error* *myerror*)   
  6. (setq AcadVersion (getvar "acadver"))
  7. (princ "\n AcadVersion :  ")(princ AcadVersion)
  8. (while (null ObjName)
  9.   (setvar "ERRNO" 0)
  10.   (setq ObjName (car (entsel)))
  11.   (if ObjName (setq ObjType (cdr(assoc 0 (entget ObjName)))))
  12.   (cond ((= (getvar "ERRNO") 52) (exit))
  13.     ((= ObjType "TEXT")(Procedure_814))
  14.     ((/= ObjType "TEXT")(setq ObjName nil))
  15.   )
  16. )
  17. (setq *error* nil)
  18. (princ)
  19. )
  20. (defun Procedure_814()
  21. (princ "\n [A] [D] 键、改变分割移动的位置")
  22. (setq Data1 (entget ObjName))
  23. (entdel ObjName)
  24. (setq Contents (cdr (assoc 1 Data1)))
  25. (setq TextH (cdr (assoc 40 Data1)))
  26. (setq Ang (cdr (assoc 50 Data1)))
  27. (setq ContentsL (StringToList Contents))
  28. (setq Len (length ContentsL))
  29. (if (and (= (cdr (assoc 72 Data1)) 0)(= (cdr (assoc 73 Data1)) 0)) (setq Co 10)(setq Co 11))
  30. (setq Loc1 (cdr (assoc Co Data1)))
  31. (setq Delta (SD8446 (list  0 (* -1.2 TextH)) '(0 0) Ang))
  32. (setq SPt (fix (* 0.5 Len)))
  33. (setq SepL (ListSeparate ContentsL SPt))
  34. (setq StrL (mapcar 'ListToString SepL))
  35. (setq Data1 (subst (cons 1 (car StrL))(assoc 1 Data1) Data1))
  36. (if (entmake Data1)(setq ObjName1 (entlast)))
  37. (setq Data2 (subst (cons  1 (cadr StrL))(assoc 1 Data1) Data1))
  38. (setq Data2 (subst (cons Co (mapcar '+ Loc1 Delta))(assoc Co Data2) Data2))
  39. (if (entmake Data2)(setq ObjName2 (entlast)))
  40.         (setq PtX nil)
  41. (while (and (/= (car PtX) 3)(/= (car PtX) 11))
  42.   (setq PtX (grread nil 2 0))
  43.   (setq KeyX (cadr PtX))
  44.   (cond  ((or (= KeyX 97)(= KeyX 65))
  45.      (if (/= SPt 1)(setq SPt (1- SPt)))
  46.     )
  47.     ((or(= KeyX 100)(= KeyX 68))
  48.      (if (/= SPt (1- Len))(setq SPt (1+ SPt)))
  49.     )
  50.   )
  51.   (cond ((or (= KeyX 100)(= KeyX 97)(= KeyX 65)(= KeyX 68))
  52.     (setq SepL (ListSeparate ContentsL SPt))
  53.     (setq StrL (mapcar 'ListToString SepL))
  54.     (setq Data1 (subst (cons 1 (car StrL))(assoc 1 Data1) Data1))
  55.     (setq Data2 (subst (cons  1 (cadr StrL))(assoc 1 Data2) Data2))
  56.     (if ObjName1 (entdel ObjName1))
  57.     (if ObjName2 (entdel ObjName2))
  58.     (if (entmake Data1)(setq ObjName1 (entlast)))
  59.     (if (entmake Data2)(setq ObjName2 (entlast)))
  60.     )
  61.   )
  62. )
  63. )
  64. (defun StringToList ( SSS / A_DATA A_LIST)
  65. (setq AcadVersion (getvar "acadver"))
  66. (cond  
  67.    ((or (= 17.0 (atof (substr AcadVersion 1 4)))
  68.     (and (= 17.2 (atof (substr AcadVersion 1 4)))(/= (ver) "Visual LISP 2009 (en)")))
  69.     (while ( /= SSS "")
  70.      (setq A_DATA (logand 224 (ascii SSS)))
  71.      (setq A_LIST (append A_LIST (list (substr SSS 1 1))))
  72.      (setq SSS (substr SSS 2))
  73.     )
  74.    )
  75.    (T
  76.       (while ( /= SSS "")
  77.      (setq A_DATA (logand 224 (ascii SSS)))
  78.      (if (or (= A_DATA 224) (= A_DATA 128))
  79.       (progn(setq A_LIST (append A_LIST (list (substr SSS 1 2))))
  80.            (setq SSS (substr SSS 3))
  81.         )
  82.       (progn(setq A_LIST (append A_LIST (list (substr SSS 1 1))))
  83.            (setq SSS (substr SSS 2))
  84.       )
  85.      )
  86.     )
  87.    )
  88. )
  89.   A_LIST
  90. )
  91. (defun ListToString ( LLL / NewString)
  92. (setq NewString "")
  93. (while (/= LLL nil)
  94.      (setq NewString (strcat NewString (car LLL)))
  95.      (setq LLL (cdr LLL))
  96. )
  97. NewString
  98. )
  99. (defun SD8446 ( PointA PointB Ang / XA YA XB YB PointC)
  100. (setq  XA2(- (car PointA) (car PointB))
  101.    YA2(- (cadr PointA) (cadr PointB))
  102. )
  103. (setq PointC (list (- (* XA2 (cos Ang))(* YA2 (sin Ang))) (+ (* XA2 (sin Ang))(* YA2 (cos Ang)))))
  104. (setq PointC (mapcar '+ PointC PointB))
  105. PointC
  106. )
  107. (defun ListSeparate(GivenList BreakPoint)
  108. (setq i 0 L1 nil)
  109. (repeat BreakPoint
  110.   (setq L1 (append L1 (list (nth i GivenList))))
  111.   (setq i (1+ i))
  112. )
  113. (setq i BreakPoint L2 nil)
  114. (repeat (- (length GivenList) BreakPoint)
  115.   (setq L2 (append L2 (list (nth i GivenList))))
  116.   (setq i (1+ i))
  117. )
  118. (setq TheList (list L1 L2))
  119. TheList
  120. )
  121. (princ)
源代码
"觉得好，就打赏"
打赏
还没有人打赏，支持一下

相关帖子
回复

使用道具 举报

xiaxiang
发表于 2012-5-1 09:03:35 | 显示全部楼层
看来郎兄出手了，顶一下
回复 支持 0 反对 1

使用道具 举报

Adam2897
发表于 2024-5-8 22:43:48 | 显示全部楼层
langjs 发表于 2012-5-1 01:52
**** 本内容被作者隐藏 ****

鼠标点击位置获取不准确，能帮忙调整下吗？谢谢。
回复 支持 反对

使用道具 举报

print1985
发表于 2012-4-30 14:27:52 | 显示全部楼层
还差个函数STRINGTOLIST
no function definition: STRINGTOLIST
回复 支持 反对

使用道具 举报

sz721
 楼主| 发表于 2012-4-30 16:36:18 | 显示全部楼层
print1985 发表于 2012-4-30 14:27
还差个函数STRINGTOLIST
no function definition: STRINGTOLIST

不好意思，少了两个函数，已经补上。请测试。
回复 支持 反对

使用道具 举报

langjs
发表于 2012-5-1 01:52:41 | 显示全部楼层
(defun c:aa (/ 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 [A] [D] 键、改变分割移动的位置")
  (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 (list 0 (* -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
                (cons 1 (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
                      (cons 1 (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)))
        (if (> (ascii (setq nn (substr sss 1 1))) 160)
          (setq nn (substr sss 1 2)
                sss (substr sss 3)
          )
          (setq sss (substr sss 2))
        )
        (setq a_list (append
                       a_list
                       (list nn)
                     )
        )
      )
    )
    (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
            (if (> (ascii (setq nn (substr sss 1 1))) 160)
              (setq nn (substr sss 1 2)
                    sss (substr sss 3)
              )
              (setq sss (substr sss 2))
            )
            (setq a_list (append
                           a_list
                           (list nn)
                         )
            )
          )
        )
      )
    )
  )
  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)
  (setq xa2 (- (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)



点评

adc
谢谢分享，切断的位置能不能调整一下，最好是在鼠标点击的位置。  发表于 2012-9-10 12:20
sz721
非常感谢！学习了。  发表于 2012-5-1 08:07
回复 支持 反对

使用道具 举报

xyh
发表于 2012-5-1 07:13:17 | 显示全部楼层
StringToList有关于双字节处理的
回复 支持 反对

使用道具 举报

CTC
发表于 2012-5-1 07:14:50 | 显示全部楼层
回复 支持 反对

使用道具 举报

laiz3000
发表于 2012-5-1 08:27:28 | 显示全部楼层
感谢分享！
回复 支持 反对

使用道具 举报

注册
发表于 2012-5-1 08:39:01 | 显示全部楼层
谢谢分享，回复学习
回复 支持 反对

使用道具 举报

fdb2007
发表于 2012-5-1 09:32:33 | 显示全部楼层
看看版主是如何做到的
回复 支持 反对

使用道具 举报

12345678910... 21下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-25 17:35 , Processed in 0.205234 second(s), 33 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表