大家合力写个开源的EXCEL-CAD如何

ayl1004 · 发表于 2013-6-9 08:53:54

(defun AYL-ConvertUnit (ENumber)
(/ (* ENumber 25.4) 72)
)
(defun AYL-ControlMA (RangeObj InitPt / Width Height RetPnt
String HAlign
VAlign IndLvl Align MaCells Font FontName
)
(setq Width (AYL-ConvertUnit (vlax-variant-value (vlax-get-property RangeObj 'Width)))
Height (AYL-ConvertUnit (vlax-variant-value (vlax-get-property RangeObj 'Height)))
RetPnt (polar InitPt 0.0 Width)
String nil
MaCells (vlax-get-property RangeObj 'Cells)
)
(vlax-for Item MaCells
(if (not String)
(setq String (vlax-variant-value (vlax-get-property Item 'Text)))
)
(vlax-release-object Item)
)
(vlax-release-object MaCells)
(entmakex (list '(0 . "Line") (cons 10 InitPt) (cons 11 RetPnt)))
(entmakex (list '(0 . "Line") (cons 10 InitPt) (cons 11 (polar InitPt (* pi 1.5) Height))))
(if String
(progn
(setq HAlign (vlax-variant-value (vlax-get-property RangeObj 'HorizontalAlignment))
VAlign (vlax-variant-value (vlax-get-property RangeObj 'VerticalAlignment))
IndLvl (AYL-ConvertUnit (* (vlax-variant-value (vlax-get-property RangeObj 'IndentLevel)) 3.0 6.25))
)
(cond ((= HAlign 1) (setq HAlign -4131))
((= HAlign -4130) (setq HAlign -4108))
((= HAlign -4117) (setq HAlign -4108))
((= HAlign 5) (setq HAlign -4108))
(t nil)
)
(cond ((= VAlign -4130) (setq VAlign -4108))
((= VAlign -4117) (setq VAlign -4108))
(t nil)
)
(cond
((and (= HAlign -4131) (= VAlign -4160))
(setq Align 1
InitPt (polar InitPt 0.0 IndLvl)
)
)
((and (= HAlign -4131) (= VAlign -4108))
(setq Align 4
InitPt (polar InitPt (* pi 1.5) (* Height 0.5))
InitPt (polar InitPt 0.0 IndLvl)
)
)
((and (= HAlign -4131) (= VAlign -4107))
(setq Align 7
InitPt (polar InitPt (* pi 1.5) Height)
InitPt (polar InitPt 0.0 IndLvl)
)
)
((and (= HAlign -4108) (= VAlign -4160))
(setq Align 2
InitPt (polar InitPt 0.0 (* Width 0.5))
)
)
((and (= HAlign -4108) (= VAlign -4108))
(setq Align 5
InitPt (polar InitPt 0.0 (* Width 0.5))
InitPt (polar InitPt (* pi 1.5) (* Height 0.5))
)
)
((and (= HAlign -4108) (= VAlign -4107))
(setq Align 8
InitPt (polar InitPt 0.0 (* Width 0.5))
InitPt (polar InitPt (* pi 1.5) Height)
)
)
((and (= HAlign -4152) (= VAlign -4160))
(setq Align 3
InitPt (polar InitPt 0.0 Width)
InitPt (polar InitPt pi IndLvl)
)
)
((and (= HAlign -4152) (= VAlign -4108))
(setq Align 6
InitPt (polar InitPt 0.0 Width)
InitPt (polar InitPt (* pi 1.5) (* Height 0.5))
InitPt (polar InitPt pi IndLvl)
)
)
((and (= HAlign -4152) (= VAlign -4107))
(setq Align 9
InitPt (polar InitPt 0.0 Width)
InitPt (polar InitPt (* pi 1.5) Height)
InitPt (polar InitPt pi IndLvl)
)
)
(t nil)
)
(setq Font (vlax-get-property RangeObj 'Font)
FontName (vlax-variant-value (vlax-get-property Font 'Name))
)
(vlax-release-object Font)
(entmakex
(list
'(0 . "MText")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
(cons 1 (strcat "\\f" FontName ";" String))
(cons 10 InitPt)
(cons 41 Width)
(cons 71 Align)
)
)
)
)
RetPnt
)
(defun c:test (/ ExcApp Wkbk Sheet URange Cells
InsPt Rows CeLst MArea MCells luPnt
ruPnt rlPnt RowH RowW MaAddr CeAddr Value
)
(vl-load-com)
(alert "需要先打开被操作的Excel文件")
(setq ExcApp (vl-catch-all-apply 'vlax-get-object (list "Excel.Application")))
(if (not (vl-catch-all-error-p ExcApp))
(progn
(setq Wkbk (vl-catch-all-apply 'vlax-get-property (list ExcApp 'ActiveWorkbook)))
(if (vl-catch-all-error-p Wkbk)
(progn (princ "\n没有打开Excel文件") (vlax-release-object ExcApp))
(progn
(setq Sheet (vlax-get-property Wkbk 'ActiveSheet)
URange (vlax-get-property Sheet 'UsedRange)
Cells (vlax-get-property URange 'Cells)
)
(if (and (= (vlax-get-property Cells 'Count) 1)
(not (vlax-variant-value (vlax-get-property URange 'Value)))
)
(progn (princ "\n当前工作表是空的") (mapcar 'vlax-release-object (list ExcApp Wkbk Sheet URange Cells)))
(progn
(if (setq InsPt (getpoint "\n指定表格的插入点<左上点>："))
(progn
(vlax-release-object Cells)
(setq Rows (vlax-get-property URange 'Rows)
CeLst nil
luPnt InsPt
)
(vlax-for Item0 Rows
(setq Cells (vlax-get-property Item0 'Cells))
(vlax-for Item1 Cells
(setq MArea (vlax-get-property Item1 'MergeArea)
MaAddr (vlax-get-property MArea 'Address :vlax-true :vlax-true 1)
CeAddr (vlax-get-property Item1 'Address :vlax-true :vlax-true 1)
)
(cond
((equal MaAddr CeAddr) (setq luPnt (AYL-ControlMA MArea luPnt)))
((not (member CeAddr CeLst))
(setq MCells (vlax-get-property MArea 'Cells))
(vlax-for Item2 MCells
(setq CeLst (append CeLst (list (vlax-get-property Item2 'Address :vlax-true :vlax-true 1))))
)
(vlax-release-object MCells)
(setq luPnt (AYL-ControlMA MArea luPnt))
)
(t nil)
)
(mapcar 'vlax-release-object (list Item1 MArea))
)
(setq RowH (AYL-ConvertUnit (vlax-variant-value (vlax-get-property Item0 'Height)))
RowW (AYL-ConvertUnit (vlax-variant-value (vlax-get-property Item0 'Width)))
luPnt (polar (polar luPnt pi RowW) (* pi 1.5) RowH)
)
(mapcar 'vlax-release-object (list Item0 Cells))
)
(setq RowH (AYL-ConvertUnit (vlax-variant-value (vlax-get-property URange 'Height)))
RowW (AYL-ConvertUnit (vlax-variant-value (vlax-get-property URange 'Width)))
rlPnt (polar luPnt 0.0 RowW)
ruPnt (polar rlPnt (* pi 0.5) RowH)
)
(entmakex (list '(0 . "Line") (cons 10 luPnt) (cons 11 rlPnt)))
(entmakex (list '(0 . "Line") (cons 10 ruPnt) (cons 11 rlPnt)))
(mapcar 'vlax-release-object (list ExcApp Wkbk Sheet URange Rows))
)
)
)
)
)
)
)
(princ "\n没有打开Excel应用程序")
)
(princ)
)

(defun AYL-ConvertUnit (ENumber) 
  (/ (* ENumber 25.4) 72) 
) 
(defun AYL-ControlMA (RangeObj InitPt / Width Height RetPnt 
                      String HAlign 
                      VAlign IndLvl Align MaCells Font FontName 
                      ) 
  (setq Width  (AYL-ConvertUnit (vlax-variant-value (vlax-get-property RangeObj 'Width))) 
        Height (AYL-ConvertUnit (vlax-variant-value (vlax-get-property RangeObj 'Height))) 
        RetPnt (polar InitPt 0.0 Width) 
        String nil 
        MaCells (vlax-get-property RangeObj 'Cells) 
  ) 
  (vlax-for Item MaCells 
    (if (not String) 
      (setq String (vlax-variant-value (vlax-get-property Item 'Text))) 
    ) 
    (vlax-release-object Item) 
  ) 
  (vlax-release-object MaCells) 
  (entmakex (list '(0 . "Line") (cons 10 InitPt) (cons 11 RetPnt))) 
  (entmakex (list '(0 . "Line") (cons 10 InitPt) (cons 11 (polar InitPt (* pi 1.5) Height)))) 
  (if String 
    (progn 
           (setq HAlign (vlax-variant-value (vlax-get-property RangeObj 'HorizontalAlignment)) 
            VAlign (vlax-variant-value (vlax-get-property RangeObj 'VerticalAlignment)) 
            IndLvl (AYL-ConvertUnit (* (vlax-variant-value (vlax-get-property RangeObj 'IndentLevel)) 3.0 6.25)) 
      ) 
       (cond ((= HAlign 1) (setq HAlign -4131)) 
            ((= HAlign -4130) (setq HAlign -4108)) 
            ((= HAlign -4117) (setq HAlign -4108)) 
            ((= HAlign 5) (setq HAlign -4108)) 
            (t nil) 
      ) 
      (cond ((= VAlign -4130) (setq VAlign -4108)) 
            ((= VAlign -4117) (setq VAlign -4108)) 
            (t nil) 
      ) 
      (cond 
        ((and (= HAlign -4131) (= VAlign -4160)) 
         (setq Align 1 
               InitPt (polar InitPt 0.0 IndLvl) 
               ) 
        ) 
        ((and (= HAlign -4131) (= VAlign -4108)) 
         (setq Align  4 
               InitPt (polar InitPt (* pi 1.5) (* Height 0.5)) 
               InitPt (polar InitPt 0.0 IndLvl) 
         ) 
        ) 
        ((and (= HAlign -4131) (= VAlign -4107)) 
         (setq Align  7 
               InitPt (polar InitPt (* pi 1.5) Height) 
               InitPt (polar InitPt 0.0 IndLvl) 
         ) 
        ) 
        ((and (= HAlign -4108) (= VAlign -4160)) 
         (setq Align  2 
               InitPt (polar InitPt 0.0 (* Width 0.5)) 
         ) 
        ) 
        ((and (= HAlign -4108) (= VAlign -4108)) 
         (setq Align  5 
               InitPt (polar InitPt 0.0 (* Width 0.5)) 
               InitPt (polar InitPt (* pi 1.5) (* Height 0.5)) 
         ) 
        ) 
        ((and (= HAlign -4108) (= VAlign -4107)) 
         (setq Align  8 
               InitPt (polar InitPt 0.0 (* Width 0.5)) 
               InitPt (polar InitPt (* pi 1.5) Height) 
         ) 
        ) 
        ((and (= HAlign -4152) (= VAlign -4160)) 
         (setq Align  3 
               InitPt (polar InitPt 0.0 Width) 
               InitPt (polar InitPt pi IndLvl) 
         ) 
        ) 
        ((and (= HAlign -4152) (= VAlign -4108)) 
         (setq Align  6 
               InitPt (polar InitPt 0.0 Width) 
               InitPt (polar InitPt (* pi 1.5) (* Height 0.5)) 
               InitPt (polar InitPt pi IndLvl) 
         ) 
        ) 
        ((and (= HAlign -4152) (= VAlign -4107)) 
         (setq Align  9 
               InitPt (polar InitPt 0.0 Width) 
               InitPt (polar InitPt (* pi 1.5) Height) 
               InitPt (polar InitPt pi IndLvl) 
         ) 
        ) 
        (t nil) 
      ) 
      (setq Font   (vlax-get-property RangeObj 'Font) 
          FontName (vlax-variant-value (vlax-get-property Font 'Name)) 
      ) 
      (vlax-release-object Font) 
      (entmakex 
        (list 
          '(0 . "MText") 
          '(100 . "AcDbEntity") 
          '(100 . "AcDbMText") 
          (cons 1 (strcat "\\f" FontName ";" String)) 
          (cons 10 InitPt) 
          (cons 41 Width) 
          (cons 71 Align) 
        ) 
      ) 
    ) 
  ) 
  RetPnt 
) 
(defun c:test (/ ExcApp Wkbk Sheet URange Cells 
               InsPt Rows CeLst MArea MCells luPnt 
               ruPnt rlPnt RowH RowW MaAddr CeAddr Value 
              ) 
  (vl-load-com) 
  (alert "需要先打开被操作的Excel文件") 
  (setq ExcApp (vl-catch-all-apply 'vlax-get-object (list "Excel.Application"))) 
  (if (not (vl-catch-all-error-p ExcApp)) 
    (progn 
      (setq Wkbk (vl-catch-all-apply 'vlax-get-property (list ExcApp 'ActiveWorkbook))) 
      (if (vl-catch-all-error-p Wkbk) 
        (progn (princ "\n没有打开Excel文件") (vlax-release-object ExcApp)) 
        (progn 
          (setq        Sheet  (vlax-get-property Wkbk 'ActiveSheet) 
                URange (vlax-get-property Sheet 'UsedRange) 
                Cells  (vlax-get-property URange 'Cells) 
          ) 
          (if (and (= (vlax-get-property Cells 'Count) 1) 
                   (not (vlax-variant-value (vlax-get-property URange 'Value))) 
              ) 
            (progn (princ "\n当前工作表是空的") (mapcar 'vlax-release-object (list ExcApp Wkbk Sheet URange Cells))) 
            (progn 
              (if (setq InsPt (getpoint "\n指定表格的插入点<左上点>：")) 
                (progn 
                  (vlax-release-object Cells) 
                  (setq Rows  (vlax-get-property URange 'Rows) 
                        CeLst nil 
                        luPnt InsPt 
                  ) 
                  (vlax-for Item0 Rows 
                    (setq Cells (vlax-get-property Item0 'Cells)) 
                    (vlax-for Item1 Cells 
                      (setq MArea  (vlax-get-property Item1 'MergeArea) 
                            MaAddr (vlax-get-property MArea 'Address :vlax-true :vlax-true 1) 
                            CeAddr (vlax-get-property Item1 'Address :vlax-true :vlax-true 1) 
                      ) 
                      (cond 
                        ((equal MaAddr CeAddr) (setq luPnt (AYL-ControlMA MArea luPnt))) 
                        ((not (member CeAddr CeLst)) 
                         (setq MCells (vlax-get-property MArea 'Cells)) 
                         (vlax-for Item2 MCells 
                           (setq CeLst (append CeLst (list (vlax-get-property Item2 'Address :vlax-true :vlax-true 1)))) 
                         ) 
                         (vlax-release-object MCells) 
                         (setq luPnt (AYL-ControlMA MArea luPnt)) 
                        ) 
                        (t nil) 
                      ) 
                      (mapcar 'vlax-release-object (list Item1 MArea)) 
                    ) 
                    (setq RowH  (AYL-ConvertUnit (vlax-variant-value (vlax-get-property Item0 'Height))) 
                          RowW  (AYL-ConvertUnit (vlax-variant-value (vlax-get-property Item0 'Width))) 
                          luPnt (polar (polar luPnt pi RowW) (* pi 1.5) RowH) 
                    ) 
                    (mapcar 'vlax-release-object (list Item0 Cells)) 
                  ) 
                  (setq RowH (AYL-ConvertUnit (vlax-variant-value (vlax-get-property URange 'Height))) 
                        RowW (AYL-ConvertUnit (vlax-variant-value (vlax-get-property URange 'Width))) 
                        rlPnt (polar luPnt 0.0 RowW) 
                        ruPnt (polar rlPnt (* pi 0.5) RowH) 
                  ) 
                  (entmakex (list '(0 . "Line") (cons 10 luPnt) (cons 11 rlPnt))) 
                  (entmakex (list '(0 . "Line") (cons 10 ruPnt) (cons 11 rlPnt))) 
                  (mapcar 'vlax-release-object (list ExcApp Wkbk Sheet URange Rows)) 
                ) 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
    (princ "\n没有打开Excel应用程序") 
  ) 
  (princ) 
)

先把能用的代码发下，里面对绘制边框线的相关表达式需要调整

Free-Lancer · 发表于 2013-6-9 09:02:03

ayl1004 发表于 2013-6-9 08:53
先把能用的代码发下，里面对绘制边框线的相关表达式需要调整

你这还是边读取边绘制并写字，我的想法是读取和绘制分开，都写成子函数，这样主程序就简单了

ayl1004 · 发表于 2013-6-9 09:02:13

Free-Lancer 发表于 2013-6-9 08:45
读取Cell部分就原汁原味读出来，构造表，后期进行处理

你给的那个VBA好象没有对缩进进行处理，我大概用：缩进<0----15> * 3.0 * 6.25，再进行单位转换，不知道是否准。

Free-Lancer · 发表于 2013-6-9 09:07:26

ayl1004 发表于 2013-6-9 09:02
你给的那个VBA好象没有对缩进进行处理，我大概用：缩进 * 3.0 * 6.25，再进行单位转换，不知道是否准。

我先试试 VBA 能不能显示那些控制符，唉，VBA也是门外汉，有结果了再贴上来

ayl1004 · 发表于 2013-6-9 09:07:43

Free-Lancer 发表于 2013-6-9 09:02
你这还是边读取边绘制并写字，我的想法是读取和绘制分开，都写成子函数，这样主程序就简单了

呵呵，绘制边框我已经声明过了，要调整的，现在绘制出来的直线都是一条接一条，肯定要重新搞，现在都是为了测试对象的属性，别的没考虑。

Free-Lancer · 发表于 2013-6-9 09:09:53

本帖最后由 Free-Lancer 于 2013-6-9 09:18 编辑

ayl1004 发表于 2013-6-9 09:07
呵呵，绘制边框我已经声明过了，要调整的，现在绘制出来的直线都是一条接一条，肯定要重新搞，现在都是为 ...

前面我写的那个 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

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

ayl1004 · 发表于 2013-6-9 09:21:19

Free-Lancer 发表于 2013-6-9 08:38
只要将整个 String 读出来（带 Excel 的控制符，类似CAD的Mtext），这样在后面进行替换成 Autocad 的控制 ...

好象不行，返回的字符串不带控制符的

Free-Lancer · 发表于 2013-6-9 10:59:19

本帖最后由 Free-Lancer 于 2013-6-9 11:00 编辑

ayl1004 发表于 2013-6-9 09:21
好象不行，返回的字符串不带控制符的

刚录制了一段宏，可以看到格式控制符在哪里，现在就是 Vlisp 怎么得到 Characters

Range("B1").Select
ActiveCell.FormulaR1C1 = "aaaaadfdasf"
With ActiveCell.Characters(Start:=1, Length:=4).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With ActiveCell.Characters(Start:=5, Length:=4).Font
.Name = "宋体"
.FontStyle = "加粗"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With ActiveCell.Characters(Start:=9, Length:=2).Font
.Name = "宋体"
.FontStyle = "倾斜"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With ActiveCell.Characters(Start:=11, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("B1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("B5").Select
End Sub

Range("B1").Select 
    ActiveCell.FormulaR1C1 = "aaaaadfdasf" 
    With ActiveCell.Characters(Start:=1, Length:=4).Font 
        .Name = "宋体" 
        .FontStyle = "常规" 
        .Size = 11 
        .Strikethrough = False 
        .Superscript = False 
        .Subscript = False 
        .OutlineFont = False 
        .Shadow = False 
        .Underline = xlUnderlineStyleNone 
        .ThemeColor = xlThemeColorLight1 
        .TintAndShade = 0 
        .ThemeFont = xlThemeFontMinor 
    End With 
    With ActiveCell.Characters(Start:=5, Length:=4).Font 
        .Name = "宋体" 
        .FontStyle = "加粗" 
        .Size = 11 
        .Strikethrough = False 
        .Superscript = False 
        .Subscript = False 
        .OutlineFont = False 
        .Shadow = False 
        .Underline = xlUnderlineStyleNone 
        .ThemeColor = xlThemeColorLight1 
        .TintAndShade = 0 
        .ThemeFont = xlThemeFontMinor 
    End With 
    With ActiveCell.Characters(Start:=9, Length:=2).Font 
        .Name = "宋体" 
        .FontStyle = "倾斜" 
        .Size = 11 
        .Strikethrough = False 
        .Superscript = False 
        .Subscript = False 
        .OutlineFont = False 
        .Shadow = False 
        .Underline = xlUnderlineStyleNone 
        .ThemeColor = xlThemeColorLight1 
        .TintAndShade = 0 
        .ThemeFont = xlThemeFontMinor 
    End With 
    With ActiveCell.Characters(Start:=11, Length:=1).Font 
        .Name = "宋体" 
        .FontStyle = "常规" 
        .Size = 11 
        .Strikethrough = False 
        .Superscript = False 
        .Subscript = False 
        .OutlineFont = False 
        .Shadow = False 
        .Underline = xlUnderlineStyleNone 
        .ThemeColor = xlThemeColorLight1 
        .TintAndShade = 0 
        .ThemeFont = xlThemeFontMinor 
    End With 
    Range("B1").Select 
    With Selection 
        .HorizontalAlignment = xlCenter 
        .VerticalAlignment = xlCenter 
        .WrapText = False 
        .Orientation = 0 
        .AddIndent = False 
        .IndentLevel = 0 
        .ShrinkToFit = False 
        .ReadingOrder = xlContext 
        .MergeCells = False 
    End With 
    Range("B5").Select 
End Sub

ayl1004 · 发表于 2013-6-9 12:03:46

我以为自己突然变色盲了，还特意打开ACAD颜色系统看了看，晕，两个系统的颜色好象也不太一样，Excel里面字符串是红色的，得到的值也是1，可到了acad里，字符串的颜色就成了绿色的了。不只什么原因？

牢固 · 发表于 2013-6-9 13:15:30

本帖最后由牢固于 2013-6-14 18:30 编辑

花了两天时间，程序基本搞定！是仿照 KozMos XL2CAD 的程序同样写了一个Excel2CAD程序，控制对话框就直接照搬 KozMos XL2CAD的对话框，操作方式完全和他一样！
程序界面:

使用演示：

如果无法播放，请点击此处在新窗口打开

编译的Fas程序文件:

请点击此处下载

请先注册会员后在进行下载

已注册会员，请先登录后下载

文件名称:Excel2CAD.zip
下载次数:24 文件大小:28 KB 售价:20D豆 [记录]
下载权限: 学生以上 [免费赚D豆]

2013.06.14更新程序：
增加选择Excel文件功能
增加按Excel页面设置来分页输出表格功能！（包括页眉、页脚、表头等内容）

2013.06.12日更新，修正了一些Bug, 增加了表格实体颜色随层或随块的选项。更新了界面如下:

请大家来下载使用，使用过程中发现问题，多提出宝贵意见，等程序完善后，我再放出全部源码，下面是主程序源码:

游客，本帖隐藏的内容需要积分高于 50 才可浏览，您当前积分为 0

Free-Lancer · 发表于 2013-6-9 15:07:07

本帖最后由 Free-Lancer 于 2013-6-9 15:08 编辑

牢固发表于 2013-6-9 13:15
花了两天时间，程序基本搞定！是仿照 KozMos XL2CAD 的程序同样写了一个Excel2CAD程序，控制对话框就直接 ...

G版就是高效，出了些问题，Windows 7 + AutoCAD 2014 + Excel 2013 32位系统，提示错误

输入表格宽度<47859.66>:Automation 错误。未找到主键

附上一个测试表格，还是增加一个选择文件比较好

牢固 · 发表于 2013-6-9 15:49:56

本帖最后由牢固于 2013-6-9 15:51 编辑

Free-Lancer 发表于 2013-6-9 15:07
G版就是高效，出了些问题，Windows 7 + AutoCAD 2014 + Excel 2013 32位系统，提示错误

输入表格宽度: ...

我没有这个测试环境啊！
你这个表我在XP下 CAD2004和Excel2003下测试是没有问题的！
你在其他版本上运行会有问题吗！添加一个选择文件功能我随后更新！

maiqi816 · 发表于 2013-6-9 16:07:16

不具备分页功能，还有就是合并的单元格如何拆分。

yangist · 发表于 2013-6-9 16:20:50

好期待O~~~~~~~~

牢固 · 发表于 2013-6-9 16:33:16

maiqi816 发表于 2013-6-9 16:07
不具备分页功能，还有就是合并的单元格如何拆分。

"合并的单元格如何拆分"是什么意思？
程序功能是画表格，不是编辑表格！

账号		自动登录	找回密码
密码			立即注册

[已解决] 大家合力写个开源的EXCEL-CAD如何

点评

点评

点评

点评

点评

点评

点评

点评

点评