CAD实用编程---CAD--Excel 相互读取

Option Explicit
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
'将CAD的图形数据写入Excel
Public Sub CadToExcel()
Dim sset As AcadSelectionSet
Dim filterType(0) As Integer, filterData(0) As Variant
On Error Resume Next
Set sset = ThisDrawing.SelectionSets.Add("ToExcel")
If Err.Number <> 0 Then
Err.Clear
Set sset = ThisDrawing.SelectionSets.Item("ToExcel")
sset.Clear
End If
Set xlApp = CreateObject("Excel.Application")
If Err.Number <> 0 Then
Err.Clear
MsgBox "Excel软件没有正确打开。", vbOKOnly + 16, "提示："
Exit Sub
End If
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
filterType(0) = 0
filterData(0) = "line,circle,arc"
sset.SelectOnScreen filterType, filterData
If sset.Count = 0 Then Exit Sub
xlSheet.Range("A1") = "ObjectCount"&#39;写入标题
xlSheet.Range("B1") = sset.Count &#39;写入数据
Dim Obj As AcadEntity, i As Long, varCP As Variant
i = 2
For Each Obj In sset
Select Case Obj.ObjectName
Case "AcDbCircle"
varCP = Obj.Center
xlSheet.Range(("A" & i)) = "AcDbCircle"&#39;写入对象名
xlSheet.Range(("B" & i)) = Obj.Radius&#39;写入半径数据
xlSheet.Range(("C" & i)) = varCP(0) & "," & varCP(1) & "," & varCP(2)&#39;写入圆心坐标数据
Case "AcDbLine"
xlSheet.Range(("A" & i)) = "AcDbLine"&#39;写入对象名
varCP = Obj.StartPoint
xlSheet.Range(("B" & i)) = varCP(0) & "," & varCP(1) & "," & varCP(2)&#39;写入起点坐标数据
varCP = Obj.EndPoint
xlSheet.Range(("C" & i)) = varCP(0) & "," & varCP(1) & "," & varCP(2)&#39;写入终点坐标数据
Case "AcDbArc"
varCP = Obj.Center
xlSheet.Range(("A" & i)) = "AcDbArc"&#39;写入对象名
xlSheet.Range(("B" & i)) = Obj.Radius&#39;写入半径数据
xlSheet.Range(("C" & i)) = varCP(0) & "," & varCP(1) & "," & varCP(2)&#39;写入圆心坐标数据
xlSheet.Range(("D" & i)) = Obj.StartAngle&#39;写入起始角数据
xlSheet.Range(("E" & i)) = Obj.EndAngle &#39;写入终止角数据
End Select
i = i + 1
Next
xlApp.Visible = True
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
&#39;提取Excel数据升成CAD图形
Public Sub ExcelToCAD()
Dim ObjectCount As Long, strTemp() As String, i As Long, strFileName As String
On Error Resume Next
Set xlApp = CreateObject("Excel.Application")
If Err.Number <> 0 Then
Err.Clear
MsgBox "Excel软件没有正确打开。", vbOKOnly + 16, "提示："
Exit Sub
End If
strFileName = InputBox("输入保存CAD图形数据的Excel文件.", "打开文件：")
If Dir(strFileName) = "" Then
MsgBox "文件未找到。"
Exit Sub
End If
Set xlBook = xlApp.Workbooks.Open(strFileName)
Set xlSheet = xlBook.Worksheets(1)
Dim dblRadius As Double, dblCenter(2) As Double, j As Integer
ObjectCount = Val(xlSheet.Range("B1"))
For i = 2 To (ObjectCount + 1)
Select Case xlSheet.Range(("A" & i))
Case "AcDbCircle"
dblRadius = xlSheet.Range(("B" & i)) &#39;读入半径数据
strTemp = Split(xlSheet.Range(("C" & i)), ",")&#39;读入圆心坐标数据
For j = 0 To 2: dblCenter(j) = Val(strTemp(j)): Next j#p#分页标题#e#
ThisDrawing.ModelSpace.AddCircle dblCenter, dblRadius
Case "AcDbLine"
Dim dblStartP(2) As Double, dblEndP(2) As Double
strTemp = Split(xlSheet.Range(("B" & i)), ",") &#39;读入起点坐标数据
For j = 0 To 2: dblStartP(j) = Val(strTemp(j)): Next j
strTemp = (Split(xlSheet.Range(("C" & i)), ","))&#39;读入终点坐标数据
For j = 0 To 2: dblEndP(j) = Val(strTemp(j)): Next j
ThisDrawing.ModelSpace.AddLine dblStartP, dblEndP
Case "AcDbArc"
Dim dblStartAngle As Double, dblEndAngle As Double
dblRadius = Val(xlSheet.Range(("B" & i))) &#39;读入半径数据
strTemp = Split(xlSheet.Range(("C" & i)), ",")&#39;读入圆心坐标数据
For j = 0 To 2: dblCenter(j) = Val(strTemp(j)): Next j
dblStartAngle = Val(xlSheet.Range(("D" & i))) &#39;读入起始角数据
dblEndAngle = Val(xlSheet.Range(("E" & i))) &#39;读入终止角数据
ThisDrawing.ModelSpace.AddArc dblCenter, dblRadius, dblStartAngle, dblEndAngle
End Select
Next i
xlBook.Close
xlApp.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing

End Sub