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

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

本帖最后由 作者 于 2009-11-5 14:53:42 编辑 <br /><br /> <p>请教高手：VBA删除实体XDATA属性值问题，下面是在明经网站搜到的，怎末删除不了南方CASS实体的属性值呢？有没有比下面的还好用的函数呢，谢谢！！！！！</p><p>'参数:<br/>'Obj: 一个AcadObject?<br/>'RegApp: 已经注册的应用名 (可选)'<br/>'注意:<br/>'1如果未指定应用名，则删除所有的扩展数据。<br/>'2.该函数将不能删除AutoCAD本身的扩展数据<br/>'示例:<br/>'Call ClearXData(myAcadObject, "MCCAD")<br/>'http://www.mjtd.com/Functions/ArticleShow.asp?ArticleID=298</p><p>&nbsp;Public Sub WJSZClearXdata(Obj As AcadObject, Optional RegApp As String = "")<br/>&nbsp;&nbsp;&nbsp; Const regAppKey As Integer = 1001<br/>&nbsp;&nbsp;&nbsp; Const acadApp As String = "ACAD"<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; Dim XDType As Variant<br/>&nbsp;&nbsp;&nbsp; Dim XDData As Variant<br/>&nbsp;&nbsp;&nbsp; Dim NewType(0) As Integer<br/>&nbsp;&nbsp;&nbsp; Dim NewData(0) As Variant<br/>&nbsp;&nbsp;&nbsp; Dim i As Integer<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; Obj.GetXData appName:=RegApp, xdatatype:=XDType, XDataValue:=XDData<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; If Not IsEmpty(XDType) Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; For i = LBound(XDType) To UBound(XDType)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If XDType(i) = regAppKey Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If Not XDData(i) Like acadApp Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; NewType(0) = regAppKey<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; NewData(0) = XDData(i)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Obj.SetXData xdatatype:=NewType, XDataValue:=NewData<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Next i<br/>&nbsp;&nbsp;&nbsp; End If<br/>End Sub</p><p></p><p></p><p></p>

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

没有人知道吗？

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

本帖最后由 作者 于 2009-11-3 7:13:20 编辑

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

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

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

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

<p>原打算在绘图时添加些内容，但不知为何一直出错，正好借<strong><font face="Verdana" color="#61b713">mycad兄的帖子，一事不烦2主了！</font></strong></p><p>setname 的问题 是：提供的输入无效。请重新检查输入并重试。</p><p>我试过2个变量如dt(0 to 1)...,就通过了！</p><p>Sub SetName()<br/>Dim Ent As AcadEntity, pt, dt(0 To 2) As Integer, Str(0 To 2)<br/>dt(0) = 1001: dt(1) = 1002: dt(2) = 1003<br/>With ThisDrawing.Utility<br/>.GetEntity Ent, pt, "赋名对象：》"<br/>Str(0) = "水线": Str(1) = "200sx": Str(2) = "30mm"<br/>'Str(1) = .GetString(False, "对象名称：》")<br/>'Str(2) = .GetString(False, "对象厚度：》")<br/>End With<br/>&nbsp;<br/>Ent.SetXData dt, Str<br/>End Sub</p><p>getname 问题:直接报错及退出cad</p><p>Sub GetName()<br/>Dim Ent As AcadEntity, pt, dt, Str, tep, Mystr$<br/>ThisDrawing.Utility.GetEntity Ent, pt, "取值对象：》"<br/>Ent.GetXData "", dt, Str<br/>If VarType(Str) &lt;&gt; vbEmpty Then<br/>For Each tep In Str<br/>Mystr = Mystr &amp; vbCrLf &amp; tep<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Next<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>ThisDrawing.Utility.Prompt Mystr<br/>End Sub<br/></p>

mycad 发表于 2009-11-4 16:35:00

<p>dt(1) = 1002: dt(2) = 1003可能出问题了，应该为dt(1) = 1000: dt(2) = 1000；改后再试试看。</p><p><br/></p>

金色的烟 发表于 2009-11-5 09:42:00

<p>谢谢，好像可以了</p><p></p>

mycad 发表于 2009-11-5 14:55:00

<p>上次上传数据没有成功，不好意思，现在有了</p><p></p>

mycad 发表于 2009-11-6 07:49:00

解决了，找出成图软件的注册名，再删除xdata属性值就可以了，要注意成图软件的注册名可能有好几个的。
页: [1]
查看完整版本: [求助]请教版主：VBA删除实体XDATA属性值