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