找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 1413|回复: 10

TEXT文本水平,垂直分解

[复制链接]
发表于 2004-7-11 15:39:34 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有账号?立即注册

×
vba处理汉字的确爽一些。我是不会VBA的,受到lzh的启发,现学现卖,见笑了,望大侠指教:)

  1. 'text字符串分解-垂直排列   修改by陌生人
  2. '修改 from lzh
  3. Public Sub Textexv()
  4. Dim pText As AcadEntity
  5. Dim pnt
  6. ThisDrawing.Utility.GetEntity pText, pnt
  7. Dim str As String
  8. str = pText.TextString
  9. Dim pStr As String
  10. Dim Txth As Double
  11. Txth = pText.Height
  12. Dim inspt As ACAD_POINT
  13. inspt = pText.InsertionPoint
  14. Dim polarPnt As ACAD_POINT
  15. polarPnt = ThisDrawing.Utility.PolarPoint(inspt, (pText.Rotation + 1.57079), Txth)
  16. Do While Len(str) <> 0
  17. pStr = pStr & Left(str, 1) & "\P"
  18. str = Right(str, Len(str) - 1)
  19. Loop
  20. Set mT = ThisDrawing.ModelSpace.AddMText(polarPnt, 0, pStr)
  21. mT.Height = Txth
  22. mT.Rotation = pText.Rotation
  23. mT.StyleName = pText.StyleName
  24. ThisDrawing.SendCommand "Explode" & vbCr & "l" & vbCr & vbCr
  25. pText.Delete
  26. End Sub


  27. 'text字符串分解-水平排列  by陌生人
  28. Public Sub Textexh()
  29. Dim pText As AcadEntity
  30. Dim pnt
  31. ThisDrawing.Utility.GetEntity pText, pnt
  32. Dim str As String
  33. str = pText.TextString
  34. Dim pStr As String
  35. Dim Txth As Double
  36. Txth = pText.Height
  37. Dim inspt As ACAD_POINT
  38. inspt = pText.InsertionPoint
  39. Dim polarPnt As ACAD_POINT
  40. polarPnt = ThisDrawing.Utility.PolarPoint(inspt, (pText.Rotation + 1.57079), Txth)
  41. Do While Len(str) <> 0
  42. pStr = pStr & Left(str, 1) & "\H1X"
  43. str = Right(str, Len(str) - 1)
  44. Loop
  45. Set mT = ThisDrawing.ModelSpace.AddMText(polarPnt, 0, pStr)
  46. mT.Height = Txth
  47. mT.Rotation = pText.Rotation
  48. mT.StyleName = pText.StyleName
  49. ThisDrawing.SendCommand "Explode" & vbCr & "l" & vbCr & vbCr
  50. pText.Delete
  51. End Sub
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
发表于 2004-7-11 15:44:45 | 显示全部楼层
水平排列比偶用的好,偶的是变颜色,还要把颜色改回,上面的代码就简单点
ps:长老不会是抢偶们VBA的饭碗吧,:)
另:原来的Text字符没删除呀,字体也会变
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2004-7-11 15:50:38 | 显示全部楼层
哪敢啊,玩玩而已:P
另:原来的Text字符没删除呀,字体也会变

已经补上了,thanks
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2004-7-11 16:17:09 | 显示全部楼层
最初由 lzh741206 发布
[B]水平排列比偶用的好,偶的是变颜色,还要把颜色改回,上面的代码就简单点
ps:长老不会是抢偶们VBA的饭碗吧,:)
另:原来的Text字符没删除呀,字体也会变 [/B]


呵,我要学烹饪了,万一下岗了就当厨师去啦~~~
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2004-7-11 19:18:44 | 显示全部楼层
偶也来发个Lisp处理汉字的,:)
;转换字符串为字符表,相当与VB.Net的ToChar -by 雪山飞狐
(defun Str2Chrs(strA / pAsc)
(setq pAsc (if (< (ascii strA) 128) 1 2))
(cond ((> (strlen strA) pAsc)
(cons (substr strA 1 pAsc) (str2Chrs (substr strA (1+ pAsc)))))
((list (substr strA 1 pAsc))))
)

;合并字符表,并加入分隔符,相当与VB的同名函数 -by 雪山飞狐
(defun Join(Chrs fchr / pStr)
(setq pStr "")
(foreach i Chrs (setq pStr (strcat pStr i fchr)))
(substr pStr 1 (- (strlen pStr) (strlen fchr)))
)
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2004-7-11 19:22:56 | 显示全部楼层
相互学习,好!好!!
可惜长不大……
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2004-7-11 20:50:35 | 显示全部楼层
嘻嘻
[php]
;(strex str)字符串分解列表.
;测试: (strex "1asd,+测试1e99") -> ("1" "a" "s" "d" "," "+" "测" "试" "1" "e" "9" "9")
(defun strex (str / i k s lst)
  (setq i 0 k (chr 128))
  (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)
)
[/php]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2004-7-12 04:57:29 | 显示全部楼层
最初由 陌生人 发布
[B]嘻嘻[php]
;(strex str)字符串分解列表.
;测试: (strex "1asd,+测试1e99") -> ("1" "a" "s" "d" "," "+" "测" "试" "1" "e" "9" "9")
(defun strex (str / i k s lst)
  (setq i 0 k (chr 128))
  (while (/=... [/B]


字符串分解列表:
(mapcar 'chr (vl-string->list aa)) (无考虑中文)
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 593个

财富等级: 财运亨通

发表于 2004-7-13 13:54:25 | 显示全部楼层
最初由 lsjjm 发布
[B][QUOTE]最初由 陌生人 发布
[B]嘻嘻[php]
;(strex str)字符串分解列表.
;测试: (strex "1asd,+测试1e99") -> ("1" "a" "s" "d" "," "+" "测" "试" "1" "e" "9" "9")
(defun strex (str / i k s lst)
  (... [/B]

http://www.xdcad.net/forum/showt ... d=294121#post294121
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2004-7-13 20:10:39 | 显示全部楼层
ea,你定的是<159 是依据什么?能说说么?
我知道很多shx,把特殊字符写到130以后,但不知道会用到多少,也许应该分两节
<128 and >159?
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2004-8-27 23:46:15 | 显示全部楼层
文字分解还是有待完善,当文字高宽比不为1的时候,不能准确还原
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-6-24 08:12 , Processed in 0.595393 second(s), 51 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

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