[文章]利用VBA 建立AutoCad2000与Excel通信

mccad

一、 Excel 的ActiveX对象模型：

1． WorkBooks集合对象

一个WorkBook对象实际上就是一个Excel文件，Excel应用程序可以同时打开或创建多个文件，它们被保存在WorkBooks集合对象中，可以通过索引号或名称访问集合中的任何一个工作簿，如下语句所示：

'该语句激活WorkBooks集合中的第一个工作簿，使其成为当前工作簿

WorkBooks(1).Activate

'该语句激活WorkBooks集合中的Mybook.xls工作簿，使其成为当前工作簿

WorkBooks("Mybook.xls"). Activate

2.Worksheets对象

每个工作簿对象上可以有多个工作表WorkSheet。在默认情况下, Excel的当前工作簿上有名为Sheet1,Sheet2,Sheet3三个工作表，并且Sheet1为当前工作表。如果想使Sheet2成为当前工作表，则可使用下列语句:

ExcelApp.Worksheets("Sheet2").Activate

3.Range对象

该对象用来指定工作表上的区域。将单元格A1的值赋给单元格A5的语句说明如下：

Worksheets("sheet1").range("A5").value=worksheets("sheet1").range("A1").value]

上述语句将Sheet1工作表上的A1（第1行第1列）单元格中的值，赋给Sheet1工作表上的A5（第5行第1列）单元格。

再看下面的语句：

‘将单元格A1和D26构成的区域选中

worksheets("sheet1").range("a1:d26").select

这条语句中的Select方法所产生的效果，与我们平时用鼠标在屏幕上将A1：D26区域上的单元格进行刷黑选择是一样的。Rnge对象的另一个重要方法是Sort，该方法用来对工作表上选定的区域进行排序，它带有许多参数，下面我们看一下该方法的语法格式：

Expression.sort(Key1,Order1,Key2,Type,Order2,Key3,Order3,Header,OrderCustom,_

MatchCase,Orientation,SortMethod,IgnoreControlCharacters,IgnoreDiacritics,IgnoreKashide)

其中：

expression：必选参数。该表达式返回Rang对象选定的区域。

Key1：Variant类型，可选参数。第一个排序字段，主要是Rang对象返回的区域或由工作表对象的Columns属性指定的列。

Order1：Variant类型，可选参数。可为下例xlSortOrder内置常量之一, xlAscending或xlDescending。用xlAscending表示以升序排列Key1。用xlDescending表示以降序排列Key1。默认值为升序xlAscending。

Key2：Variant类型，可选参数。第二个排序字段，主要是Rang对象返回的区域或由工作表对象Columns的属性指定的列。如果省略本参数，则没有第二个排序字段。对数据透视表排序时不用。

Type：Varoant类型，可选参数。指定参与排序的要素。可为下列xlSortType常量之一：xlSortValues或xlSortLabels。仅用于对数据透视表的排序。

Order2：Variant类型。可选参数。可为下列XlSortOrder常量之一：xlDescending或xlDescending。用xlAscending表示以升序排列Key2。用xldescending表示以降序排列Key2。默认值为xlAscending。对数据透视表排序时不用。

Key3：Variant类型，可选参数。第三个排序字段，主要是Rang对象返回的区域或由工作表对象的Columns属性指定的列。如果省略本参数，则没有第三个排序字段。对数据透视表排序时不用。

Order3：Variant类型，可选参数。可为下列xlSortOrder常量之一：xlAscending或xlDescending。用xlAscending表示以升序排列Key3，用xlDescending表示以降序排列Key3。默认值为xlAscending。对数据透视有排序时不用。

Heard：Variant类型，可选取参数。指定第一行时否包含标题。可为下列xlYesNoGuess常量之一：xlYes、xlNo或xlGuess。如果首行包含标题（不对首行排序），就指定xlYes。如果首行不包含标题（对整个区域排序），就指定xlNo。若指定为xlGuess，将由Microsoft Excel判断是否有标题及标题位于何处。默认值为xlNo。对数据透视表排序时不用。

OrderCustom：Variant类型，可选参数。以从1开始的整数指定在自定义排序顺序列表中的索引号。如果省略本参数，就使用不着1（“常规：“）。

MatchCase：Variant类型，可选。若指定为True，则进行区分大小写的排序；若指定为False，则排序时不区分大小写。对数据透视表排序时不用。

Orientation：Variant类型，可选参数。如果指定为xlTopToBottom，排序将从上到下（按行）进行。如果指定为xlLeftToRight，排序将从左到右（按列）进行。

SortMethod：Variant类型，可选参数。排序方式。可为下列xlSortMethod常量之一：xlSyllabary（按发音排序）或xlCodePage（按代码页排序）。默认值为xlSyllabary。

IgnoreControlCharacters：Variant类型，可选参数。不用于美国英语版的Microsoft Excel中。

IgnoreDiacritics:Variant类型，可选参数，不用于美国英语版的Microsoft Excel中。

IgnoreKashida：Variant类型，可选参数。不用于美国英语版的Microsoft Excel中。

