|
|
发表于 2006-8-15 21:24:00
|
显示全部楼层
这里是所有的代码，能不能帮我看看。
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 AcadSelectionSets
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 AcadUCSs
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
|
|
置顶卡
