根据块名附属性.doc

;根据块名附属性(defunc:test()(regappsouth)(setqsscnt0)(promptn请选择要赋属性的块:)(if(setqins_all(ssget(list(0.insert)(repeat(sslengthins_all)(setqss_ins_name(ssnameins_allsscnt)(setqss_ins_att(entgetss_ins_name(list*)(setqins_name(cdr(assoc2ss_ins_att)(setqins_code(substrins_name1(vl-string-position(ascii_)ins_name)(setqins_code_lst(list-3(listsouth(cons1000ins_code)(setqss_ins_att(reverse(append(listins_code_lst)(reversess_ins_att)(entmodss_ins_att)(setqsscnt(1+sscnt)#语法 (xdsize list)功能及参数 此函数将返回当 list 被附加到一个图元中作为扩展图元数据 (Xdata) 时, 它所占用的位组大小。如果不成功, 这个函数会返回 nil。 list 必须是一个合法的 xdata 表, 它必须包含一个前面已经使用 regapp 函数注册过的应用程序名称。大括号()项 (群组代码1002) 必须要对称。一个不合法的 list 将会产生一个错误, 并将适当的错误代码放置于 ERRNO 变量中。如果 Xdata 中包含一个尚未注册的应用程序名称, 则您会看到以下的错误信息(假定 COMDECHO 为 on): Invalid application name 1001 group 这个 list 可以从群组代码-3 开始, 但是它并不是必须的, 因为 Xdata 可以包含多个应用程序的说明。这个表必须要有一组括起来的括号： (-3 (MYAPP (1000 . SUITOFARMOR) (1002 . ) (1040 . 0.0) (1040 . 1.0) (1002 . ) ) ) 以下也是没有群组代码 -3 的相同范例。这个表刚好是第一个范例的 cdr, 但是将括起来的括号包含在里面是很重要的。 ( (MYAPP (1000 . SUITOFARMOR) (1002 . ) (1040 . 0.0) (1040 . 1.0) (1002 . ) ) Invalid application name 1001 group 这个 list 可以从群组代码-3 开始, 但是它并不是必须的, 因为 Xdata 可以包含多个应用程序的说明。这个表必须要有一组括起来的括号： (-3 (MYAPP (1000 . SUITOFARMOR) (1002 . ) (1040 . 0.0) (1040 . 1.0) (1002 . ) ) ) 以下也是没有群组代码 -3 的相同范例。这个表刚好是第一个范例的 cdr, 但是将括起来的括号包含在里面是很重要的。 ( (MYAPP (1000 . SUITOFARMOR) (1002 . ) (1040 . 0.0) (1040 . 1.0) (1002 . ) )范例 (setq n2 (list YOURAPP (cons 1000 SUITOFARMOR) (cons 1040 0.0) (cons 1040 1.0) ) ) (regapp MYAPP) (ragapp YOURAPP) 则: (xdsize (list n1 n2) 返回 48# (cons 1040 0.0) (cons 1040 1.0) ) ) (regapp MYAPP) (ragapp YOURAPP) 则: (xdsize (list n1 n2) 返回 48扩展数据扩展数据 (xdata) 由 AutoLISP 或 ObjectARX 应用程序创建。如果图元包含扩展数据，则扩展数据将跟随在图元的普通定义数据之后。组码 1000 至 1071 描述了扩展数据。下面是一个包含 DXF 格式扩展数据的图元样例。普通图元定义数据： 0 INSERT 5F11100AcDbEntity 8TOP100AcDbBlockReference 2BLOCK_A 100.0 200.0 300.0扩展图元定义数据：1001AME_SOL10021070 01071 1.95059E+061070 51910102.5471710202.12264210302.0492011005ECD1005EE91005010400.010401.01000MILD_STEEL组码 1001 表示扩展数据的开始。与普通图元数据相比，具有扩展数据的同一组码可以出现多次，而且出现次序很重要。扩展数据按注册的应用程序名分组。每个注册的应用程序组始于 1001 组码，并将程序名作为字符串值。注册的应用程序名对应于 APPID 符号表条目。应用程序可以根据需要使用任意多的 APPID 名。APPID 名是固定不变的，但是，如果当前未在图形中使用 APPID 名，则可以将它们删除。每个 APPID 名只能向每个图元附加一个数据组。在应用程序组中，扩展数据组的顺序和含义由应用程序定义。下表列出了扩展数据组码。 扩展数据组码和说明图元名组码说明字符串1000扩展数据中字符串的最大长度为 255 个字节（第 256 个字节是为空字符保留的）应用程序名称1001也是字符串值应用程序名的最大长度为 31 个字节（第 32 个字节是为空字符保留的）注意不要将 1001 组添加到扩展数据中，因为 AutoCAD 假定它是新应用程序扩展数据组的开始控制字符串1002扩展数据控制字符串可以是“”或“”。这两个大括号使应用程序可以通过将数据细分为表来组织数据。左大括号开始一个列表，右大括号结束最近的列表。列表可以嵌套。读取特定应用程序的扩展数据时，AutoCAD 会进行检查以确保大括号是成对的图层名1003与扩展数据关联的图层名二进制数据1004二进制数据组织成可变长度的数据块。每个数据块的最大长度为 127 个字节。在 ASCII 格式的 DXF 文件中，二进制数据以十六进制数字字符串的形式表示，每个二进制字节由两个数字字符表示数据库句柄1005图形数据库中的图元句柄注意使用 INSERT、INSERT *、XREF BIND、XBIND 或 PARTIAL OPEN 将带有句柄和扩展数据句柄的图形输入到另一个图形时，扩展数据句柄将使用其相应图元句柄的转换方式进行转换，从而使两者之间的绑定保持不变。EXPLODE 块操作或任何其他 AutoCAD 操作也是如此。如果 AUDIT 检测出扩展数据句柄与图形文件中的图元句柄不匹配，将认为存在错误。AUDIT 修复图元时，将句柄设置为 0。3 个实数1010, 1020, 1030 按 X、Y、Z 次序排列的三个实数值。可将它们用作点或矢量记录。AutoCAD 永远不会改变它们的值世界空间位置1011, 1021, 1031与简单的三维点不同，世界空间坐标随扩展数据所属的父图元进行移动、缩放、旋转和镜像。对父图元使用 STRETCH 命令并且此点位于选择窗口中时，世界空间位置也会被拉伸。世界空间位移1012, 1022, 1032也是一个随着父图元进行缩放、旋转和镜像（而不是移动或拉伸）的三维点世界方向1013, 1023, 1033也是一个随着父图元旋转和镜像（而不是移动、缩放或拉伸）的三维点实数1040一个实数值距离1041一个随着父图元进行缩放的实数值比例因子1042也是一个随着父图元进行缩放的实数值。距离和缩放因子的差别由应用程序定义整数1070一个 16 位整数（有符号或无符号）长整数1071一个 32 位有符号（长）整数SetXData 方法设置与对象关联的扩展数据 (外部数据) 。参阅 | 示例语法 object.SetXData XDataType, XData Object所有图形对象 , AttributeReference, Block, Dictionary, DimStyle, Group, Layer, Linetype, PlotConfigurations, RegisteredApplication, TextStyle, UCS, View, Viewport; XRecord使用该方法的对象。 XDataTypeVariant变体 (短整数数组); 仅用于输入 XData变体数组; 仅用于输入 说明 扩展数据是由 ObjectARX 或 AutoLISP 编写的程序创建的特定实例数据的实例。该数据可添加到任何对象中。它跟随在对象定义数据的后面，并按一定的顺序存入文档中。（AutoCAD 保留此信息，但不使用。）GetXData 方法获取与对象关联的扩展数据(XData) 。参阅 | 示例语法 object.GetXData AppName, XDataType, XDataValue Object所有图形对象 , AttributeReference, Block, Dictionary, DimStyle, Group, Layer, Linetype, PlotConfigurations, RegisteredApplication, TextStyle, UCS, View, Viewport; XRecord使用该方法的对象。 AppNameString字符串; 仅用于输入使用NULL字符串可返回所有与对象关联的数据，而不考虑创建它的应用程序。如提供一个应用程序名则只返回由指定应用程序创建的数据。 XDataTypeVariant变体 (短整数数组); 仅用于输出 XDataValueVariant变体 (变体数组); 仅用于输出 说明 扩展数据是由 ObjectARX 或 AutoLISP 编写的程序创建的特定实例数据的实例。该数据可添加到任何对象中。它跟随在对象定义数据的后面，并按一定的顺序存入文档中。（AutoCAD 保留此信息，但不使用。）我想更改一个属性块中包含的所有实体对象的图层，使之与该块本身的图层一致(setq ss (ssget “X” (0 . “insert”) i0 -1)(while (setq ent (ssname ss (setq i0 (1+ i0)(setq la (cdr (assoc 8 (entget ent)color1 (cdr (assoc 62 (entget ent)exit0 nil)(while (and (not exit0)(setq ent (entnext ent)(setq entg (entget ent)(setq entg (subst (cons 8 la) (assoc 8 entg) entg)entg (subst (cons 62 color1) (assoc 62 entg) entg)(entmod entg)(setq exit0 (assoc -2 entg)但是结果并满意，属性块中最后一个实体对象无法更改。一个属性块的数据表如下：(NO.1)(-1 . ) (0 . “INSERT”) (330 . )(5 . “15E”) (100 . “AcDbEntity”) (67 . 0) (410 . “Model”) (8 . “植被层”) (6 .“18) (48 . 0.5) (100 . “AcDbBlockReference”) (66 . 1) (2 . “G1012) (10339.028 414.377 -0.0440077) (41 . 0.5) (42 . 0.5) (43 . 0.5) (50 . 0.875457)(70 . 0) (71 . 0) (44 . 0.0) (45 . 0.0) (210 0.0 0.0 1.0)用(entnext)依次提取上述块所包含的属性表。第一次(entnext)：(NO.2)(-1 . ) (0 . “ATTRIB”) (330 . ) (5 .“15F”) (100 . “AcDbEntity”) (67 . 0) (410 . “Model”) (8 . “0) (100 .“AcDbText”) (10 339.738 414.566 -0.0440077) (40 . 0.849) (1 . “93720) (50 .0.875457) (41 . 1.0) (51 . 0.0) (7 . “Standard”) (71 . 0) (72 . 0) (11 339.412414.838 -0.0440077) (210 0.0 0.0 1.0) (100 . “AcDbAttribute”) (2 . “CODE”) (70. 1) (73 . 0) (74 . 2)第二次(entnext)：(NO.3)(-1 . ) (0 . “SEQEND”) (330 . ) (5 .“160) (100 . “AcDbEntity”) (67 . 0) (410 . “Model”) (8 . “植被层”) (6 . “18)(48 . 0.5) (-2 . )第二次(entnext)：nil用(setq entg (subst (cons 8 la) (assoc 8 entg) entg)entg (subst (cons 62 color1) (assoc 62 entg) entg)(entmod entg)对NO.1-NO.3的对象进行修改特定的值，NO.1和NO.2的对象修改成功，但是NO.3的对象修改不成功。期待得到帮助的问题有：1.我的做法在NO.3处为什么会不成功？2.我该如何正确实现上述的修改操作？3.我想删除属性块中属性数据即上述的NO.2和NO.3的对象又该如何实现？我想更改线实体对象的图层，使之与该线本身的扩展属性一致如何将多个一样的word表格文件读到一个excel表格文件中,每个word文件在excel中为一行WORD中的简历有规律的话，或者有标记的话，是比较容易解决的。 示例：Sub test()Dim mFolder As StringDim i As Integer mFolder = f:111 修改这个地方就是存放文件的地方 A1 = 路径: B1 = 文件名 With Application.FileSearch .NewSearch .LookIn = mFolder .SearchSubFolders = True .Filename = *.* If .Execute() 0 Then For i = 1 To .FoundFiles.Count If .FoundFiles(i) ThisWorkbook.FullName Then Call Write_In(.FoundFiles(i) End If Next i Else MsgBox 文件夹 & mFolder & 中没有所需的文件 End If End WithEnd SubSub Write_In(strFile As String)Dim intStart As Integer, intEnd As Integer, iRow As LongDim strFileName As String intStart = InStrRev(strFile, ) intEnd = InStrRev(strFile, .) strFileName = Mid(strFile, intStart + 1, intEnd - intStart - 1) Application.ScreenUpdating = False With Sheet1 iRow = .a65536.End(xlUp).Row + 1 .Cells(iRow, 1) = strFile .Cells(iRow, 2) = strFileName End With Application.ScreenUpdating = TrueEnd Sub结果只是把各个word文件的文件名导入到excel表格里了试一下以下代码, 祝你成功!Dim fcc,fo,fsoSet fso = CreateObject(Scripting.filesystemobject)Set fo = fso.getfolder(C:AA)文件夹i=1For Each fc In fo.subFolders For Each fcc In fc.Files If InStr(1, fcc.Name, .doc, 1) Then Range(A & i) = fcc.Name i = i + 1 End If NextNext如何将多个同样的word表格文件指定内容读到一个excel表格文件中,word文件在excel为一行word表格格式相同，文件夹下的word文件个数不固定（量较大)，现需提取其中数据到excel中,引用Microsoft Word 11.0 Object LibrarySub yy() dpath = ThisWorkbook.Path & 岗位意向表 Dim wdapp As Word.Application Dim wddocument As Word.Document Set wdapp = New Word.Application wdapp.Visible = True Application.ScreenUpdating = False Filename = Dir(dpath & *.doc) Do While Filename Set wddocument = wdapp.Documents.Open(dpath & & Filename) Set wdTb = wddocument.Tables(1) If a3 Then r = a65536.End(xlUp).Row + 1 Else r = 3 With wdTb If r = 3 Then Range(a3) = 1 Else Range(a & r) = Range(a & r - 1) + 1 Range(b & r) = Replace(.Cell(1, 2).Range.Text, vbCr & , ) Range(c & r) = Replace(.Cell(1, 4).Range.Text, vbCr & , ) Range(d & r) = Replace(.Cell(1, 6).Range.Text, vbCr & , ) Range(e & r) = Replace(.Cell(2, 2).Range.Text, vbCr & , ) Range(f & r) = Replace(.Cell(2, 4).Range.Text, vbCr & , ) Range(g & r) = Replace(.Cell(2, 6).Range.Text, vbCr & , ) Range(h & r) = Replace(.Cell(3, 2).Range.Text, vbCr & , ) Range(i & r) = Replace(.Cell(3, 4).Range.Text, vbCr & , ) Range(j & r) = Replace(.Cell(4, 2).Range.Text, vbCr & , ) Range(k & r) = Replace(.Cell(4, 4).Range.Text, vbCr & , ) arr = Split(Replace(.Cell(5, 3).Range.Text, vbCr & , ), ；) Range(l & r) = Trim(Replace(Replace(arr(0), 第一意向：, ), ，, ) Range(m & r) = Trim(Replace(Replace(arr(1), 第二意向：, ), ，, ) Range(n & r) = Trim(Replace(Replace(arr(2), 第三意向：, ), ，, ) If InStr(arr(3), ) And InStr(arr(3), ) InStr(.Cell(8, 2).Range.Text, 否) Then Range(x & r) = 否 Else Range(w & r) = 是 End If End With Set wdTb = Nothing wddocument.Close Filename = Dir() Loop Set wddocument = Nothing wdapp.Quit Set wdapp = Nothing Application.ScreenUpdating = TrueEnd Sub普通浏览复制代码保存代码打印代码Subyy()dpath=ThisWorkbook.Path&支付申请单DimwdappAsWord.ApplicationDimwddocumentAsWord.DocumentSetwdapp=NewWord.Applicationwdapp.Visible=TrueApplication.ScreenUpdating=Falser=a600.End(xlUp).RowFori=2Tora=a&Cells(i,1).TextNextFilename=Dir(dpath&*.doc)DoWhileFilenameIfInStr(a,Filename)=0Thenr=r+1Setwddocument=wdapp.Documents.Open(dpath&Filename)SetwdTb=wddocument.Tables(1)WithwdTbRange(a&r)=Filenamearr1=Split(Replace(.Cell(1,2).Range.Text,vbCr&,)Range(b&r)=Trim(Replace(Replace(arr1(0),项目号/成本中心：,),，,)arr2=Split(Replace(.Cell(1,1).Range.Text,vbCr&,)Range(c&r)=Trim(Replace(Replace(arr2(0),项目名称：,),，,)arr3=Split(Replace(.Cell(4,1).Range.Text,vbCr&,)Range(d&r)=Trim(Replace(Replace(arr3(27),交货/完工付款,),，,)arr4=Split(Replace(.Cell(2,1).Range.Text,vbCr&,)Range(e&r)=Trim(Replace(Replace(arr4(0),收款单位/人：,),，,)arr5=Split(Replace(.Cell(11,3).Range.Text,vbCr&,)Range(f&r)=Trim(Replace(Replace(arr5(0),小写：￥,),，,)EndWithSetwdTb=Nothingwddocument.CloseEndIfFilename=Dir()LoopSetwddocument=Nothingwdapp.QuitSetwdapp=NothingApplication.ScreenUpdating=TrueEndSub-在excel中用宏Sub test()Dim i%, ar(1 To 60000, 1 To 20), ttt$, brr()Dim wordApp As Object, myword As Object, t As ObjectApplication.ScreenUpdating = FalseSet wordApp = CreateObject(Word.Application)Set myword = wordApp.Documents.Open(ThisWorkbook.Path & 全省项目排版1014.doc)wordApp.Visible = 0On Error Resume NextReDim brr(1 To myword.Tables.Count)For Each t In myword.Tables If t.Rows.Count 19 Then j = 0 ttt = t.Cell(j + 1, 1).Range.Text Do While InStr(ttt, 名称) = 0 j = j + 1 ttt = t.Cell(j + 1, 1).Range.Text If j = 5 Then Exit Do Loop If j 18 Then For j = 1 To t.Rows.Count Step 18 i = i + 1 ar(i, 1) = t.Cell(1 + 3, 2).Range.Text ar(i, 2) = t.Cell(2 + 3, 2).Range.Text ar(i, 3) = t.Cell(3 + 3, 3).Range.Text ar(i, 4) = t.Cell(3 + 3, 5).Range.Text ar(i, 5) = t.Cell(4 + 3, 3).Range.Text ar(i, 6) = t.Cell(5 + 3, 3).Range.Text ar(i, 7) = t.Cell(6 + 3, 3).Range.Text ar(i, 8) = t.Cell(6 + 3, 5).Range.Text ar(i, 9) = t.Cell(7 + 3, 3).Range.Text ar(i, 10) = t.Cell(8 + 3, 3).Range.Text ar(i, 11) = t.Cell(9 + 3, 3).Range.Text ar(i, 12) = t.Cell(9 + 3, 5).Range.Text ar(i, 13) = t.Cell(10 + 3, 3).Range.Text ar(i, 14) = t.Cell(11 + 3, 3).Range.Text ar(i, 15) = t.Cell(12 + 3, 2).Range.Text ar(i, 16) = t.Cell(13 + 3, 2).Range.Text ar(i, 17) = t.Cell(14 + 3, 3).Range.Text ar(i, 18) = t.Cell(14 + 3, 5).Range.Text ar(i, 19) = t.Cell(15 + 3, 3).Range.Text ar(i, 20) = t.Cell(15 + 3, 5).Range.Text Next