- UID
- 18608
- 积分
- 2508
- 精华
- 贡献
-
- 威望
-
- 活跃度
-
- D豆
-
- 在线时间
- 小时
- 注册时间
- 2002-12-4
- 最后登录
- 1970-1-1
|
楼主 |
发表于 2013-6-9 09:09:53
|
显示全部楼层
本帖最后由 Free-Lancer 于 2013-6-9 09:18 编辑
前面我写的那个 Sortln 就是想合并这些一段段线条的,你看看这是一个完整的 VBA 转换,出来的线也是一段段的,没有优化,另外边读边画速度不快
- Option Explicit
- ' 方向系数
- Dim DirectionScale As Double
- ' 行高系数,磅
- Dim RowHeightScale As Double
- ' 列宽单位,1、字符,2、磅,默认为字符
- Dim ColumnWidthUnitType As Integer
- ' 列宽系数
- Dim ColumnWidthScale As Double
- ' 文字高度系数
- Dim TextHeightScale As Double
- Dim TableRange As Excel.Range
- Private Sub UserForm_Initialize()
- ' 初始化,列宽采用字符为单位
- RowHeightScale = 0.5
- ColumnWidthUnitType = 1
- ColumnWidthScale = 2
- TextHeightScale = 0.3
- End Sub
- Private Sub cmdPickPt_Click()
- Dim iPt As Variant
- On Error GoTo ErrTrap
- '隐藏窗体,注意与用户交互时必须先隐藏窗体,然后等待用户操作,最后显示窗体
- Me.Hide
- ' 返回选择或者输入的点
- iPt = ThisDrawing.Utility.GetPoint(, "指定插入点: ")
- TextBox1.Text = iPt(0)
- TextBox2.Text = iPt(1)
- iPt(2) = 0
- ' 显示窗体
- Me.Show
- Exit Sub
-
- ErrTrap:
- ' 防止出错时窗体不显示
- Me.Show
- On Error GoTo 0
- End Sub
- Private Sub cmdOK_Click()
- Dim iPt(0 To 2) As Double
- Dim xlApp As Object
- Dim xlSheet As Object
-
- ' 表格的插入点
- iPt(0) = TextBox1.Text
- iPt(1) = TextBox2.Text
- iPt(2) = 0
-
- ' 发生错误时跳到下一个语句继续执行
- On Error Resume Next
- ' 连接Excel应用程序
- Set xlApp = GetObject(, "Excel.Application")
- If Err.Number <> 0 Then
- MsgBox "Excel应用程序没有运行!"
- Exit Sub
- End If
- ' 返回当前活动的工作表
- Set xlSheet = xlApp.ActiveSheet
-
- ' 表格的转换方向
- If OptionButton3.Value = True Then
- DirectionScale = 1 ' 从上到下
- Else
- DirectionScale = -1 ' 从下到上
- End If
-
- Dim r As Object
- ' 表格的转换区域
- If OptionButton1.Value = True Then ' 使用区域
- Set TableRange = xlSheet.UsedRange
- ' 遍历要转换的单元格区域
- For Each r In xlSheet.UsedRange
- ' 转换表格的边框
- AddTableLine ThisDrawing.Blocks("*Model_Space"), iPt, r
- ' 转换表格的文字
- AddTableText ThisDrawing.Blocks("*Model_Space"), iPt, r
- Next
- Else ' 选中区域
- Set TableRange = xlSheet.UsedRange
- ' 遍历要转换的单元格区域
- For Each r In xlApp.Selection
- ' 转换表格的边框
- AddTableLine ThisDrawing.Blocks("*Model_Space"), iPt, r
- ' 转换表格的文字
- AddTableText ThisDrawing.Blocks("*Model_Space"), iPt, r
- Next
- End If
-
- ' 更新
- ThisDrawing.Regen acActiveViewport
-
- ' 释放对象
- Set xlSheet = Nothing
- Set xlApp = Nothing
-
- Unload Me
- End Sub
- Private Sub cmdCancel_Click()
- Unload Me
- End Sub
- ' 给制单元格中的边框
- Sub AddTableLine(ByRef BlockObj As AcadBlock, ByVal iPt As Variant, ByVal xlRange As Range)
- ' 记录单元格的位置和尺寸
- Dim rl As Double
- Dim rt As Double
- Dim rw As Double
- Dim rh As Double
-
- Dim sPt(0 To 2) As Double
- Dim ePt(0 To 2) As Double
- Dim pPt(0 To 3) As Double
- Dim LineObj As AcadLine
- Dim LWPLineObj As Object
-
- Dim i As Integer
-
- ' 单元格没有边框不做处理
- If xlRange.Borders(xlEdgeLeft).LineStyle = xlNone _
- And xlRange.Borders(xlEdgeBottom).LineStyle = xlNone _
- And xlRange.Borders(xlEdgeRight).LineStyle = xlNone _
- And xlRange.Borders(xlEdgeTop).LineStyle = xlNone Then Exit Sub
-
- If ColumnWidthUnitType = 1 Then
- ' 字符单位时的列宽
- For i = TableRange.Column To xlRange.Column - 1
- rl = rl + TableRange.Columns(i).ColumnWidth * ColumnWidthScale
- Next
- ElseIf ColumnWidthUnitType = 2 Then
- ' 磅单位时的列宽
- rl = (xlRange.Left - TableRange.Left) * ColumnWidthScale
- End If
- rt = (xlRange.top - TableRange.top) * RowHeightScale
- If ColumnWidthUnitType = 1 Then
- rw = xlRange.ColumnWidth * ColumnWidthScale
- ElseIf ColumnWidthUnitType = 2 Then
- rw = xlRange.Width * ColumnWidthScale
- End If
- rh = xlRange.Height * RowHeightScale
-
- ' 左边框,只有第一列才转换,避免重复,因为单元格的右边框为右方单元格的左边框
- If xlRange.Borders(xlEdgeLeft).LineStyle <> xlNone And xlRange.Column = TableRange.Column Then
- If OptionButton5.Value = True Then
- ' 创建直线
- sPt(0) = iPt(0) + rl: sPt(1) = iPt(1) - rt * DirectionScale
- ePt(0) = iPt(0) + rl: ePt(1) = iPt(1) - (rt + rh) * DirectionScale
- Set LineObj = BlockObj.AddLine(sPt, ePt)
- LineObj.color = LineColor(xlRange.Borders(xlEdgeLeft))
- Else
- ' 创建多段线
- pPt(0) = iPt(0) + rl: pPt(1) = iPt(1) - rt * DirectionScale
- pPt(2) = iPt(0) + rl: pPt(3) = iPt(1) - (rt + rh) * DirectionScale
- Set LWPLineObj = BlockObj.AddLightWeightPolyline(pPt)
- LWPLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeLeft))
- LWPLineObj.color = LineColor(xlRange.Borders(xlEdgeLeft))
- End If
- End If
-
- ' 下边框,对于合并单元格的内部不转换
- If xlRange.Borders(xlEdgeBottom).LineStyle <> xlNone And (xlRange.Row = xlRange.MergeArea.Row + xlRange.MergeArea.Rows.Count - 1) Then
- If OptionButton5.Value = True Then
- ' 创建直线
- sPt(0) = iPt(0) + rl: sPt(1) = iPt(1) - (rt + rh) * DirectionScale
- ePt(0) = iPt(0) + rl + rw: ePt(1) = iPt(1) - (rt + rh) * DirectionScale
- Set LineObj = BlockObj.AddLine(sPt, ePt)
- LineObj.color = LineColor(xlRange.Borders(xlEdgeLeft))
- Else
- ' 创建多段线
- pPt(0) = iPt(0) + rl: pPt(1) = iPt(1) - (rt + rh) * DirectionScale
- pPt(2) = iPt(0) + rl + rw: pPt(3) = iPt(1) - (rt + rh) * DirectionScale
- Set LWPLineObj = BlockObj.AddLightWeightPolyline(pPt)
- LWPLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeBottom))
- LWPLineObj.color = LineColor(xlRange.Borders(xlEdgeBottom))
- End If
- End If
-
- ' 右边框,对于合并单元格的内部不转换
- If xlRange.Borders(xlEdgeRight).LineStyle <> xlNone And (xlRange.Column >= xlRange.MergeArea.Column + xlRange.MergeArea.Columns.Count - 1) Then
- If OptionButton5.Value = True Then
- ' 创建直线
- sPt(0) = iPt(0) + rl + rw: sPt(1) = iPt(1) - rt * DirectionScale
- ePt(0) = iPt(0) + rl + rw: ePt(1) = iPt(1) - (rt + rh) * DirectionScale
- Set LineObj = BlockObj.AddLine(sPt, ePt)
- LineObj.color = LineColor(xlRange.Borders(xlEdgeLeft))
- Else
- ' 创建多段线
- pPt(0) = iPt(0) + rl + rw: pPt(1) = iPt(1) - rt * DirectionScale
- pPt(2) = iPt(0) + rl + rw: pPt(3) = iPt(1) - (rt + rh) * DirectionScale
- Set LWPLineObj = BlockObj.AddLightWeightPolyline(pPt)
- LWPLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeRight))
- LWPLineObj.color = LineColor(xlRange.Borders(xlEdgeRight))
- End If
- End If
-
- ' 上边框,只有第一行才转换,避免重复,因为单元格的下边框为下方单元格的上边框
- If xlRange.Borders(xlEdgeTop).LineStyle <> xlNone And xlRange.Row = TableRange.Row Then
- If OptionButton5.Value = True Then
- ' 创建直线
- sPt(0) = iPt(0) + rl: sPt(1) = iPt(1) - rt * DirectionScale
- ePt(0) = iPt(0) + rl + rw: ePt(1) = iPt(1) - rt * DirectionScale
- Set LineObj = BlockObj.AddLine(sPt, ePt)
- LineObj.color = LineColor(xlRange.Borders(xlEdgeLeft))
- Else
- ' 创建多段线
- pPt(0) = iPt(0) + rl: pPt(1) = iPt(1) - rt * DirectionScale
- pPt(2) = iPt(0) + rl + rw: pPt(3) = iPt(1) - rt * DirectionScale
- Set LWPLineObj = BlockObj.AddLightWeightPolyline(pPt)
- LWPLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeTop))
- LWPLineObj.color = LineColor(xlRange.Borders(xlEdgeTop))
- End If
- End If
-
- Set LineObj = Nothing
- Set LWPLineObj = Nothing
- End Sub
- ' 给制单元格中的文字
- Sub AddTableText(ByRef BlockObj As AcadBlock, ByVal iPt As Variant, ByVal xlRange As Range)
- ' 记录单元格的位置和尺寸
- Dim rl As Double
- Dim rt As Double
- Dim rw As Double
- Dim rh As Double
-
- Dim tiPt(0 To 2) As Double
- Dim TextObj As AcadText
- Dim MTextObj As AcadMText
- Dim tPt As Variant
-
- Dim i As Integer
-
- ' 单元格没有文字不做处理
- If xlRange.Text = "" Then Exit Sub
-
- If ColumnWidthUnitType = 1 Then
- ' 字符单位时的列宽
- For i = TableRange.Column To xlRange.Column - 1
- rl = rl + TableRange.Columns(i).ColumnWidth * ColumnWidthScale
- Next
- ElseIf ColumnWidthUnitType = 2 Then
- ' 磅单位时的列宽
- rl = (xlRange.Left - TableRange.Left) * ColumnWidthScale
- End If
- rt = (xlRange.top - TableRange.top) * RowHeightScale
- If ColumnWidthUnitType = 1 Then
- rw = xlRange.ColumnWidth * ColumnWidthScale
- ElseIf ColumnWidthUnitType = 2 Then
- rw = xlRange.Width * ColumnWidthScale
- End If
- rh = xlRange.MergeArea.Height * RowHeightScale
-
- tiPt(0) = iPt(0) + rl: tiPt(1) = iPt(1) - rt * DirectionScale: tiPt(2) = 0
- If OptionButton7.Value = True Then
- ' 创建单行文字
- Set TextObj = BlockObj.AddText(xlRange.Text, tiPt, xlRange.Font.Size * TextHeightScale)
- TextObj.color = TextColor(xlRange.Font)
- Else
- ' 创建多行文字
- Set MTextObj = BlockObj.AddMText(tiPt, rw, xlRange.Text)
- MTextObj.Height = xlRange.Font.Size * TextHeightScale
- MTextObj.color = TextColor(xlRange.Font)
- End If
-
- tiPt(0) = tiPt(0) + rw / 2: tiPt(1) = tiPt(1) - rh / 2 * DirectionScale: tiPt(2) = 0
- If xlRange.VerticalAlignment = xlTop And (xlRange.HorizontalAlignment = xlLeft Or xlRange.HorizontalAlignment = xlGeneral) Then
- ' 左上对齐
- If OptionButton7.Value = True Then
- TextObj.Alignment = acAlignmentTopLeft
- Else
- MTextObj.AttachmentPoint = acAttachmentPointTopLeft
- End If
- tPt = ThisDrawing.Utility.PolarPoint(tiPt, 3.1415926, rw / 2)
- tPt = ThisDrawing.Utility.PolarPoint(tPt, 1.5707963, rh / 2)
- ElseIf xlRange.VerticalAlignment = xlTop And xlRange.HorizontalAlignment = xlCenter Then
- ' 中上对齐
- If OptionButton7.Value = True Then
- TextObj.Alignment = acAlignmentTopCenter
- Else
- MTextObj.AttachmentPoint = acAttachmentPointTopCenter
- End If
- tPt = ThisDrawing.Utility.PolarPoint(tiPt, 1.5707963, rh / 2)
- ElseIf xlRange.VerticalAlignment = xlTop And xlRange.HorizontalAlignment = xlRight Then
- ' 右上对齐
- If OptionButton7.Value = True Then
- TextObj.Alignment = acAlignmentTopRight
- Else
- MTextObj.AttachmentPoint = acAttachmentPointTopRight
- End If
- tPt = ThisDrawing.Utility.PolarPoint(tiPt, 0, rw / 2)
- tPt = ThisDrawing.Utility.PolarPoint(tPt, 1.5707963, rh / 2)
- ElseIf xlRange.VerticalAlignment = xlCenter And (xlRange.HorizontalAlignment = xlLeft _
- Or xlRange.HorizontalAlignment = xlGeneral) Then
- ' 左中对齐
- If OptionButton7.Value = True Then
- TextObj.Alignment = acAlignmentMiddleLeft
- Else
- MTextObj.AttachmentPoint = acAttachmentPointMiddleLeft
- End If
- tPt = ThisDrawing.Utility.PolarPoint(tiPt, 3.1415926, rw / 2)
- ElseIf xlRange.VerticalAlignment = xlCenter And xlRange.HorizontalAlignment = xlCenter Then
- ' 正中对齐
- If OptionButton7.Value = True Then
- TextObj.Alignment = acAlignmentMiddleCenter
- Else
- MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
- End If
- tPt = tiPt
- ElseIf xlRange.VerticalAlignment = xlCenter And xlRange.HorizontalAlignment = xlRight Then
- ' 右中对齐
- If OptionButton7.Value = True Then
- TextObj.Alignment = acAlignmentMiddleRight
- Else
- MTextObj.AttachmentPoint = acAttachmentPointMiddleRight
- End If
- tPt = ThisDrawing.Utility.PolarPoint(tiPt, 0, rw / 2)
- ElseIf xlRange.VerticalAlignment = xlBottom And (xlRange.HorizontalAlignment = xlLeft _
- Or xlRange.HorizontalAlignment = xlGeneral) Then
- ' 左下对齐
- If OptionButton7.Value = True Then
- TextObj.Alignment = acAlignmentBottomLeft
- Else
- MTextObj.AttachmentPoint = acAttachmentPointBottomLeft
- End If
- tPt = ThisDrawing.Utility.PolarPoint(tiPt, 3.1415926, rw / 2)
- tPt = ThisDrawing.Utility.PolarPoint(tPt, -1.5707963, rh / 2)
- ElseIf xlRange.VerticalAlignment = xlBottom And xlRange.HorizontalAlignment = xlCenter Then
- ' 中下对齐
- If OptionButton7.Value = True Then
- TextObj.Alignment = acAlignmentBottomCenter
- Else
- MTextObj.AttachmentPoint = acAttachmentPointBottomCenter
- End If
- tPt = ThisDrawing.Utility.PolarPoint(tiPt, -1.5707963, rh / 2)
- ElseIf xlRange.VerticalAlignment = xlBottom And xlRange.HorizontalAlignment = xlRight Then
- ' 右下对齐
- If OptionButton7.Value = True Then
- TextObj.Alignment = acAlignmentBottomRight
- Else
- MTextObj.AttachmentPoint = acAttachmentPointBottomRight
- End If
- tPt = ThisDrawing.Utility.PolarPoint(tiPt, 0, rw / 2)
- tPt = ThisDrawing.Utility.PolarPoint(tPt, -1.5707963, rh / 2)
- End If
- If OptionButton7.Value = True Then
- TextObj.TextAlignmentPoint = tPt
- Else
- MTextObj.InsertionPoint = tPt
- End If
-
- Set TextObj = Nothing
- Set MTextObj = Nothing
- End Sub
- '边框粗细
- Function 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 Select
- End Function
- '边框颜色,处理的颜色不全,请自己添加
- Function LineColor(ByVal xlBorder As Border) As Integer
- Select Case xlBorder.ColorIndex
- Case xlAutomatic
- LineColor = acByLayer
- Case 2
- LineColor = acWhite
- Case 3
- LineColor = acRed
- Case 5
- LineColor = acBlue
- Case 6
- LineColor = acYellow
- Case 7
- LineColor = acMagenta
- Case 10
- LineColor = acGreen
- Case 14
- LineColor = acCyan
- Case Else
- LineColor = acByLayer
- End Select
- End Function
- '文字颜色,处理的颜色不全,请自己添加
- Function TextColor(ByVal xlFont As Excel.Font) As Integer
- Select Case xlFont.ColorIndex
- Case xlAutomatic
- TextColor = acByLayer
- Case 2
- TextColor = acWhite
- Case 3
- TextColor = acRed
- Case 5
- TextColor = acBlue
- Case 6
- TextColor = acYellow
- Case 7
- TextColor = acMagenta
- Case 10
- TextColor = acGreen
- Case 14
- TextColor = acCyan
- Case Else
- TextColor = acByLayer
- End Select
- End Function
DVB文件
http://www.xdcad.net/forum/forum.php?mod=attachment&aid=MjQxN3xiZmE5MzgxN3wxMzcwNzQwMjM2fDE4NjA4fDY2ODY4Mw%3D%3D
|
|