根据块名附属性.doc

;;;;根据块名附属性
(defun c:test()
(regapp "south")
(setq sscnt 0)
  (prompt "\n请选择要赋属性的块:")
  (if (setq ins_all (ssget (list '(0 . "insert"))))
   (repeat (sslength ins_all)
    (setq ss_ins_name (ssname ins_all sscnt))
    (setq ss_ins_att (entget ss_ins_name (list "*")))
    (setq ins_name (cdr (assoc '2 ss_ins_att)))
    (setq ins_code (substr ins_name 1 (vl-string-position (ascii "_") ins_name)))
    (setq ins_code_lst (list '-3 (list "south" (cons 1000 ins_code))))
    (setq ss_ins_att (reverse (append (list ins_code_lst) (reverse ss_ins_att))))
    (entmod ss_ins_att)
    (setq sscnt (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
5
F11
100
AcDbEntity
8
TOP
100
AcDbBlockReference
2
BLOCK_A
10
0.0
20
0.0
30
0.0
扩展图元定义数据：
1001
AME_SOL
1002
{
1070
0
1071
1.95059E+06
1070
519
1010
2.54717
1020
2.122642
1030
2.049201
1005
ECD
1005
EE9
1005
0
1040
0.0
1040
1.0
1000
MILD_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
使用该方法的对象。
XDataType
Variant[变体] (短整数数组); 仅用于输入
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
使用该方法的对象。
AppName
String[字符串]; 仅用于输入
使用NULL字符串可返回所有与对象关联的数据，而不考虑创建它的应用程序。如提供一个应用程序名则只返回由指定应用程序创建的数据。
XDataType
Variant[变体] (短整数数组); 仅用于输出
XDataValue
Variant[变体] (变体数组); 仅用于输出
说明
扩展数据是由 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″) (10
339.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.412
414.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 String
Dim 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 With
End Sub
Sub Write_In(strFile As String)
Dim intStart As Integer, intEnd As Integer, iRow As Long
Dim 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 = True
End Sub
结果只是把各个word文件的文件名导入到excel表格里了

试一下以下代码, 祝你成功!
Dim fcc,fo,fso
Set fso = CreateObject("Scripting.filesystemobject")
Set fo = fso.getfolder("C:\AA") '文件夹
i=1
For 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
Next
Next

如何将多个同样的word表格文件指定内容读到一个excel表格文件中,word文件在excel为一行

word表格格式相同，文件夹下的word文件个数不固定（量较大)，现需提取其中数据到excel中,

'引用Microsoft Word 11.0 Object Library

Sub 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(arr(3), "）") Then
                Range("o" & r) = "是"
            Else
                Range("p" & r) = "否"
            End If
            arr = Split(Replace(.Cell(6, 3).Range.Text, vbCr & "", ""), vbCr)
            Range("q" & r) = Trim(Replace(arr(0), "第一意向：", ""))
            Range("r" & r) = Trim(Replace(arr(1), "第二意向：", ""))
            Range("s" & r) = Trim(Replace(arr(2), "第三意向：", ""))
            arr = Split(Replace(.Cell(7, 3).Range.Text, vbCr & "", ""), vbCr)
            Range("t" & r) = Trim(Replace(arr(0), "第一意向：", ""))
            Range("u" & r) = Trim(Replace(arr(1), "第二意向：", ""))
            Range("v" & r) = Trim(Replace(arr(2), "第三意向：", ""))
            If InStr(.Cell(8, 2).Range.Text, "√") > 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 = True

End Sub

普通浏览复制代码保存代码打印代码
Sub 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
    r = [a600].End(xlUp).Row
    For i = 2 To r
        a = a & Cells(i, 1).Text
    Next
    Filename = Dir(dpath & "\*.doc")
    Do While Filename <> ""
        If InStr(a, Filename) = 0 Then
        r = r + 1
        Set wddocument = wdapp.Documents.Open(dpath & "\" & Filename)
        Set wdTb = wddocument.Tables(1)
        With wdTb
            Range("a" & r) = Filename
            arr1 = 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), "小写：￥", ""), "，", ""))
            End With
        Set wdTb = Nothing
        wddocument.Close
        End If
        Filename = Dir()
    Loop
    Set wddocument = Nothing
    wdapp.Quit
    Set wdapp = Nothing
    Application.ScreenUpdating = True

End Sub

-------------------------------------------------------------------------------------------------------------------
在excel中用宏
Sub test()
Dim i%, ar(1 To 60000, 1 To 20), ttt$, brr()
Dim wordApp As Object, myword As Object, t As Object
Application.ScreenUpdating = False
Set wordApp = CreateObject("Word.Application")
Set myword = wordApp.Documents.Open(ThisWorkbook.Path & "\全省项目排版1014.doc")
wordApp.Visible = 0
On Error Resume Next
ReDim 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 < 4 Then
        i = i + 1
            ar(i, 1) = t.Cell(1 + j, 2).Range.Text
            ar(i, 2) = t.Cell(2 + j, 2).Range.Text
            ar(i, 3) = t.Cell(3 + j, 3).Range.Text
            ar(i, 4) = t.Cell(3 + j, 5).Range.Text
            ar(i, 5) = t.Cell(4 + j, 3).Range.Text
            ar(i, 6) = t.Cell(5 + j, 3).Range.Text
            ar(i, 7) = t.Cell(6 + j, 3).Range.Text
            ar(i, 8) = t.Cell(6 + j, 5).Range.Text
            ar(i, 9) = t.Cell(7 + j, 3).Range.Text
            ar(i, 10) =