Option Explicit
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
'將CAD的圖形數(shù)據(jù)寫入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;寫入標(biāo)題
xlSheet.Range("B1") = sset.Count &#39;寫入數(shù)據(jù)
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;寫入對(duì)象名
xlSheet.Range(("B" & i)) = Obj.Radius&#39;寫入半徑數(shù)據(jù)
xlSheet.Range(("C" & i)) = varCP(0) & "," & varCP(1) & "," & varCP(2)&#39;寫入圓心坐標(biāo)數(shù)據(jù)
Case "AcDbLine"
xlSheet.Range(("A" & i)) = "AcDbLine"&#39;寫入對(duì)象名
varCP = Obj.StartPoint
xlSheet.Range(("B" & i)) = varCP(0) & "," & varCP(1) & "," & varCP(2)&#39;寫入起點(diǎn)坐標(biāo)數(shù)據(jù)
varCP = Obj.EndPoint
xlSheet.Range(("C" & i)) = varCP(0) & "," & varCP(1) & "," & varCP(2)&#39;寫入終點(diǎn)坐標(biāo)數(shù)據(jù)
Case "AcDbArc"
varCP = Obj.Center
xlSheet.Range(("A" & i)) = "AcDbArc"&#39;寫入對(duì)象名
xlSheet.Range(("B" & i)) = Obj.Radius&#39;寫入半徑數(shù)據(jù)
xlSheet.Range(("C" & i)) = varCP(0) & "," & varCP(1) & "," & varCP(2)&#39;寫入圓心坐標(biāo)數(shù)據(jù)
xlSheet.Range(("D" & i)) = Obj.StartAngle&#39;寫入起始角數(shù)據(jù)
xlSheet.Range(("E" & i)) = Obj.EndAngle &#39;寫入終止角數(shù)據(jù)
End Select
i = i + 1
Next
xlApp.Visible = True
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
&#39;提取Excel數(shù)據(jù)升成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圖形數(shù)據(jù)的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;讀入半徑數(shù)據(jù)
strTemp = Split(xlSheet.Range(("C" & i)), ",")&#39;讀入圓心坐標(biāo)數(shù)據(jù)
For j = 0 To 2: dblCenter(j) = Val(strTemp(j)): Next j#p#分頁標(biāo)題#e#
ThisDrawing.ModelSpace.AddCircle dblCenter, dblRadius
Case "AcDbLine"
Dim dblStartP(2) As Double, dblEndP(2) As Double
strTemp = Split(xlSheet.Range(("B" & i)), ",") &#39;讀入起點(diǎn)坐標(biāo)數(shù)據(jù)
For j = 0 To 2: dblStartP(j) = Val(strTemp(j)): Next j
strTemp = (Split(xlSheet.Range(("C" & i)), ","))&#39;讀入終點(diǎn)坐標(biāo)數(shù)據(jù)
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;讀入半徑數(shù)據(jù)
strTemp = Split(xlSheet.Range(("C" & i)), ",")&#39;讀入圓心坐標(biāo)數(shù)據(jù)
For j = 0 To 2: dblCenter(j) = Val(strTemp(j)): Next j
dblStartAngle = Val(xlSheet.Range(("D" & i))) &#39;讀入起始角數(shù)據(jù)
dblEndAngle = Val(xlSheet.Range(("E" & i))) &#39;讀入終止角數(shù)據(jù)
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