EXCEL 直接復制到CAD裏面,excel表格變成了空白表格，excel是2016 CAD是2014,2008的CAD也是這樣，
代碼如下：（註：該代碼要復制到CAD的文件中，當然在CAD中要加載EXCEL應用）
Sub 根據excel自動畫表()
Dim xlApp As Excel.Application
Set xlApp = GetObject(, "Excel.Application")
Dim xlSheet As Worksheet
Set xlSheet = xlApp.ActiveSheet
Dim iPt(0 To 2) As Double
iPt(0) = 0: iPt(1) = 0: iPt(2) = 0
Dim BlockObj As AcadBlock
Set BlockObj = ThisDrawing.Blocks("*Model_Space")
Dim xlRange As Range
For Each xlRange In xlSheet.UsedRange
AddLine BlockObj, xlRange
AddText BlockObj, xlRange
Next
Set xlRange = Nothing
Set xlSheet = Nothing
Set xlApp = Nothing
End Sub
'邊框處理
Sub AddLine(ByRef BlockObj As AcadBlock, ByVal xlRange As Range)
Dim rl As Double
Dim rt As Double
Dim rw As Double
Dim rh As Double
rl = xlRange.Left / 2.835
rt = xlRange.top / 2.835
rw = xlRange.Width / 2.835
rh = xlRange.Height / 2.835
Dim pPt(0 To 3) As Double
Dim pLineObj As AcadLWPolyline
If xlRange.Borders(xlEdgeLeft).LineStyle <> xlNone And xlRange.Column = 1 Then
pPt(0) = rl: pPt(1) = -rt
pPt(2) = rl: pPt(3) = -(rl + rh)
Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)
With xlRange.Borders(xlEdgeLeft)
If .ColorIndex <> xlAutomatic Then
If .ColorIndex = 3 Then
pLineObj.color = acRed
ElseIf .ColorIndex = 4 Then
pLineObj.color = acGreen
ElseIf .ColorIndex = 5 Then
pLineObj.color = acBlue
ElseIf .ColorIndex = 6 Then
pLineObj.color = acYellow
ElseIf .ColorIndex = 8 Then
pLineObj.color = acCyan
ElseIf .ColorIndex = 9 Then
pLineObj.color = acMagenta
End If
End If
If .Weight = xlThin Then
pLineObj.ConstantWidth = 0
ElseIf .Weight = xlMedium Then
pLineObj.ConstantWidth = 0.35
ElseIf .Weight = xlThick Then
pLineObj.ConstantWidth = 0.7
End If
End With
End If
If xlRange.Borders(xlEdgeBottom).LineStyle <> xlNone And (xlRange.Row = xlRange.MergeArea.Row + xlRange.MergeArea.Rows.Count - 1) Then
pPt(0) = rl: pPt(1) = -(rt + rh)
pPt(2) = rl + rw: pPt(3) = -(rt + rh)
Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)
With xlRange.Borders(xlEdgeBottom)
If .ColorIndex <> xlAutomatic Then
If .ColorIndex = 3 Then
pLineObj.color = acRed
ElseIf .ColorIndex = 4 Then
pLineObj.color = acGreen
ElseIf .ColorIndex = 5 Then
pLineObj.color = acBlue
ElseIf .ColorIndex = 6 Then
pLineObj.color = acYellow
ElseIf .ColorIndex = 8 Then
pLineObj.color = acCyan
ElseIf .ColorIndex = 9 Then
pLineObj.color = acMagenta
End If
End If
If .Weight = xlThin Then
pLineObj.ConstantWidth = 0
ElseIf .Weight = xlMedium Then
pLineObj.ConstantWidth = 0.35
ElseIf .Weight = xlThick Then
pLineObj.ConstantWidth = 0.7
End If
End With
End If
If xlRange.Borders(xlEdgeRight).LineStyle <> xlNone And (xlRange.Column >= xlRange.MergeArea.Column + xlRange.MergeArea.Columns.Count - 1) Then
pPt(0) = rl + rw: pPt(1) = -(rt + rh)
pPt(2) = rl + rw: pPt(3) = -rt
Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)
With xlRange.Borders(xlEdgeRight)
If .ColorIndex <> xlAutomatic Then
If .ColorIndex = 3 Then
pLineObj.color = acRed
ElseIf .ColorIndex = 4 Then
pLineObj.color = acGreen
ElseIf .ColorIndex = 5 Then
pLineObj.color = acBlue
ElseIf .ColorIndex = 6 Then
pLineObj.color = acYellow
ElseIf .ColorIndex = 8 Then
pLineObj.color = acCyan
ElseIf .ColorIndex = 9 Then
pLineObj.color = acMagenta
End If
End If
If .Weight = xlThin Then
pLineObj.ConstantWidth = 0
ElseIf .Weight = xlMedium Then
pLineObj.ConstantWidth = 0.35
ElseIf .Weight = xlThick Then
pLineObj.ConstantWidth = 0.7
End If
End With
End If
If xlRange.Borders(xlEdgeTop).LineStyle <> xlNone And xlRange.top = 1 Then
pPt(0) = rl + rw: pPt(1) = -rt
pPt(2) = rl: pPt(3) = -rt
Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)
With xlRange.Borders(xlEdgeTop)
If .ColorIndex <> xlAutomatic Then
If .ColorIndex = 3 Then
pLineObj.color = acRed
ElseIf .ColorIndex = 4 Then
pLineObj.color = acGreen
ElseIf .ColorIndex = 5 Then
pLineObj.color = acBlue
ElseIf .ColorIndex = 6 Then
pLineObj.color = acYellow
ElseIf .ColorIndex = 8 Then
pLineObj.color = acCyan
ElseIf .ColorIndex = 9 Then
pLineObj.color = acMagenta
End If
End If
If .Weight = xlThin Then
pLineObj.ConstantWidth = 0
ElseIf .Weight = xlMedium Then
pLineObj.ConstantWidth = 0.35
ElseIf .Weight = xlThick Then
pLineObj.ConstantWidth = 0.7
End If
End With
End If
Set pLineObj = Nothing
End Sub
'文字處理
Sub AddText(ByRef BlockObj As AcadBlock, ByVal xlRange As Range)
If xlRange.Text = "" Then Exit Sub
Dim rl As Double
Dim rt As Double
Dim rw As Double
Dim rh As Double
rl = xlRange.Left / 2.835
rt = xlRange.top / 2.835
rw = xlRange.MergeArea.Width / 2.835
rh = xlRange.MergeArea.Height / 2.835
Dim iPt(0 To 2) As Double
iPt(0) = rl: iPt(1) = -rt: iPt(2) = 0
Dim mTextObj As AcadMText
Set mTextObj = BlockObj.AddMText(iPt, rw, xlRange.Text)
Dim tPt As Variant
If xlRange.VerticalAlignment = xlTop And (xlRange.HorizontalAlignment = xlLeft Or xlRange.HorizontalAlignment = xlGeneral) Then
mTextObj.AttachmentPoint = acAttachmentPointTopLeft
mTextObj.InsertionPoint = iPt
ElseIf xlRange.VerticalAlignment = xlTop And xlRange.HorizontalAlignment = xlCenter Then
mTextObj.AttachmentPoint = acAttachmentPointTopCenter
tPt = ThisDrawing.Utility.PolarPoint(iPt, 0, rw / 2)
ElseIf xlRange.VerticalAlignment = xlTop And xlRange.HorizontalAlignment = xlRight Then
mTextObj.AttachmentPoint = acAttachmentPointTopRight
tPt = ThisDrawing.Utility.PolarPoint(iPt, 0, rw)
ElseIf xlRange.VerticalAlignment = xlCenter And (xlRange.HorizontalAlignment = xlLeft _
Or xlRange.HorizontalAlignment = xlGeneral) Then
mTextObj.AttachmentPoint = acAttachmentPointMiddleLeft
tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh / 2)
ElseIf xlRange.VerticalAlignment = xlCenter And xlRange.HorizontalAlignment = xlCenter Then
mTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh / 2)
tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw / 2)
ElseIf xlRange.VerticalAlignment = xlCenter And xlRange.HorizontalAlignment = xlRight Then
mTextObj.AttachmentPoint = acAttachmentPointMiddleRight
tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh / 2)
tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw / 2)
ElseIf xlRange.VerticalAlignment = xlBottom And (xlRange.HorizontalAlignment = xlLeft _
Or xlRange.HorizontalAlignment = xlGeneral) Then
mTextObj.AttachmentPoint = acAttachmentPointBottomLeft
tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh)
ElseIf xlRange.VerticalAlignment = xlBottom And xlRange.HorizontalAlignment = xlCenter Then
mTextObj.AttachmentPoint = acAttachmentPointBottomCenter
tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh)
tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw / 2)
ElseIf xlRange.VerticalAlignment = xlBottom And xlRange.HorizontalAlignment = xlRight Then
mTextObj.AttachmentPoint = acAttachmentPointBottomRight
tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh)
tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw)
End If
mTextObj.InsertionPoint = tPt
Set mTextObj = Nothing
End Sub