[求助]请教版主：VBA删除实体XDATA属性值

mycad · 发表于 2009-10-30 14:37:00

请教高手：VBA删除实体XDATA属性值问题，下面是在乐筑天下网站搜到的，怎末删除不了南方CASS实体的属性值呢？有没有比下面的还好用的函数呢，谢谢！！！！！
'参数:
'Obj: 一个AcadObject?
'RegApp: 已经注册的应用名 (可选)'
'注意:
'1如果未指定应用名，则删除所有的扩展数据。
'2.该函数将不能删除本身的扩展数据
'示例:
'Call ClearXData(myAcadObject, "MCCAD")
'http://www.mjtd.com/Functions/ArticleShow.asp?ArticleID=298
&nbspublic Sub WJSZClearXdata(Obj As AcadObject, Optional RegApp As String = "")
Const regAppKey As Integer = 1001
Const acadApp As String = "ACAD"

Dim XDType As Variant
Dim XDData As Variant
Dim NewType(0) As Integer
Dim NewData(0) As Variant
Dim i As Integer

Obj.GetXData appName:=RegApp, xdatatype:=XDType, XDataValue:=XDData

If Not IsEmpty(XDType) Then
      For i = LBound(XDType) To UBound(XDType)
         If XDType(i) = regAppKey Then
            If Not XDData(i) Like acadApp Then
                  NewType(0) = regAppKey
                  NewData(0) = XDData(i)
                  Obj.SetXData xdatatype:=NewType, XDataValue:=NewData
            End If
         End If
      Next i
End If
End Sub

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

mycad · 发表于 2009-11-2 06:57:00

没有人知道吗？

mycad · 发表于 2009-11-2 16:59:00

这么多网友看了，没人回复吗，只能麻烦版主了，先谢谢了！！1

wylong · 发表于 2009-11-3 11:20:00

关键在Call ClearXData(myAcadObject, "MCCAD")中的"MCCAD"，也就是要改成南方CASS定义的程序名。

金色的烟 · 发表于 2009-11-3 20:15:00

原打算在绘图时添加些内容，但不知为何一直出错，正好借mycad兄的帖子，一事不烦2主了！
setname 的问题是：提供的输入无效。请重新检查输入并重试。
我试过2个变量如dt(0 to 1)...,就通过了！
Sub SetName()
Dim Ent As AcadEntity, pt, dt(0 To 2) As Integer, Str(0 To 2)
dt(0) = 1001: dt(1) = 1002: dt(2) = 1003
With ThisDrawing.Utility
.GetEntity Ent, pt, "赋名对象：》"
Str(0) = "水线": Str(1) = "200sx": Str(2) = "30mm"
'Str(1) = .GetString(False, "对象名称：》")
'Str(2) = .GetString(False, "对象厚度：》")
End With

Ent.SetXData dt, Str
End Sub
getname 问题:直接报错及退出cad
Sub GetName()
Dim Ent As AcadEntity, pt, dt, Str, tep, Mystr$
ThisDrawing.Utility.GetEntity Ent, pt, "取值对象：》"
Ent.GetXData "", dt, Str
If VarType(Str)  vbEmpty Then
For Each tep In Str
Mystr = Mystr & vbCrLf & tep

         Next
      End If
ThisDrawing.Utility.Prompt Mystr
End Sub