飞狐版主请进+《AutoCAD VBA开发精彩实例教程》问题

idoo

在《AutoCAD VBA开发精彩实例教程》2004年1月第一版中，第3.8节的程序在执行时为什么总是提示“不支持的对象库功能”？？焦点锁定在

If Not IsNull(ThisDrawing.SelectionSets.item("this")) Then
        Set SSet = ThisDrawing.SelectionSets.item("this")
        SSet.Delete
    End If

的SSet=上，该如何解决？

idoo

不会大家都用不到这个吧？？

chenfeng22

少了定义了吧

dim SSet as SelectionSets

idoo

是的，应该是定义为SelectionSets，源程序定义成了SelectionSet，以及第66行，也应该为Dim objUcs As AcadUCSs，源程序错误成Dim objUcs As AcadUCS。可是第89行开始：

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

又有问题，提示不支持的对象库功能，焦点锁定在blkRef =上，请问哪里还有问题啊～～

idoo

将AcadBlockReference更改为AcadBlock，能够运行，可是得不到结果……

idoo

这里是所有的代码，能不能帮我看看。

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

idoo

有没有用过啊？？？

雪山飞狐_lzh

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
        Exit Sub
    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
    ThisDrawing.SelectionSets.item("this").Delete
    Set SSet = ThisDrawing.SelectionSets.Add("this")
    Dim item(0) As AcadEntity
    Set item(0) = objEnt
    SSet.AddItems item
   
    '输出WMF文件
    ThisDrawing.Export "d:\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("d:\temp.wmf") <> "" Then    '判断文件是否存在
        ThisDrawing.Import "d:\temp.wmf", ptBase, 2
        Kill ("d:\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

mayuezxl

《AutoCAD VBA开发精彩实例教程》这本书哪里有买？

idoo

书店应该都有的，要么就直接去规模大的书店找。