将文本字符串分解成单个字符

lsjjm

将文本字符串分解成单个字符
[PHP]
(defun lenstr (ss)
  (setq tst (textbox (list (cons 1 ss))))
  (setq l (car (cadr tst)))
)
;
(defun c:test (/ a el str lst ll lst p)
  (setq a (car (entsel)))
  (setq el (entget a))
  (setq str (cdr (assoc 1 el)))
  (setq lst (mapcar 'chr (vl-string->list str)))
  (setq clay (getvar "clayer"))
  (setq csty (getvar "textstyle"))
  (setvar "textstyle" (cdr (assoc 7 el)))
  (repeat (strlen str)
    (if (> (strlen str) 1)
      (setq g2 (lenstr (substr str 2 1))
            ll (cons (list (- (lenstr (substr str 1 2)) g2)(substr str 1 1)) ll))
      (setq ll (cons (list 0 (substr str 1 1)) ll))
    )
    (setq str (substr str 2))
  )
  (vl-cmdf "layer" "s" (cdr (assoc 8 el)) "")
  (vl-cmdf "erase" a "")
  (setq p (cdr (assoc 10 el)))
  (foreach i (reverse ll)
    (vl-cmdf "text" p (cdr (assoc 40 el)) (* (/ 180 pi)(cdr (assoc 50 el)))(cadr i) "")
    (setq p (polar p (cdr (assoc 50 el))(car i)))
  )
  (setvar "textstyle" csty)
  (setvar "clayer" clay)
)
[/PHP]

Free-Lancer

你这个处理空格了吗？好像XD工具箱的可以

自由的鱼

是不是不支持中文的？执行以后文字不见了？

lsjjm

最初由 自由的鱼 发布
[B]是不是不支持中文的？执行以后文字不见了？ [/B]

哈哈! 前天跟你"字符旋转180度"的贴, 说执行程序后, "文字不见了" 今天你把它又还给我了?-----JUST KIDDING.
我的AUTOCAD是英文的, 所有的程序是否对中文有效,不得而知.

eachy

一个汉字是两个字符，用 （substr str 1 1）中文是肯定没了

陌生人

加个汉字识别，ascii好像是>13?   (个位不记得了)

lsjjm

还是请在CAD中经常使用汉字的朋友补充一下吧?

自由的鱼

最初由 lsjjm 发布
[B]还是请在CAD中经常使用汉字的朋友补充一下吧? [/B]

原来如此~~~：）

htm

搞成中文的才实用呢。

自由的鱼

支持中、英文字符，带空格
Sub TTT1()

Dim Fx As Variant
Dim pnt(0 To 2) As Double
Dim inspnt As Variant
Dim Ro As Double
Dim T As AcadText
Dim H As Double
Dim x As String
Dim Jl As Double
Dim Jj As Double
Dim y()
Dim s As Integer
Dim sset As AcadSelectionSet
Dim i As Integer
Dim Minpnt As Variant
Dim Maxpnt As Variant
For i = 0 To ThisDrawing.SelectionSets.Count - 1
    ThisDrawing.SelectionSets.Item(i).Clear
    ThisDrawing.SelectionSets.Item(i).Delete
Next

Set sset = ThisDrawing.SelectionSets.Add("tt")
sset.SelectOnScreen

sset.Item(0).GetBoundingBox Minpnt, Maxpnt


Jl = Sqr((Maxpnt(0) - Minpnt(0)) ^ 2 + (Maxpnt(1) - Minpnt(1)) ^ 2)


H = sset.Item(0).Height
Ro = sset.Item(0).Rotation
Fx = Ro
x = sset.Item(0).TextString
sset.Item(0).Delete
For i = 0 To Len(x) - 1
s = s + 1
ReDim Preserve y(s)

y(s) = Mid(x, s, 1)
Debug.Print y(s)
Next


v = Filter(y, " ", False)
Jj = Jl / UBound(v)

For i = 1 To UBound(v)
inspnt = ThisDrawing.Utility.PolarPoint(Minpnt, Fx, Jj * (i - 1))

Set T = ThisDrawing.ModelSpace.AddText(v(i), inspnt, H)
T.Rotate inspnt, Ro
T.Color = acRed
Debug.Print v(i)
Next


End Sub

陌生人

明天我也用vba玩一个：）

雪山飞狐(lzh)

写个另类一点的，:)
Sub TextExplode()
Dim pText As AcadEntity
Dim pMText As AcadMText
Dim pnt
ThisDrawing.Utility.GetEntity pText, pnt
Dim str As String
str = pText.textString
Dim pStr As String
Do While Len(str) <> 0
pStr = pStr & Left(str, 1) & "\C0;"
str = Right(str, Len(str) - 1)
Loop
Set pMText = ThisDrawing.ModelSpace.AddMText(pText.insertionPoint, 0, pStr)
pMText.height = pText.height
pMText.StyleName = pText.StyleName
pText.GetBoundingBox d1, d2
pMText.Rotate d1, pText.Rotation
pMText.GetBoundingBox d3, d4
pMText.Move d3, d1
ThisDrawing.SendCommand "Explode" & vbCr & "l" & vbCr & vbCr
pText.Delete
End Sub

fylinwater

唉 我也写了个绝对决定准确，就是文字分开后位置还是不变（如果两个文本重叠分解一个一个后，屏幕上看不出有一点错位）， 但现在还无法传上来，需要我们公司的环境函数支持

aeo

相通了其实很简单:
假定"ABCDE"
1,写ABCDE ,算出最右面点P(再删BCDE)
2,写BCDE,算出最右点p1 ,移动它从p1到p (再删CDE)
3,,写CDE,算出最右点p1 ,移动它从p1到p (再删DE)
....
写的时候以原来的属性，包括定义点.(特殊类型:先转到左对齐)

xyp1964

最初由 aeo 发布
[B]相通了其实很简单:
假定"ABCDE"
1,写ABCDE ,算出最右面点P(再删BCDE)
2,写BCDE,算出最右点p1 ,移动它从p1到p (再删CDE)
3,,写CDE,算出最右点p1 ,移动它从p1到p (再删DE)
....
写的时候以原来的属性，包括定义?.. [/B]

对中文也适用吗！