下面语句是有关使用Sort方法的2个示例。

示例1：对工作表“Sheet1”上的单元格区域A1：C20进行排序，用单元格A1作为第一关键字，用单元格B1作为第二关键盘字。排序是按行以升序（默认）进行的，没有标题。

Worksheets("sheet1").range(A1:c20").sort,key1:=worksheets("sheet1").range("A1"),key2:=_

Worksheets("sheet1").range("B1")

示例2、对工作表“Sheet1“上包含单元格“A1”的当前区进行排序，按第一列中的数据进行排序，并且自动判断是否存在标题行。Sort方法将自动判断当前区。

Worksheets("Sheet1").Range("A1").Sort,Key1:=Workssheets("Sheet1").Columns("A"),_

Header:=xlGuess

4．Cells属性

工作表对象中的Cells属性，在单元格的选择方面可以达到与Rang相同的效果它是以行Row和列Gol作为参数的，如下语句所示：

‘将单元格A1的值赋给单元格A5

Worksheets("Sheet1").Cells(5,1).Value=Worksheets("Sheet1").Cells(1,1).Value

上面语句即将第1行第1列（A1）单元格内的值，赋给第5行第1列（A5）单元格。Cells属性的优点是，对于行和列的选择可以采用变量，如下语句所示：

Worksheets("Sheet1").Activate

For theYear=1 to 5

Cells(1,theYear+1).Value=1990+theYear

Next theYear

上述语句将在当前工作表的第一行的第2、3、4、5、6列，分别添上1992、1993、1994、1995和1996的值。注意，由于第1条语句已将Sheet1设为当前工作簿，所以Cells属性可以不必显示指定工作表。

5．GetObject和CreateObject函数

二、在AutoCAD创建Excel应用程序

1． 打开AutoCad的VBA编辑器

2． 选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项

3． 单击“确定”按钮

4． 接下来使用下列代码就可创建完整的应用程序对象实例：

Dim ExcelApp as Excel.Application

'激活要与之通信的Excel应用程序

On Error Resume Next

Set ExcelApp=GetObject( , "Excel.Application")

If Err<>0 Then

Set ExcelApp=CreateObject("Excel.Applicationn")

End If

注意GetObject和CreateObject函数的区别。当Excel程序已经在运行时，前者可以马上创建Excel应用程序的实例，这样不会出现2个Excel应用程序对象实例，这将有效地节省系统资源的开销。如果当前Excel没有运行，GetObject函数将出错，紧接着Err将捕获错误，并运行CreateObject函数创建一个Excel应用程序实例，所以在具体使用时，这2个函数最好都不要省略。

三、将明细表做成一个Excel报表

1、 运行AutoCad2000程序

2、 打开AutoCad2000主运行文件夹下的“\Sample\Actives\ExtAtt\attrib.dwg”文件。该文件的右上角有一明细表，该明细表的每一行都是一个插入的块引用，显示的文字就是块的属性文本或标签（主要用于标题）

3、 创建成下面的过程及代码，并运行之

Sub  BlkAttr_Extract()
    Dim  Excel  As  Excel.Application
    Dim  ExcelSheet  As  Object
    Dim  ExcelWorkbook  As  Object
    '创建Excel应用程序实例
    On  Error  Resume  Next
    Set  Excel = GetObject(, "Excel.Application")
    If  Err <> 0  Then
        Set  Excel = CreateObject("Excel.Application")
    End  If
    '创建一个新工作簿
    Set  ExcelWorkbook = Excel.Workbooks.Add
    '确保Sheet1工作表为当前工作表
    Set  ExcelSheet = Excel.ActiveSheet
    '将新创建的工作簿保存为Excel文件
    ExcelWorkbook.SaveAs "属性表.xls"
    '令Excel应用程序可见
    Dim  RowNum  As  Integer
    Dim  Header  As  Boolean
    Dim  blkElem  As  AcadEntity
    Dim  Array1  As  Variant
    Dim  Count  As  Integer
    RowNum = 1
    Header = False
    '遍历模型空间，查找明细表的每个块引用表行
    For bEach  blkElem  In  ThisDrawing.ModelSpace
        With  blkElem
            '当一个块引用表行被找到后，检查它是否有属性
            If  StrComp(.EntityName, "AcDbBlockReference", 1) = 0  Then
                '如果有属性
                If . HasAttributes  Then
                    '提取块引用中的属性
                    Array1 = .GetAttributes
                    '这一轮循环用来查找标题，如果有填在第1行
                    For  Count = LBound(Array1)  To  UBound(Array1)
                        '如果还没有标题
                        If  Header = False  Then
                            '作为标题的明细行其块属性常设为Constant类型
                            If  Array1(Count).Constant  Then
                                ExcelSheet.Cells(RowNum, Count + 1).Value _
                                                = Array1(Count).TextString
                            End  If
                        End  If
                    Next  Count
                    '从第2行开始，填写其它的明细表行内容
                    RowNum = RowNum + 1
                    For  Count = LBound(Array1)  To  UBound(Array1)
                        ExcelSheet.Cells(RowNum, Count + 1).Value _
                                    = Array1(Count).TextString
                    Next  Count
                    Header = True
                End  If
            End  If
        End  With
    Next  blkElem
    '对填入当前表单的内容，按第1列进行排序,
    '范围是从A1单元格开始的整个工作表
    Excel.Worksheets("Sheet1").Range("A1").Sort _
        key1:=Excel.Worksheets("Sheet1").Columns("A"), _
        Header:=xlGuess
    '显示Excel工作表中的结果
    Excel.Visible = True
    '该语句用来等待查看显示结果
    MsgBox "按‘确定’键将关闭Excel的运行！"
    '保存传过来的数据
    ExcelWorkbook.Save
    '关闭Excel应用程序
    Excel.Application.Quit
    '删除Excel应用程序实例
    Set Excel = Nothing
End Sub
运行上述代码后，将在“\My Documents”文件夹下生成一“属性表.xls”文件。由于在attrib.dwg文件中，其明细表中第一行标题的文字不是块属性，而是文本对象，所以在“属性表.xls”文件中的第1行为空。不过在Excel界面下要编写一行标题是非常容易的。在多数情况下，作为标题的明细表行是不希望随便改动的，所以标题行地块属性往往被设成固定不变(Constamt)类型。在ActiveX中的Attribute和AttributeRef对象，都有一个Constsnt属性，用来判断某个块或块引用中的属性值类型，它是一个布尔类型的值，其值若为True，表示块属性值为Constsnt类型。

本代码在Windows95\AutoCadR2000上运行通过。

通信地址：湖南衡东城关北街69号
湖南机油泵股份有限公司计算机中心
邮编：421400

happystory

牛人，拿红包了哈哈哈哈哈

宇涵他爹/

学习学习！最近刚好要编个小程序能用到！谢谢了

blackfire

我也正需要这方面知识，谢谢楼主

zeiss

有没有cad块属性和excel链接的程序。

燕归来

刚学的，相传一个数据给cad为什么不行，求助啊！坐标穿不过去
Sub cc100()
Dim cc(0 To 2) As Double
Dim dd(0 To 2) As Double
Dim ExcelApp As Excel.Application
Dim ExcelSheet As Object
Dim ExcelWorkbook As Object

'激活要与之通信的Excel应用程序

On Error Resume Next

Set ExcelApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set ExcelApp = CreateObject("Excel.Application") '激活excel程序
End If
Set ExcelWorkbook = Excel.Workbooks.Add
    '确保Sheet1工作表为当前工作表
    Set ExcelSheet = Excel.ActiveSheet
ExcelApp.Workbooks.Open ("F:\vb\123.xls") '打开工作薄
Set ExcelSheet = ExcelApp.ActiveWorkbook.Sheets("sheet1") '当前工作表为sheet1



cc(0) = 1000
cc(1) = 1000
cc(2) = 0
dd(0) = 500
dd(1) = Worksheets("sheet1").Range("A1").Value
dd(2) = 0

For i = 1 To 100 Step 10
Call ThisDrawing.ModelSpace.AddCircle(cc, i * 10)
Call ThisDrawing.ModelSpace.AddCircle(dd, i * 10)
Next i

ExcelApp.Quit '退出excel程序
Set ExcelApp = Nothing '释放变量
Set ExcelSheet = Nothing


End Sub

Silence...

学习一下，谢谢了

tianshan888

燕归来 发表于 2012-7-14 10:06
刚学的，相传一个数据给cad为什么不行，求助啊！坐标穿不过去
Sub cc100()
Dim cc(0 To 2) As Double

数据在  ("F:\vb\123.xls") 里的话 不必 Set ExcelWorkbook = Excel.Workbooks.Add 这条语句是新建表并赋给excelworkbook
dd(1) = Worksheets("sheet1").Range("A1").Value 语句没有明确限定工作簿

改下
Set ExcelApp =GetObject(, "Excel.Application")
If Err <> 0 Then
Set ExcelApp = CreateObject("Excel.Application") '激活excel程序
End If

set ExcelWorkbook = ExcelApp.Workbooks.Open ("F:\vb\123.xls") '工作簿要确保关闭 做的好点的话要有检验
Set ExcelSheet =ExcelWorkbook.Sheets("sheet1") ' 设定工作表
.......
dd(1) = Excelsheet.Range("A1").Value
......

假设要提取 某个工作簿 某工作表 某行 某列的 话
dim excelapp Excel.Application , 工作簿 as object
1. 建立excel 对象  参见上面   Set ExcelApp
2.打开工作簿并赋给工作簿对象  set 工作簿 = excelapp.workbooks(工作簿路径).open
   工作簿已打开的话  set 工作簿 = excelapp.workbooks(工作簿名) 工作簿名不含路径但要有扩展名
3.提取某个数据  aaa = 工作簿.worksheets(工作表名).cells(行，列）
4.提取已打开的工作簿数据的话 也可以 aaa = ExcelApp.workbooks(工作簿名).worksheets(工作表名).cells(行,列)