1、Sub Test() On Error Resume Next Excel Dim xlApp As Excel.Application Set xlApp = GetObject(, Excel.Application) If Err Then MsgBox Excel Excel Exit Sub End If 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 AcadBlo
2、ck Set BlockObj = ThisDrawing.Blocks(*Model_Space) Dim iPt As Variant iPt = ThisDrawing.Utility.GetPoint(, : ) If IsEmpty(iPt) Then Exit Sub Dim xlRange As Range Debug.Print xlSheet.UsedRange.Address For Each xlRange In xlSheet.UsedRange AddLine BlockObj, iPt, xlRange AddText BlockObj, iPt, xlRange
3、Next Set xlRange = Nothing Set xlSheet = Nothing Set xlApp = NothingEnd SubFunction LineWidth(ByVal xlBorder As Border) As Double Select Case xlBorder.Weight Case xlThin LineWidth = 0 Case xlMedium LineWidth = 0.35 Case xlThick LineWidth = 0.7 Case Else LineWidth = 0 End SelectEnd FunctionFunction L
4、ineColor(ByVal xlBorder As Border) As Integer Select Case xlBorder.ColorIndex Case xlAutomatic LineColor = acByLayer Case 3 LineColor = acRed Case 4 LineColor = acGreen Case 5 LineColor = acBlue Case 6 LineColor = acYellow Case 8 LineColor = acCyan Case 9 LineColor = acMagenta Case Else LineColor =
5、acByLayer End SelectEnd FunctionSub AddLine(ByRef BlockObj As AcadBlock, ByVal iPt As Variant, ByVal xlRange As Range) If xlRange.Borders(xlEdgeLeft).LineStyle = xlNone _ And xlRange.Borders(xlEdgeBottom).LineStyle = xlNone _ And xlRange.Borders(xlEdgeRight).LineStyle = xlNone _ And xlRange.Borders(
6、xlEdgeTop).LineStyle = xlNone Then Exit Sub Dim rl As Double Dim rt As Double Dim rw As Double Dim rh As Double rl = PToM(xlRange.Left) rt = PToM(xlRange.top) rw = PToM(xlRange.Width) rh = PToM(xlRange.Height) Dim pPt(0 To 3) As Double Dim pLineObj As AcadLWPolyline If xlRange.Borders(xlEdgeLeft).Li
7、neStyle xlNone And xlRange.Column = 1 Then pPt(0) = iPt(0) + rl: pPt(1) = iPt(1) - rt pPt(2) = iPt(0) + rl: pPt(3) = iPt(1) - (rt + rh) Set pLineObj = BlockObj.AddLightWeightPolyline(pPt) pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeLeft) pLineObj.Color = LineColor(xlRange.Borders(xlEdge
8、Left) End If If xlRange.Borders(xlEdgeBottom).LineStyle xlNone And (xlRange.Row = xlRange.MergeArea.Row + xlRange.MergeArea.Rows.Count - 1) Then pPt(0) = iPt(0) + rl: pPt(1) = iPt(1) - (rt + rh) pPt(2) = iPt(0) + rl + rw: pPt(3) = iPt(1) - (rt + rh) Set pLineObj = BlockObj.AddLightWeightPolyline(pPt
9、) pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeBottom) pLineObj.Color = LineColor(xlRange.Borders(xlEdgeBottom) End If If xlRange.Borders(xlEdgeRight).LineStyle xlNone And (xlRange.Column = xlRange.MergeArea.Column + xlRange.MergeArea.Columns.Count - 1) Then pPt(0) = iPt(0) + rl + rw: pP
10、t(1) = iPt(1) - (rt + rh) pPt(2) = iPt(0) + rl + rw: pPt(3) = iPt(1) - rt Set pLineObj = BlockObj.AddLightWeightPolyline(pPt) pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeRight) pLineObj.Color = LineColor(xlRange.Borders(xlEdgeRight) End If If xlRange.Borders(xlEdgeTop).LineStyle xlNone
11、And xlRange.Row = 1 Then pPt(0) = iPt(0) + rl + rw: pPt(1) = iPt(1) - rt pPt(2) = iPt(0) + rl: pPt(3) = iPt(1) - rt Set pLineObj = BlockObj.AddLightWeightPolyline(pPt) pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeTop) pLineObj.Color = LineColor(xlRange.Borders(xlEdgeTop) End If Set pLine
12、Obj = NothingEnd SubSub AddText(ByRef BlockObj As AcadBlock, ByVal InsertionPoint As Variant, 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 = PToM(xlRange.Left) rt = PToM(xlRange.top) rw = PToM(xlRange.MergeArea.Width)
13、rh = PToM(xlRange.MergeArea.Height) Dim i As Integer Dim s As String For i = 1 To Len(xlRange.Text) EXCEL滻PR2002Replace If Asc(Mid(xlRange.Text, i, 1) = 10 Then s = s & P Else s = s & Mid(xlRange.Text, i, 1) End If Next Dim iPt(0 To 2) As Double iPt(0) = InsertionPoint(0) + rl: iPt(1) = InsertionPoi
14、nt(1) - rt: iPt(2) = 0 Dim mTextObj As AcadMText Set mTextObj = BlockObj.AddMText(iPt, rw, s) f & xlRange.Font.Name & ; & s & ) mTextObj.LineSpacingFactor = 0.75 mTextObj.Height = PToM(xlRange.Font.Size) Dim tPt As Variant If xlRange.VerticalAlignment = xlTop And (xlRange.HorizontalAlignment = xlLef
15、t Or xlRange.HorizontalAlignment = xlGeneral) Then mTextObj.AttachmentPoint = acAttachmentPointTopLeft tPt = iPt ElseIf xlRange.VerticalAlignment = xlTop And xlRange.HorizontalAlignment = xlCenter Then mTextObj.AttachmentPoint = acAttachmentPointTopCenter tPt = ThisDrawing.Utility.PolarPoint(iPt, 0,
16、 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.Ho
17、rizontalAlignment = 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 = acAttachmentPointMiddleCente
18、r 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
19、(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.Pol
20、arPoint(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 xlRa
21、nge.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 = NothingEnd Sub 岻趨Function PToM(ByVal Points As Double) As Double PToM = Points * 0.3527778End Function
