CAD2006怎样用VBA读取EXCE
CAD中VBA与EXCEL
VBA调用EXCEL信息
Sub ExcelRead()
Dim ExcelApp As New Excel。Application
ExcelApp。 Workbooks。Open "d:\book1。xls", , ReadOnly
Dim pt1(0 To 2) As Double, pt2(0 To 2) As Double
Dim Rad As Double
Dim i As Integer
i = 2
With ExcelApp。 ActiveWorkbook。Worksheets("sheet1")
Do
Select Case 。Range(...全部
CAD中VBA与EXCEL
VBA调用EXCEL信息
Sub ExcelRead()
Dim ExcelApp As New Excel。Application
ExcelApp。
Workbooks。Open "d:\book1。xls", , ReadOnly
Dim pt1(0 To 2) As Double, pt2(0 To 2) As Double
Dim Rad As Double
Dim i As Integer
i = 2
With ExcelApp。
ActiveWorkbook。Worksheets("sheet1")
Do
Select Case 。Range("A" & i)
Case "直线":
pt1(0) = 。Range("B" & i)
pt1(1) = 。
Range("C" & i)
pt1(2) = 0
pt2(0) = 。Range("D" & i)
pt2(1) = 。Range("E" & i)
pt2(0) = 0
ThisDrawing。
ModelSpace。AddLine pt1, pt2
Case "圆":
pt1(0) = 。Range("B" & i)
pt1(1) = 。Range("C" & i)
pt1(2) = 0
Rad = 。
Range("D" & i)
ThisDrawing。ModelSpace。AddCircle pt1, Rad
Case Else:
Exit Do
End Select
i = i + 1
Loop
End With
ExcelApp。
Workbooks。Close
ExcelApp。Quit
ThisDrawing。Application。Update
End Sub
运行这段代码需要加载EXCEL ActiveX对象模型。
在ACAD VBA编辑器中选择“工具”菜单->“引用”，选择合适的Microsoft Excel Object Library。
这段代码第2行先声明并新建一个EXCEL。Application对象。
新建EXCEL对象，也可以调用VB库函数CreateObject()：
Dim ExcelApp As Excel。Application
Set ExcelApp = CreateObject("Microsoft Excel")
程序第3行调用EXCEL的Application对象的Workbooks集合的Open方法，以只读方式打开指定的EXCEL文档。
第4-7行声明一些变量。i 用于表明要操作的EXCEL单元格的行号，通常EXCEL文档第1 行是表头说明，我们从第2行开始读数据。
程序第8行告诉编译程序以下对当前活动的EXCEL文档的Sheet1工作表进行操作。
程序第9行到第29行循环读取EXCEL文档的Sheet1工作表中对于自动绘图有用的单元格内容并在ACAD模型空间中绘图。
循环内部用Select Case语句根据EXCEL文档的第1 列内容选择不同的绘图方法。
为了说明问题，程序仅对直线和圆两种ACAD图元对象进行操作并将其它对象出现作为循环退出条件。实际编程时可以对更多ACAD图元对象进行操作。
程序第31、32行释放不再使用的EXCEL对象，第33行刷新ACAD图形以显示自动绘制的图形。
下面的代码由用户在ACAD图形中选择对象并将对象部分属性写入EXCEL文档。
Sub WriteExcel()
Dim ExcelApp As New Excel。Application
Dim ExcelWkbk As Excel。
Workbook
Set ExcelWkbk = ExcelApp。Workbooks。Add
Dim sel As AcadSelectionSet
Dim i As Integer
i = 2
On Error Resume Next
Set sel = ThisDrawing。
SelectionSets。Add("ssel")
If Err Then
Err。Clear
Set sel = ThisDrawing。SelectionSets。Item("ssel")
End If
On Error GoTo 0
sel。
SelectOnScreen
Dim Ent As AcadEntity
Dim pt1 As Variant, pt2 As Variant
MsgBox ExcelWkbk。Name
With ExcelWkbk。
Worksheets("sheet1")
For Each Ent In sel
Select Case UCase(Ent。ObjectName)
Case "ACDBLINE":
。Range("A" & i) = "直线"
pt1 = Ent。
StartPoint
pt2 = Ent。EndPoint
。Range("B" & i) = pt1(0)
。Range("c" & i) = pt1(1)
。Range("D" & i) = pt2(0)
。
Range("E" & i) = pt2(1)
i = i + 1
Case "ACDBCIRCLE":
。Range("A" & i) = "圆"
pt1 = Ent。Center
。Range("B" & i) = pt1(0)
。
Range("C" & i) = pt1(1)
。Range("D" & i) = Ent。Radius
i = i + 1
Case Else:
End Select
Next Ent
End With
ExcelApp。
ActiveWorkbook。SaveAs "d:\book1。xls"
ExcelApp。Workbooks。Close
ExcelApp。Quit
sel。Delete
End Sub。收起
