[教学]：文字分解为多段线

yunzhong80

Option Explicit

Sub ExplodeText()
    '输出WMF文件*****************************************
    '选择文字
    Dim objText As AcadText
    Dim objMtext As AcadMText
    Dim ptMin, ptMax        '文字限制框的角点
   
    Dim objEnt As AcadEntity
    Dim pt As Variant
   
    On Error Resume Next
Retry:
    ThisDrawing.Utility.GetEntity objEnt, pt, "选择要分解的文字："
   
    If Err <> 0 Then        '错误处理
        Err.Clear
        GoTo Retry
    End If
   
    '获得文字的限制框角点
      If objEnt.ObjectName = "AcDbText" Then
        Set objText = objEnt
        objText.GetBoundingBox ptMin, ptMax
    ElseIf objEnt.ObjectName = "AcDbMText" Then
        Set objMtext = objEnt
        objMtext.GetBoundingBox ptMin, ptMax
    Else
        MsgBox "所选择的实体不是文字或者多行文字对象！", vbCritical
        Exit Sub
    End If
   
    '为了提高分辨率，保证对象完全在当前视口中，进行缩放操作
    ZoomWindow ptMin, ptMax
    'ZoomScaled 0.9, acZoomScaledRelative
   
   
    '创建选择集
    Dim SSet As AcadSelectionSet
    If Not IsNull(ThisDrawing.SelectionSets.item("this")) Then
        Set SSet = ThisDrawing.SelectionSets.item("this")
        SSet.Delete
    End If
    Set SSet = ThisDrawing.SelectionSets.Add("this")
    Dim item(0) As AcadEntity
    Set item(0) = objEnt
    SSet.AddItems item
   
    '输出WMF文件
    ThisDrawing.Export "C:\temp", "WMF", SSet
   
    '输入WMF文件*****************************************
    '当前视口的高宽
    Dim height As Double, width As Double   '当前图形窗口的宽、高
    height = ThisDrawing.GetVariable("ViewSize")    '返回当前视口的高度（图形单位）
    Dim dblScale As Variant     '高宽比例
    dblScale = ThisDrawing.GetVariable("ScreenSize")    '该系统变量返回当前视口的像素单位（x和y值）
    width = (dblScale(0) / dblScale(1)) * height
   
    '视图中心点的绝对坐标
    Dim ptCen, ptTemp
    Dim ucsName As String
    ucsName = ThisDrawing.GetVariable("UCSNAME")    '该系统变量返回当前UCS的名称
    If ucsName <> "" Then
        Dim objUcs As AcadUCS
        Set objUcs = ThisDrawing.ActiveUCS
        ptTemp = ThisDrawing.GetVariable("viewctr")     '返回当前视口的中心点(UCS坐标)
        ptCen = ThisDrawing.Utility.TranslateCoordinates(ptTemp, acUCS, acWorld, False)
    ElseIf ucsName = "" Then
        ptCen = ThisDrawing.GetVariable("viewctr")
    End If
   
    '视图左上角点的坐标（即WMF图形插入的基点）
    Dim ptBase(0 To 2) As Double
    ptBase(0) = ptCen(0) - width / 2: ptBase(1) = ptCen(1) + height / 2: ptCen(2) = 0
   
        
    '输入文件
    If Dir("C:\temp.wmf") <> "" Then    '判断文件是否存在
        ThisDrawing.Import "C:\temp.wmf", ptBase, 2
        Kill ("c:\temp.wmf")    '删除临时文件
    Else
        MsgBox "程序使用的临时文件不存在，请重新运行程序！", vbCritical
        Exit Sub
    End If
   
    '分解得到的块参照************************************
    Dim blkRef As AcadBlockReference
    Dim element As AcadEntity
    Set element = ThisDrawing.ModelSpace.item(ThisDrawing.ModelSpace.Count - 1)
    If TypeOf element Is AcadBlockReference Then
        Set blkRef = element
        blkRef.Explode
        blkRef.Delete
    End If
   
    objEnt.Delete   '删除原来的文字对象
    SSet.Delete
   
    '缩放图形，返回原来的视图
    ZoomPrevious
    'ZoomPrevious
End Sub

1121443108qaz

这个怎么用的