TEXT文本水平，垂直分解

陌生人

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

2. 
   
3. 'text字符串分解－垂直排列   修改by陌生人
   
4. '修改 from lzh
   
5. Public Sub Textexv()
   
6. Dim pText As AcadEntity
   
7. Dim pnt
   
8. ThisDrawing.Utility.GetEntity pText, pnt
   
9. Dim str As String
   
10. str = pText.TextString
    
11. Dim pStr As String
    
12. Dim Txth As Double
    
13. Txth = pText.Height
    
14. Dim inspt As ACAD_POINT
    
15. inspt = pText.InsertionPoint
    
16. Dim polarPnt As ACAD_POINT
    
17. polarPnt = ThisDrawing.Utility.PolarPoint(inspt, (pText.Rotation + 1.57079), Txth)
    
18. Do While Len(str) <> 0
    
19. pStr = pStr & Left(str, 1) & "\P"
    
20. str = Right(str, Len(str) - 1)
    
21. Loop
    
22. Set mT = ThisDrawing.ModelSpace.AddMText(polarPnt, 0, pStr)
    
23. mT.Height = Txth
    
24. mT.Rotation = pText.Rotation
    
25. mT.StyleName = pText.StyleName
    
26. ThisDrawing.SendCommand "Explode" & vbCr & "l" & vbCr & vbCr
    
27. pText.Delete
    
28. End Sub
    
29. 
    
30. 
    
31. 'text字符串分解－水平排列  by陌生人
    
32. Public Sub Textexh()
    
33. Dim pText As AcadEntity
    
34. Dim pnt
    
35. ThisDrawing.Utility.GetEntity pText, pnt
    
36. Dim str As String
    
37. str = pText.TextString
    
38. Dim pStr As String
    
39. Dim Txth As Double
    
40. Txth = pText.Height
    
41. Dim inspt As ACAD_POINT
    
42. inspt = pText.InsertionPoint
    
43. Dim polarPnt As ACAD_POINT
    
44. polarPnt = ThisDrawing.Utility.PolarPoint(inspt, (pText.Rotation + 1.57079), Txth)
    
45. Do While Len(str) <> 0
    
46. pStr = pStr & Left(str, 1) & "\H1X"
    
47. str = Right(str, Len(str) - 1)
    
48. Loop
    
49. Set mT = ThisDrawing.ModelSpace.AddMText(polarPnt, 0, pStr)
    
50. mT.Height = Txth
    
51. mT.Rotation = pText.Rotation
    
52. mT.StyleName = pText.StyleName
    
53. ThisDrawing.SendCommand "Explode" & vbCr & "l" & vbCr & vbCr
    
54. pText.Delete
    
55. End Sub
    

<br /> 'text字符串分解－垂直排列   修改by陌生人<br /> '修改 from lzh<br /> Public Sub Textexv()<br /> Dim pText As AcadEntity<br /> Dim pnt<br /> ThisDrawing.Utility.GetEntity pText, pnt<br /> Dim str As String<br /> str = pText.TextString<br /> Dim pStr As String<br /> Dim Txth As Double<br /> Txth = pText.Height<br /> Dim inspt As ACAD_POINT<br /> inspt = pText.InsertionPoint<br /> Dim polarPnt As ACAD_POINT<br /> polarPnt = ThisDrawing.Utility.PolarPoint(inspt, (pText.Rotation + 1.57079), Txth)<br /> Do While Len(str) <> 0<br /> pStr = pStr & Left(str, 1) & "\P"<br /> str = Right(str, Len(str) - 1)<br /> Loop<br /> Set mT = ThisDrawing.ModelSpace.AddMText(polarPnt, 0, pStr)<br /> mT.Height = Txth<br /> mT.Rotation = pText.Rotation<br /> mT.StyleName = pText.StyleName<br /> ThisDrawing.SendCommand "Explode" & vbCr & "l" & vbCr & vbCr<br /> pText.Delete<br /> End Sub<br /> <br /> <br /> 'text字符串分解－水平排列  by陌生人<br /> Public Sub Textexh()<br /> Dim pText As AcadEntity<br /> Dim pnt<br /> ThisDrawing.Utility.GetEntity pText, pnt<br /> Dim str As String<br /> str = pText.TextString<br /> Dim pStr As String<br /> Dim Txth As Double<br /> Txth = pText.Height<br /> Dim inspt As ACAD_POINT<br /> inspt = pText.InsertionPoint<br /> Dim polarPnt As ACAD_POINT<br /> polarPnt = ThisDrawing.Utility.PolarPoint(inspt, (pText.Rotation + 1.57079), Txth)<br /> Do While Len(str) <> 0<br /> pStr = pStr & Left(str, 1) & "\H1X"<br /> str = Right(str, Len(str) - 1)<br /> Loop<br /> Set mT = ThisDrawing.ModelSpace.AddMText(polarPnt, 0, pStr)<br /> mT.Height = Txth<br /> mT.Rotation = pText.Rotation<br /> mT.StyleName = pText.StyleName<br /> ThisDrawing.SendCommand "Explode" & vbCr & "l" & vbCr & vbCr<br /> pText.Delete<br /> End Sub<br />

雪山飞狐(lzh)

水平排列比偶用的好，偶的是变颜色，还要把颜色改回，上面的代码就简单点
ps:长老不会是抢偶们VBA的饭碗吧，：）
另：原来的Text字符没删除呀，字体也会变

陌生人

哪敢啊，玩玩而已：P

另：原来的Text字符没删除呀，字体也会变

已经补上了，thanks

自由的鱼

最初由 lzh741206 发布
[B]水平排列比偶用的好，偶的是变颜色，还要把颜色改回，上面的代码就简单点
ps:长老不会是抢偶们VBA的饭碗吧，：）
另：原来的Text字符没删除呀，字体也会变 [/B]

呵，我要学烹饪了，万一下岗了就当厨师去啦~~~

雪山飞狐(lzh)

偶也来发个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)))
)

ahlzl

相互学习，好！好！！
可惜长不大……

陌生人

嘻嘻
[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]

lsjjm

最初由 陌生人 发布
[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)) (无考虑中文)

eachy

最初由 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

陌生人

ea,你定的是<159 是依据什么？能说说么？
我知道很多shx，把特殊字符写到130以后，但不知道会用到多少，也许应该分两节
<128 and >159?

梦断江南

文字分解还是有待完善，当文字高宽比不为1的时候，不能准确还原