找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

楼主: Free-Lancer

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

[复制链接]

已领礼包: 3884个

财富等级: 富可敌国

发表于 2013-6-9 08:53:54 | 显示全部楼层
  1. (defun AYL-ConvertUnit (ENumber)
  2.   (/ (* ENumber 25.4) 72)
  3. )
  4. (defun AYL-ControlMA (RangeObj InitPt / Width Height RetPnt
  5.                       String HAlign
  6.                       VAlign IndLvl Align MaCells Font FontName
  7.                       )
  8.   (setq Width  (AYL-ConvertUnit (vlax-variant-value (vlax-get-property RangeObj 'Width)))
  9.         Height (AYL-ConvertUnit (vlax-variant-value (vlax-get-property RangeObj 'Height)))
  10.         RetPnt (polar InitPt 0.0 Width)
  11.         String nil
  12.         MaCells (vlax-get-property RangeObj 'Cells)
  13.   )
  14.   (vlax-for Item MaCells
  15.     (if (not String)
  16.       (setq String (vlax-variant-value (vlax-get-property Item 'Text)))
  17.     )
  18.     (vlax-release-object Item)
  19.   )
  20.   (vlax-release-object MaCells)
  21.   (entmakex (list '(0 . "Line") (cons 10 InitPt) (cons 11 RetPnt)))
  22.   (entmakex (list '(0 . "Line") (cons 10 InitPt) (cons 11 (polar InitPt (* pi 1.5) Height))))
  23.   (if String
  24.     (progn
  25.            (setq HAlign (vlax-variant-value (vlax-get-property RangeObj 'HorizontalAlignment))
  26.             VAlign (vlax-variant-value (vlax-get-property RangeObj 'VerticalAlignment))
  27.             IndLvl (AYL-ConvertUnit (* (vlax-variant-value (vlax-get-property RangeObj 'IndentLevel)) 3.0 6.25))
  28.       )
  29.        (cond ((= HAlign 1) (setq HAlign -4131))
  30.             ((= HAlign -4130) (setq HAlign -4108))
  31.             ((= HAlign -4117) (setq HAlign -4108))
  32.             ((= HAlign 5) (setq HAlign -4108))
  33.             (t nil)
  34.       )
  35.       (cond ((= VAlign -4130) (setq VAlign -4108))
  36.             ((= VAlign -4117) (setq VAlign -4108))
  37.             (t nil)
  38.       )
  39.       (cond
  40.         ((and (= HAlign -4131) (= VAlign -4160))
  41.          (setq Align 1
  42.                InitPt (polar InitPt 0.0 IndLvl)
  43.                )
  44.         )
  45.         ((and (= HAlign -4131) (= VAlign -4108))
  46.          (setq Align  4
  47.                InitPt (polar InitPt (* pi 1.5) (* Height 0.5))
  48.                InitPt (polar InitPt 0.0 IndLvl)
  49.          )
  50.         )
  51.         ((and (= HAlign -4131) (= VAlign -4107))
  52.          (setq Align  7
  53.                InitPt (polar InitPt (* pi 1.5) Height)
  54.                InitPt (polar InitPt 0.0 IndLvl)
  55.          )
  56.         )
  57.         ((and (= HAlign -4108) (= VAlign -4160))
  58.          (setq Align  2
  59.                InitPt (polar InitPt 0.0 (* Width 0.5))
  60.          )
  61.         )
  62.         ((and (= HAlign -4108) (= VAlign -4108))
  63.          (setq Align  5
  64.                InitPt (polar InitPt 0.0 (* Width 0.5))
  65.                InitPt (polar InitPt (* pi 1.5) (* Height 0.5))
  66.          )
  67.         )
  68.         ((and (= HAlign -4108) (= VAlign -4107))
  69.          (setq Align  8
  70.                InitPt (polar InitPt 0.0 (* Width 0.5))
  71.                InitPt (polar InitPt (* pi 1.5) Height)
  72.          )
  73.         )
  74.         ((and (= HAlign -4152) (= VAlign -4160))
  75.          (setq Align  3
  76.                InitPt (polar InitPt 0.0 Width)
  77.                InitPt (polar InitPt pi IndLvl)
  78.          )
  79.         )
  80.         ((and (= HAlign -4152) (= VAlign -4108))
  81.          (setq Align  6
  82.                InitPt (polar InitPt 0.0 Width)
  83.                InitPt (polar InitPt (* pi 1.5) (* Height 0.5))
  84.                InitPt (polar InitPt pi IndLvl)
  85.          )
  86.         )
  87.         ((and (= HAlign -4152) (= VAlign -4107))
  88.          (setq Align  9
  89.                InitPt (polar InitPt 0.0 Width)
  90.                InitPt (polar InitPt (* pi 1.5) Height)
  91.                InitPt (polar InitPt pi IndLvl)
  92.          )
  93.         )
  94.         (t nil)
  95.       )
  96.       (setq Font   (vlax-get-property RangeObj 'Font)
  97.           FontName (vlax-variant-value (vlax-get-property Font 'Name))
  98.       )
  99.       (vlax-release-object Font)
  100.       (entmakex
  101.         (list
  102.           '(0 . "MText")
  103.           '(100 . "AcDbEntity")
  104.           '(100 . "AcDbMText")
  105.           (cons 1 (strcat "\\f" FontName ";" String))
  106.           (cons 10 InitPt)
  107.           (cons 41 Width)
  108.           (cons 71 Align)
  109.         )
  110.       )
  111.     )
  112.   )
  113.   RetPnt
  114. )
  115. (defun c:test (/ ExcApp Wkbk Sheet URange Cells
  116.                InsPt Rows CeLst MArea MCells luPnt
  117.                ruPnt rlPnt RowH RowW MaAddr CeAddr Value
  118.               )
  119.   (vl-load-com)
  120.   (alert "需要先打开被操作的Excel文件")
  121.   (setq ExcApp (vl-catch-all-apply 'vlax-get-object (list "Excel.Application")))
  122.   (if (not (vl-catch-all-error-p ExcApp))
  123.     (progn
  124.       (setq Wkbk (vl-catch-all-apply 'vlax-get-property (list ExcApp 'ActiveWorkbook)))
  125.       (if (vl-catch-all-error-p Wkbk)
  126.         (progn (princ "\n没有打开Excel文件") (vlax-release-object ExcApp))
  127.         (progn
  128.           (setq        Sheet  (vlax-get-property Wkbk 'ActiveSheet)
  129.                 URange (vlax-get-property Sheet 'UsedRange)
  130.                 Cells  (vlax-get-property URange 'Cells)
  131.           )
  132.           (if (and (= (vlax-get-property Cells 'Count) 1)
  133.                    (not (vlax-variant-value (vlax-get-property URange 'Value)))
  134.               )
  135.             (progn (princ "\n当前工作表是空的") (mapcar 'vlax-release-object (list ExcApp Wkbk Sheet URange Cells)))
  136.             (progn
  137.               (if (setq InsPt (getpoint "\n指定表格的插入点<左上点>:"))
  138.                 (progn
  139.                   (vlax-release-object Cells)
  140.                   (setq Rows  (vlax-get-property URange 'Rows)
  141.                         CeLst nil
  142.                         luPnt InsPt
  143.                   )
  144.                   (vlax-for Item0 Rows
  145.                     (setq Cells (vlax-get-property Item0 'Cells))
  146.                     (vlax-for Item1 Cells
  147.                       (setq MArea  (vlax-get-property Item1 'MergeArea)
  148.                             MaAddr (vlax-get-property MArea 'Address :vlax-true :vlax-true 1)
  149.                             CeAddr (vlax-get-property Item1 'Address :vlax-true :vlax-true 1)
  150.                       )
  151.                       (cond
  152.                         ((equal MaAddr CeAddr) (setq luPnt (AYL-ControlMA MArea luPnt)))
  153.                         ((not (member CeAddr CeLst))
  154.                          (setq MCells (vlax-get-property MArea 'Cells))
  155.                          (vlax-for Item2 MCells
  156.                            (setq CeLst (append CeLst (list (vlax-get-property Item2 'Address :vlax-true :vlax-true 1))))
  157.                          )
  158.                          (vlax-release-object MCells)
  159.                          (setq luPnt (AYL-ControlMA MArea luPnt))
  160.                         )
  161.                         (t nil)
  162.                       )
  163.                       (mapcar 'vlax-release-object (list Item1 MArea))
  164.                     )
  165.                     (setq RowH  (AYL-ConvertUnit (vlax-variant-value (vlax-get-property Item0 'Height)))
  166.                           RowW  (AYL-ConvertUnit (vlax-variant-value (vlax-get-property Item0 'Width)))
  167.                           luPnt (polar (polar luPnt pi RowW) (* pi 1.5) RowH)
  168.                     )
  169.                     (mapcar 'vlax-release-object (list Item0 Cells))
  170.                   )
  171.                   (setq RowH (AYL-ConvertUnit (vlax-variant-value (vlax-get-property URange 'Height)))
  172.                         RowW (AYL-ConvertUnit (vlax-variant-value (vlax-get-property URange 'Width)))
  173.                         rlPnt (polar luPnt 0.0 RowW)
  174.                         ruPnt (polar rlPnt (* pi 0.5) RowH)
  175.                   )
  176.                   (entmakex (list '(0 . "Line") (cons 10 luPnt) (cons 11 rlPnt)))
  177.                   (entmakex (list '(0 . "Line") (cons 10 ruPnt) (cons 11 rlPnt)))
  178.                   (mapcar 'vlax-release-object (list ExcApp Wkbk Sheet URange Rows))
  179.                 )
  180.               )
  181.             )
  182.           )
  183.         )
  184.       )
  185.     )
  186.     (princ "\n没有打开Excel应用程序")
  187.   )
  188.   (princ)
  189. )

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

点评

你这还是边读取边绘制并写字,我的想法是读取和绘制分开,都写成子函数,这样主程序就简单了  详情 回复 发表于 2013-6-9 09:02
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2013-6-9 09:02:03 | 显示全部楼层
ayl1004 发表于 2013-6-9 08:53
先把能用的代码发下,里面对绘制边框线的相关表达式需要调整

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

点评

呵呵,绘制边框我已经声明过了,要调整的,现在绘制出来的直线都是一条接一条,肯定要重新搞,现在都是为了测试对象的属性,别的没考虑。  详情 回复 发表于 2013-6-9 09:07
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3884个

财富等级: 富可敌国

发表于 2013-6-9 09:02:13 | 显示全部楼层
Free-Lancer 发表于 2013-6-9 08:45
读取Cell部分就原汁原味读出来,构造表,后期进行处理

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

点评

我先试试 VBA 能不能显示那些控制符,唉,VBA也是门外汉,有结果了再贴上来  详情 回复 发表于 2013-6-9 09:07
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2013-6-9 09:07:26 | 显示全部楼层
ayl1004 发表于 2013-6-9 09:02
你给的那个VBA好象没有对缩进进行处理,我大概用:缩进 * 3.0 * 6.25,再进行单位转换,不知道是否准。

我先试试 VBA 能不能显示那些控制符,唉,VBA也是门外汉,有结果了再贴上来
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3884个

财富等级: 富可敌国

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

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

点评

前面我写的那个 Sortln 就是想合并这些一段段线条的,你看看  详情 回复 发表于 2013-6-9 09:09
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2013-6-9 09:09:53 | 显示全部楼层
本帖最后由 Free-Lancer 于 2013-6-9 09:18 编辑
ayl1004 发表于 2013-6-9 09:07
呵呵,绘制边框我已经声明过了,要调整的,现在绘制出来的直线都是一条接一条,肯定要重新搞,现在都是为 ...

前面我写的那个 Sortln 就是想合并这些一段段线条的,你看看这是一个完整的 VBA 转换,出来的线也是一段段的,没有优化,另外边读边画速度不快
  1. Option Explicit
  2. ' 方向系数
  3. Dim DirectionScale As Double
  4. ' 行高系数,磅
  5. Dim RowHeightScale As Double
  6. ' 列宽单位,1、字符,2、磅,默认为字符
  7. Dim ColumnWidthUnitType As Integer
  8. ' 列宽系数
  9. Dim ColumnWidthScale As Double
  10. ' 文字高度系数
  11. Dim TextHeightScale As Double
  12. Dim TableRange As Excel.Range

  13. Private Sub UserForm_Initialize()
  14.     ' 初始化,列宽采用字符为单位
  15.     RowHeightScale = 0.5
  16.     ColumnWidthUnitType = 1
  17.     ColumnWidthScale = 2
  18.     TextHeightScale = 0.3
  19. End Sub

  20. Private Sub cmdPickPt_Click()
  21.     Dim iPt As Variant

  22.     On Error GoTo ErrTrap
  23.     '隐藏窗体,注意与用户交互时必须先隐藏窗体,然后等待用户操作,最后显示窗体
  24.     Me.Hide
  25.     ' 返回选择或者输入的点
  26.     iPt = ThisDrawing.Utility.GetPoint(, "指定插入点: ")
  27.     TextBox1.Text = iPt(0)
  28.     TextBox2.Text = iPt(1)
  29.     iPt(2) = 0
  30.     ' 显示窗体
  31.     Me.Show
  32.     Exit Sub
  33.    
  34. ErrTrap:
  35.     ' 防止出错时窗体不显示
  36.     Me.Show
  37.     On Error GoTo 0
  38. End Sub

  39. Private Sub cmdOK_Click()
  40.     Dim iPt(0 To 2) As Double
  41.     Dim xlApp As Object
  42.     Dim xlSheet As Object
  43.    
  44.     ' 表格的插入点
  45.     iPt(0) = TextBox1.Text
  46.     iPt(1) = TextBox2.Text
  47.     iPt(2) = 0
  48.    
  49.     ' 发生错误时跳到下一个语句继续执行
  50.     On Error Resume Next
  51.     ' 连接Excel应用程序
  52.     Set xlApp = GetObject(, "Excel.Application")
  53.     If Err.Number <> 0 Then
  54.         MsgBox "Excel应用程序没有运行!"
  55.         Exit Sub
  56.     End If

  57.     ' 返回当前活动的工作表
  58.     Set xlSheet = xlApp.ActiveSheet
  59.    
  60.     ' 表格的转换方向
  61.     If OptionButton3.Value = True Then
  62.         DirectionScale = 1 ' 从上到下
  63.     Else
  64.         DirectionScale = -1 ' 从下到上
  65.     End If
  66.    
  67.     Dim r As Object
  68.     ' 表格的转换区域
  69.     If OptionButton1.Value = True Then ' 使用区域
  70.         Set TableRange = xlSheet.UsedRange
  71.         ' 遍历要转换的单元格区域
  72.         For Each r In xlSheet.UsedRange
  73.             ' 转换表格的边框
  74.             AddTableLine ThisDrawing.Blocks("*Model_Space"), iPt, r
  75.             ' 转换表格的文字
  76.             AddTableText ThisDrawing.Blocks("*Model_Space"), iPt, r
  77.         Next
  78.     Else ' 选中区域
  79.         Set TableRange = xlSheet.UsedRange
  80.         ' 遍历要转换的单元格区域
  81.         For Each r In xlApp.Selection
  82.             ' 转换表格的边框
  83.             AddTableLine ThisDrawing.Blocks("*Model_Space"), iPt, r
  84.             ' 转换表格的文字
  85.             AddTableText ThisDrawing.Blocks("*Model_Space"), iPt, r
  86.         Next
  87.     End If
  88.    
  89.     ' 更新
  90.     ThisDrawing.Regen acActiveViewport
  91.    
  92.     ' 释放对象
  93.     Set xlSheet = Nothing
  94.     Set xlApp = Nothing
  95.    
  96.     Unload Me
  97. End Sub

  98. Private Sub cmdCancel_Click()
  99.     Unload Me
  100. End Sub

  101. ' 给制单元格中的边框
  102. Sub AddTableLine(ByRef BlockObj As AcadBlock, ByVal iPt As Variant, ByVal xlRange As Range)
  103.     ' 记录单元格的位置和尺寸
  104.     Dim rl As Double
  105.     Dim rt As Double
  106.     Dim rw As Double
  107.     Dim rh As Double
  108.    
  109.     Dim sPt(0 To 2) As Double
  110.     Dim ePt(0 To 2) As Double
  111.     Dim pPt(0 To 3) As Double
  112.     Dim LineObj As AcadLine
  113.     Dim LWPLineObj As Object
  114.    
  115.     Dim i As Integer
  116.    
  117.     ' 单元格没有边框不做处理
  118.     If xlRange.Borders(xlEdgeLeft).LineStyle = xlNone _
  119.         And xlRange.Borders(xlEdgeBottom).LineStyle = xlNone _
  120.         And xlRange.Borders(xlEdgeRight).LineStyle = xlNone _
  121.         And xlRange.Borders(xlEdgeTop).LineStyle = xlNone Then Exit Sub
  122.         
  123.     If ColumnWidthUnitType = 1 Then
  124.         ' 字符单位时的列宽
  125.         For i = TableRange.Column To xlRange.Column - 1
  126.             rl = rl + TableRange.Columns(i).ColumnWidth * ColumnWidthScale
  127.         Next
  128.     ElseIf ColumnWidthUnitType = 2 Then
  129.         ' 磅单位时的列宽
  130.         rl = (xlRange.Left - TableRange.Left) * ColumnWidthScale
  131.     End If
  132.     rt = (xlRange.top - TableRange.top) * RowHeightScale
  133.     If ColumnWidthUnitType = 1 Then
  134.         rw = xlRange.ColumnWidth * ColumnWidthScale
  135.     ElseIf ColumnWidthUnitType = 2 Then
  136.         rw = xlRange.Width * ColumnWidthScale
  137.     End If
  138.     rh = xlRange.Height * RowHeightScale
  139.    
  140.     ' 左边框,只有第一列才转换,避免重复,因为单元格的右边框为右方单元格的左边框
  141.     If xlRange.Borders(xlEdgeLeft).LineStyle <> xlNone And xlRange.Column = TableRange.Column Then
  142.         If OptionButton5.Value = True Then
  143.             ' 创建直线
  144.             sPt(0) = iPt(0) + rl: sPt(1) = iPt(1) - rt * DirectionScale
  145.             ePt(0) = iPt(0) + rl: ePt(1) = iPt(1) - (rt + rh) * DirectionScale
  146.             Set LineObj = BlockObj.AddLine(sPt, ePt)
  147.             LineObj.color = LineColor(xlRange.Borders(xlEdgeLeft))
  148.         Else
  149.             ' 创建多段线
  150.             pPt(0) = iPt(0) + rl: pPt(1) = iPt(1) - rt * DirectionScale
  151.             pPt(2) = iPt(0) + rl: pPt(3) = iPt(1) - (rt + rh) * DirectionScale
  152.             Set LWPLineObj = BlockObj.AddLightWeightPolyline(pPt)
  153.             LWPLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeLeft))
  154.             LWPLineObj.color = LineColor(xlRange.Borders(xlEdgeLeft))
  155.         End If
  156.     End If
  157.    
  158.     ' 下边框,对于合并单元格的内部不转换
  159.     If xlRange.Borders(xlEdgeBottom).LineStyle <> xlNone And (xlRange.Row = xlRange.MergeArea.Row + xlRange.MergeArea.Rows.Count - 1) Then
  160.         If OptionButton5.Value = True Then
  161.             ' 创建直线
  162.             sPt(0) = iPt(0) + rl: sPt(1) = iPt(1) - (rt + rh) * DirectionScale
  163.             ePt(0) = iPt(0) + rl + rw: ePt(1) = iPt(1) - (rt + rh) * DirectionScale
  164.             Set LineObj = BlockObj.AddLine(sPt, ePt)
  165.             LineObj.color = LineColor(xlRange.Borders(xlEdgeLeft))
  166.         Else
  167.             ' 创建多段线
  168.             pPt(0) = iPt(0) + rl: pPt(1) = iPt(1) - (rt + rh) * DirectionScale
  169.             pPt(2) = iPt(0) + rl + rw: pPt(3) = iPt(1) - (rt + rh) * DirectionScale
  170.             Set LWPLineObj = BlockObj.AddLightWeightPolyline(pPt)
  171.             LWPLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeBottom))
  172.             LWPLineObj.color = LineColor(xlRange.Borders(xlEdgeBottom))
  173.         End If
  174.     End If
  175.    
  176.     ' 右边框,对于合并单元格的内部不转换
  177.     If xlRange.Borders(xlEdgeRight).LineStyle <> xlNone And (xlRange.Column >= xlRange.MergeArea.Column + xlRange.MergeArea.Columns.Count - 1) Then
  178.         If OptionButton5.Value = True Then
  179.             ' 创建直线
  180.             sPt(0) = iPt(0) + rl + rw: sPt(1) = iPt(1) - rt * DirectionScale
  181.             ePt(0) = iPt(0) + rl + rw: ePt(1) = iPt(1) - (rt + rh) * DirectionScale
  182.             Set LineObj = BlockObj.AddLine(sPt, ePt)
  183.             LineObj.color = LineColor(xlRange.Borders(xlEdgeLeft))
  184.         Else
  185.             ' 创建多段线
  186.             pPt(0) = iPt(0) + rl + rw: pPt(1) = iPt(1) - rt * DirectionScale
  187.             pPt(2) = iPt(0) + rl + rw: pPt(3) = iPt(1) - (rt + rh) * DirectionScale
  188.             Set LWPLineObj = BlockObj.AddLightWeightPolyline(pPt)
  189.             LWPLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeRight))
  190.             LWPLineObj.color = LineColor(xlRange.Borders(xlEdgeRight))
  191.         End If
  192.     End If
  193.    
  194.     ' 上边框,只有第一行才转换,避免重复,因为单元格的下边框为下方单元格的上边框
  195.     If xlRange.Borders(xlEdgeTop).LineStyle <> xlNone And xlRange.Row = TableRange.Row Then
  196.         If OptionButton5.Value = True Then
  197.             ' 创建直线
  198.             sPt(0) = iPt(0) + rl: sPt(1) = iPt(1) - rt * DirectionScale
  199.             ePt(0) = iPt(0) + rl + rw: ePt(1) = iPt(1) - rt * DirectionScale
  200.             Set LineObj = BlockObj.AddLine(sPt, ePt)
  201.             LineObj.color = LineColor(xlRange.Borders(xlEdgeLeft))
  202.         Else
  203.             ' 创建多段线
  204.             pPt(0) = iPt(0) + rl: pPt(1) = iPt(1) - rt * DirectionScale
  205.             pPt(2) = iPt(0) + rl + rw: pPt(3) = iPt(1) - rt * DirectionScale
  206.             Set LWPLineObj = BlockObj.AddLightWeightPolyline(pPt)
  207.             LWPLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeTop))
  208.             LWPLineObj.color = LineColor(xlRange.Borders(xlEdgeTop))
  209.         End If
  210.     End If
  211.    
  212.     Set LineObj = Nothing
  213.     Set LWPLineObj = Nothing
  214. End Sub

  215. ' 给制单元格中的文字
  216. Sub AddTableText(ByRef BlockObj As AcadBlock, ByVal iPt As Variant, ByVal xlRange As Range)
  217.     ' 记录单元格的位置和尺寸
  218.     Dim rl As Double
  219.     Dim rt As Double
  220.     Dim rw As Double
  221.     Dim rh As Double
  222.    
  223.     Dim tiPt(0 To 2) As Double
  224.     Dim TextObj As AcadText
  225.     Dim MTextObj As AcadMText
  226.     Dim tPt As Variant
  227.    
  228.     Dim i As Integer
  229.    
  230.     ' 单元格没有文字不做处理
  231.     If xlRange.Text = "" Then Exit Sub
  232.    
  233.     If ColumnWidthUnitType = 1 Then
  234.         ' 字符单位时的列宽
  235.         For i = TableRange.Column To xlRange.Column - 1
  236.             rl = rl + TableRange.Columns(i).ColumnWidth * ColumnWidthScale
  237.         Next
  238.     ElseIf ColumnWidthUnitType = 2 Then
  239.         ' 磅单位时的列宽
  240.         rl = (xlRange.Left - TableRange.Left) * ColumnWidthScale
  241.     End If
  242.     rt = (xlRange.top - TableRange.top) * RowHeightScale
  243.     If ColumnWidthUnitType = 1 Then
  244.         rw = xlRange.ColumnWidth * ColumnWidthScale
  245.     ElseIf ColumnWidthUnitType = 2 Then
  246.         rw = xlRange.Width * ColumnWidthScale
  247.     End If
  248.     rh = xlRange.MergeArea.Height * RowHeightScale
  249.    
  250.     tiPt(0) = iPt(0) + rl: tiPt(1) = iPt(1) - rt * DirectionScale: tiPt(2) = 0
  251.     If OptionButton7.Value = True Then
  252.         ' 创建单行文字
  253.         Set TextObj = BlockObj.AddText(xlRange.Text, tiPt, xlRange.Font.Size * TextHeightScale)
  254.         TextObj.color = TextColor(xlRange.Font)
  255.     Else
  256.         ' 创建多行文字
  257.         Set MTextObj = BlockObj.AddMText(tiPt, rw, xlRange.Text)
  258.         MTextObj.Height = xlRange.Font.Size * TextHeightScale
  259.         MTextObj.color = TextColor(xlRange.Font)
  260.     End If
  261.    
  262.     tiPt(0) = tiPt(0) + rw / 2: tiPt(1) = tiPt(1) - rh / 2 * DirectionScale: tiPt(2) = 0
  263.     If xlRange.VerticalAlignment = xlTop And (xlRange.HorizontalAlignment = xlLeft Or xlRange.HorizontalAlignment = xlGeneral) Then
  264.         ' 左上对齐
  265.         If OptionButton7.Value = True Then
  266.             TextObj.Alignment = acAlignmentTopLeft
  267.         Else
  268.             MTextObj.AttachmentPoint = acAttachmentPointTopLeft
  269.         End If
  270.         tPt = ThisDrawing.Utility.PolarPoint(tiPt, 3.1415926, rw / 2)
  271.         tPt = ThisDrawing.Utility.PolarPoint(tPt, 1.5707963, rh / 2)
  272.     ElseIf xlRange.VerticalAlignment = xlTop And xlRange.HorizontalAlignment = xlCenter Then
  273.         ' 中上对齐
  274.         If OptionButton7.Value = True Then
  275.             TextObj.Alignment = acAlignmentTopCenter
  276.         Else
  277.             MTextObj.AttachmentPoint = acAttachmentPointTopCenter
  278.         End If
  279.         tPt = ThisDrawing.Utility.PolarPoint(tiPt, 1.5707963, rh / 2)
  280.     ElseIf xlRange.VerticalAlignment = xlTop And xlRange.HorizontalAlignment = xlRight Then
  281.         ' 右上对齐
  282.         If OptionButton7.Value = True Then
  283.             TextObj.Alignment = acAlignmentTopRight
  284.         Else
  285.             MTextObj.AttachmentPoint = acAttachmentPointTopRight
  286.         End If
  287.         tPt = ThisDrawing.Utility.PolarPoint(tiPt, 0, rw / 2)
  288.         tPt = ThisDrawing.Utility.PolarPoint(tPt, 1.5707963, rh / 2)
  289.     ElseIf xlRange.VerticalAlignment = xlCenter And (xlRange.HorizontalAlignment = xlLeft _
  290.             Or xlRange.HorizontalAlignment = xlGeneral) Then
  291.         ' 左中对齐
  292.         If OptionButton7.Value = True Then
  293.             TextObj.Alignment = acAlignmentMiddleLeft
  294.         Else
  295.             MTextObj.AttachmentPoint = acAttachmentPointMiddleLeft
  296.         End If
  297.         tPt = ThisDrawing.Utility.PolarPoint(tiPt, 3.1415926, rw / 2)
  298.     ElseIf xlRange.VerticalAlignment = xlCenter And xlRange.HorizontalAlignment = xlCenter Then
  299.         ' 正中对齐
  300.         If OptionButton7.Value = True Then
  301.             TextObj.Alignment = acAlignmentMiddleCenter
  302.         Else
  303.             MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
  304.         End If
  305.         tPt = tiPt
  306.     ElseIf xlRange.VerticalAlignment = xlCenter And xlRange.HorizontalAlignment = xlRight Then
  307.         ' 右中对齐
  308.         If OptionButton7.Value = True Then
  309.             TextObj.Alignment = acAlignmentMiddleRight
  310.         Else
  311.             MTextObj.AttachmentPoint = acAttachmentPointMiddleRight
  312.         End If
  313.         tPt = ThisDrawing.Utility.PolarPoint(tiPt, 0, rw / 2)
  314.     ElseIf xlRange.VerticalAlignment = xlBottom And (xlRange.HorizontalAlignment = xlLeft _
  315.             Or xlRange.HorizontalAlignment = xlGeneral) Then
  316.         ' 左下对齐
  317.         If OptionButton7.Value = True Then
  318.             TextObj.Alignment = acAlignmentBottomLeft
  319.         Else
  320.             MTextObj.AttachmentPoint = acAttachmentPointBottomLeft
  321.         End If
  322.         tPt = ThisDrawing.Utility.PolarPoint(tiPt, 3.1415926, rw / 2)
  323.         tPt = ThisDrawing.Utility.PolarPoint(tPt, -1.5707963, rh / 2)
  324.     ElseIf xlRange.VerticalAlignment = xlBottom And xlRange.HorizontalAlignment = xlCenter Then
  325.         ' 中下对齐
  326.         If OptionButton7.Value = True Then
  327.             TextObj.Alignment = acAlignmentBottomCenter
  328.         Else
  329.             MTextObj.AttachmentPoint = acAttachmentPointBottomCenter
  330.         End If
  331.         tPt = ThisDrawing.Utility.PolarPoint(tiPt, -1.5707963, rh / 2)
  332.     ElseIf xlRange.VerticalAlignment = xlBottom And xlRange.HorizontalAlignment = xlRight Then
  333.         ' 右下对齐
  334.         If OptionButton7.Value = True Then
  335.             TextObj.Alignment = acAlignmentBottomRight
  336.         Else
  337.             MTextObj.AttachmentPoint = acAttachmentPointBottomRight
  338.         End If
  339.         tPt = ThisDrawing.Utility.PolarPoint(tiPt, 0, rw / 2)
  340.         tPt = ThisDrawing.Utility.PolarPoint(tPt, -1.5707963, rh / 2)
  341.     End If
  342.     If OptionButton7.Value = True Then
  343.         TextObj.TextAlignmentPoint = tPt
  344.     Else
  345.         MTextObj.InsertionPoint = tPt
  346.     End If
  347.    
  348.     Set TextObj = Nothing
  349.     Set MTextObj = Nothing
  350. End Sub

  351. '边框粗细
  352. Function LineWidth(ByVal xlBorder As Border) As Double
  353.     Select Case xlBorder.Weight
  354.         Case xlThin
  355.             LineWidth = 0
  356.         Case xlMedium
  357.             LineWidth = 0.35
  358.         Case xlThick
  359.             LineWidth = 0.7
  360.         Case Else
  361.             LineWidth = 0
  362.     End Select
  363. End Function

  364. '边框颜色,处理的颜色不全,请自己添加
  365. Function LineColor(ByVal xlBorder As Border) As Integer
  366.     Select Case xlBorder.ColorIndex
  367.         Case xlAutomatic
  368.             LineColor = acByLayer
  369.         Case 2
  370.             LineColor = acWhite
  371.         Case 3
  372.             LineColor = acRed
  373.         Case 5
  374.             LineColor = acBlue
  375.         Case 6
  376.             LineColor = acYellow
  377.          Case 7
  378.             LineColor = acMagenta
  379.         Case 10
  380.             LineColor = acGreen
  381.          Case 14
  382.             LineColor = acCyan
  383.         Case Else
  384.             LineColor = acByLayer
  385.     End Select
  386. End Function

  387. '文字颜色,处理的颜色不全,请自己添加
  388. Function TextColor(ByVal xlFont As Excel.Font) As Integer
  389.     Select Case xlFont.ColorIndex
  390.         Case xlAutomatic
  391.             TextColor = acByLayer
  392.         Case 2
  393.             TextColor = acWhite
  394.         Case 3
  395.             TextColor = acRed
  396.         Case 5
  397.             TextColor = acBlue
  398.         Case 6
  399.             TextColor = acYellow
  400.          Case 7
  401.             TextColor = acMagenta
  402.         Case 10
  403.             TextColor = acGreen
  404.          Case 14
  405.             TextColor = acCyan
  406.         Case Else
  407.             TextColor = acByLayer
  408.     End Select
  409. End Function

DVB文件
http://www.xdcad.net/forum/forum.php?mod=attachment&aid=MjQxN3xiZmE5MzgxN3wxMzcwNzQwMjM2fDE4NjA4fDY2ODY4Mw%3D%3D



论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3884个

财富等级: 富可敌国

发表于 2013-6-9 09:21:19 | 显示全部楼层
Free-Lancer 发表于 2013-6-9 08:38
只要将整个 String 读出来(带 Excel 的控制符,类似CAD的Mtext),这样在后面进行替换成 Autocad 的控制 ...

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

点评

刚录制了一段宏,可以看到格式控制符在哪里,现在就是 Vlisp 怎么得到  详情 回复 发表于 2013-6-9 10:59
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2013-6-9 10:59:19 | 显示全部楼层
本帖最后由 Free-Lancer 于 2013-6-9 11:00 编辑
ayl1004 发表于 2013-6-9 09:21
好象不行,返回的字符串不带控制符的

刚录制了一段宏,可以看到格式控制符在哪里,现在就是 Vlisp 怎么得到 Characters
  1. Range("B1").Select
  2.     ActiveCell.FormulaR1C1 = "aaaaadfdasf"
  3.     With ActiveCell.Characters(Start:=1, Length:=4).Font
  4.         .Name = "宋体"
  5.         .FontStyle = "常规"
  6.         .Size = 11
  7.         .Strikethrough = False
  8.         .Superscript = False
  9.         .Subscript = False
  10.         .OutlineFont = False
  11.         .Shadow = False
  12.         .Underline = xlUnderlineStyleNone
  13.         .ThemeColor = xlThemeColorLight1
  14.         .TintAndShade = 0
  15.         .ThemeFont = xlThemeFontMinor
  16.     End With
  17.     With ActiveCell.Characters(Start:=5, Length:=4).Font
  18.         .Name = "宋体"
  19.         .FontStyle = "加粗"
  20.         .Size = 11
  21.         .Strikethrough = False
  22.         .Superscript = False
  23.         .Subscript = False
  24.         .OutlineFont = False
  25.         .Shadow = False
  26.         .Underline = xlUnderlineStyleNone
  27.         .ThemeColor = xlThemeColorLight1
  28.         .TintAndShade = 0
  29.         .ThemeFont = xlThemeFontMinor
  30.     End With
  31.     With ActiveCell.Characters(Start:=9, Length:=2).Font
  32.         .Name = "宋体"
  33.         .FontStyle = "倾斜"
  34.         .Size = 11
  35.         .Strikethrough = False
  36.         .Superscript = False
  37.         .Subscript = False
  38.         .OutlineFont = False
  39.         .Shadow = False
  40.         .Underline = xlUnderlineStyleNone
  41.         .ThemeColor = xlThemeColorLight1
  42.         .TintAndShade = 0
  43.         .ThemeFont = xlThemeFontMinor
  44.     End With
  45.     With ActiveCell.Characters(Start:=11, Length:=1).Font
  46.         .Name = "宋体"
  47.         .FontStyle = "常规"
  48.         .Size = 11
  49.         .Strikethrough = False
  50.         .Superscript = False
  51.         .Subscript = False
  52.         .OutlineFont = False
  53.         .Shadow = False
  54.         .Underline = xlUnderlineStyleNone
  55.         .ThemeColor = xlThemeColorLight1
  56.         .TintAndShade = 0
  57.         .ThemeFont = xlThemeFontMinor
  58.     End With
  59.     Range("B1").Select
  60.     With Selection
  61.         .HorizontalAlignment = xlCenter
  62.         .VerticalAlignment = xlCenter
  63.         .WrapText = False
  64.         .Orientation = 0
  65.         .AddIndent = False
  66.         .IndentLevel = 0
  67.         .ShrinkToFit = False
  68.         .ReadingOrder = xlContext
  69.         .MergeCells = False
  70.     End With
  71.     Range("B5").Select
  72. End Sub

点评

我就是这样调用,但提示说:Automation错误,Range类不支持Characters属性。  发表于 2013-6-9 16:13
这样读取: (setq Characters (vlax-get-property range "Characters" start len))  发表于 2013-6-9 14:46
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3884个

财富等级: 富可敌国

发表于 2013-6-9 12:03:46 | 显示全部楼层
我以为自己突然变色盲了,还特意打开ACAD颜色系统看了看,晕,两个系统的颜色好象也不太一样,Excel里面字符串是红色的,得到的值也是1,可到了acad里,字符串的颜色就成了绿色的了。不只什么原因?
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 344个

财富等级: 日进斗金

发表于 2013-6-9 13:15:30 | 显示全部楼层
本帖最后由 牢固 于 2013-6-14 18:30 编辑

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

编译的Fas程序文件:
请点击此处下载

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

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

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

2013.06.14更新程序 :
增加选择Excel文件功能
增加按Excel页面设置来分页输出表格功能!(包括页眉、页脚、表头等内容) Excel2CAD1.jpg
2013.06.12日更新,修正了一些Bug, 增加了表格实体颜色随层或随块的选项。更新了界面如下:
Excel2CAD2.jpg
请大家来下载使用,使用过程中发现问题,多提出宝贵意见,等程序完善后,我再放出全部源码,下面是主程序源码:
游客,本帖隐藏的内容需要积分高于 50 才可浏览,您当前积分为 0





点评

换了个机子 Windows 7 + Excel 2010 + AutoCAD 2012 均为64位版,依然如上提示 命令: Excel表格->CAD表格 By Gu_xl 命令: X2C *** 2013.06.09 *** 命令: 命令: X2C 放置位置: 输入表格宽度: Automat  详情 回复 发表于 2013-6-10 08:30
G版就是高效,出了些问题,Windows 7 + AutoCAD 2014 + Excel 2013 32位系统,提示错误 输入表格宽度:Automation 错误。 未找到主键  详情 回复 发表于 2013-6-9 15:07
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 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 错误。 未找到主键

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

HGO与HDS2003平差坐标值比较表.rar

13.37 KB, 下载次数: 10, 下载积分: D豆 -1 , 活跃度 1

点评

我没有这个测试环境啊! 你这个表我在XP下 CAD2004和Excel2003下测试是没有问题的! 你在其他版本上运行会有问题吗!  详情 回复 发表于 2013-6-9 15:49
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 344个

财富等级: 日进斗金

发表于 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下测试是没有问题的!
你在其他版本上运行会有问题吗!添加一个选择文件功能我随后更新!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-6-9 16:07:16 | 显示全部楼层
不具备分页功能,还有就是合并的单元格如何拆分。

点评

"合并的单元格如何拆分"是什么意思? 程序功能是画表格,不是编辑表格!  详情 回复 发表于 2013-6-9 16:33
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-6-9 16:20:50 | 显示全部楼层
好期待O~~~~~~~~
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复

使用道具 举报

已领礼包: 344个

财富等级: 日进斗金

发表于 2013-6-9 16:33:16 来自手机 | 显示全部楼层
maiqi816 发表于 2013-6-9 16:07
不具备分页功能,还有就是合并的单元格如何拆分。

"合并的单元格如何拆分"是什么意思?
程序功能是画表格,不是编辑表格!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-11-23 06:24 , Processed in 0.246741 second(s), 59 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表