1、 Dim iPt(0 To 2) As DoubleiPt(0) = 0: iPt(1) = 0: iPt(2) = 0 Dim BlockObj As AcadBlock 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
2、 xlSheet.UsedRange AddLine BlockObj, iPt, xlRange AddText BlockObj, iPt, xlRange 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
3、 xlThick LineWidth = 0.7 Case Else End SelectEnd FunctionFunction LineColor(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 Lin
4、eColor = acCyan Case 9 LineColor = acMagentaSub 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 xlRa
5、nge.Borders(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(xl
6、EdgeLeft).LineStyle 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.Bo
7、rders(xlEdgeLeft) If xlRange.Borders(xlEdgeBottom).LineStyle xlNone And (xlRange.Row = xlRange.MergeArea.Row + xlRange.MergeArea.Rows.Count - 1) Then pPt(1) = iPt(1) - (rt + rh) pPt(2) = iPt(0) + rl + rw: pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeBottom) pLineObj.Color = LineColor(xlR
8、ange.Borders(xlEdgeBottom) If xlRange.Borders(xlEdgeRight).LineStyle = xlRange.MergeArea.Column + xlRange.MergeArea.Columns.Count - 1) Then pPt(0) = iPt(0) + rl + rw: pPt(3) = iPt(1) - rt pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeRight) pLineObj.Color = LineColor(xlRange.Borders(xlEdg
9、eRight) If xlRange.Borders(xlEdgeTop).LineStyle xlNone And xlRange.Row = 1 Then pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeTop) pLineObj.Color = LineColor(xlRange.Borders(xlEdgeTop) Set pLineObj = NothingSub AddText(ByRef BlockObj As AcadBlock, ByVal InsertionPoint As Variant, ByVal xl
10、Range As Range) If xlRange.Text = Then Exit Sub rw = PToM(xlRange.MergeArea.Width) 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 Mid(xlRange.Text, i, 1) End If Dim iPt(0 T
11、o 2) As Double iPt(0) = InsertionPoint(0) + rl: iPt(1) = InsertionPoint(1) - rt: 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.VerticalAlign
12、ment = xlTop And (xlRange.HorizontalAlignment = xlLeft Or xlRange.HorizontalAlignment = xlGeneral) Then mTextObj.AttachmentPoint = acAttachmentPointTopLeft tPt = iPt ElseIf xlRange.VerticalAlignment = xlTop And xlRange.HorizontalAlignment = xlCenter Then mTextObj.AttachmentPoint = acAttachmentPointT
13、opCenter 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
14、(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 mT
15、extObj.AttachmentPoint = acAttachmentPointMiddleCenter tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw / 2) ElseIf xlRange.VerticalAlignment = xlCenter And xlRange.HorizontalAlignment = xlRight Then mTextObj.AttachmentPoint = acAttachmentPointMiddleRight ElseIf xlRange.VerticalAlignment = xlBottom A
16、nd (xlRange.HorizontalAlignment = xlLeft _ mTextObj.AttachmentPoint = acAttachmentPointBottomLeft tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh) ElseIf xlRange.VerticalAlignment = xlBottom And xlRange.HorizontalAlignment = xlCenter Then mTextObj.AttachmentPoint = acAttachmentPointBottomCe
17、nter ElseIf xlRange.VerticalAlignment = xlBottom And xlRange.HorizontalAlignment = xlRight Then mTextObj.AttachmentPoint = acAttachmentPointBottomRight tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw) mTextObj.InsertionPoint = tPt Set mTextObj = Nothing 岻趨Function PToM(ByVal Points As Double) As Double PToM = Points * 0.3527778