利用VBA 建立AutoCad2000與Excel通信

一、 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類型,可選參數?？蔀橄吕齲lSortOrder內置常量之一, xlAscending或xlDescending。用xlAscending表示以升序排列Key1.用xlDescending表示以降序排列Key1.默認值為升序xlAscending。
Key2：Variant類型，可選參數。第二個排序字段，主要是Rang對象返回的區域或由工作表對象Columns的屬性指定的列。如果省略本參數，則沒有第二個排序字段。對數據透視表排序時不用。
Type：Varoant類型，可選參數。指定參與排序的要素?？蔀橄铝衳lSortType常量之一：xlSortValues或xlSortLabels。僅用于對數據透視表的排序。
Order2：Variant類型?？蛇x參數?？蔀橄铝蠿lSortOrder常量之一：xlDescending或xlDescending。用xlAscending表示以升序排列Key2。用xldescending表示以降序排列Key2。默認值為xlAscending。對數據透視表排序時不用。
Key3：Variant類型，可選參數。第三個排序字段，主要是Rang對象返回的區域或由工作表對象的Columns屬性指定的列。如果省略本參數，則沒有第三個排序字段。對數據透視表排序時不用。
Order3：Variant類型，可選參數?？蔀橄铝衳lSortOrder常量之一：xlAscending或xlDescending。用xlAscending表示以升序排列Key3，用xlDescending表示以降序排列Key3。默認值為xlAscending。對數據透視有排序時不用。
Heard：Variant類型，可選取參數。指定第一行時否包含標題?？蔀橄铝衳lYesNoGuess常量之一：xlYes、xlNo或xlGuess。如果首行包含標題（不對首行排序），就指定xlYes。如果首行不包含標題（對整個區域排序），就指定xlNo。若指定為xlGuess，將由Microsoft Excel判斷是否有標題及標題位于何處。默認值為xlNo。對數據透視表排序時不用。
OrderCustom：Variant類型，可選參數。以從1開始的整數指定在自定義排序順序列表中的索引號。如果省略本參數，就使用不著1（“常規：“）。
MatchCase：Variant類型，可選。若指定為True，則進行區分大小寫的排序；若指定為False，則排序時不區分大小寫。對數據透視表排序時不用。
Orientation：Variant類型，可選參數。如果指定為xlTopToBottom，排序將從上到下（按行）進行。如果指定為xlLeftToRight，排序將從左到右（按列）進行。
SortMethod：Variant類型，可選參數。排序方式?？蔀橄铝衳lSortMethod常量之一：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上運行通過。

原文轉自：http://www.anti-gravitydesign.com