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

Free-Lancer · 发表于 2013-6-7 09:08:50

绘制边框线

;;绘制表格边框线
;;参数： lst ---- ((p1 p2) (p3 p4) ... (pn-1 pn)
;;说明： obj 在主程序定义，可以是 Modelspace Blockdef Paperspace
(defun fy:Addline (lst)
(mapcar '(lambda (x)
(vla-addline
obj
(vlax-3d-point (car x))
(vlax-3d-point (cadr x))
)
)
lst
)
)

ayl1004 · 发表于 2013-6-7 11:20:11

Free-Lancer 发表于 2013-6-7 09:01
继续, 先写一个优化 Cell 边框的函数, 读取 Cell 边框坐标(仅有边框线部分), 将这些坐标构造一个表, 用下 ...

[pcode=lisp,true]
(defun c:tt (/ ExcApp RetLst Wkbk Sht UsedRange Cells Font)
  (vl-load-com)
  (alert "需要先打开被操作的Excel文件")
  (setq ExcApp (vl-catch-all-apply 'vlax-get-object (list "Excel.Application"))
RetLst nil
  )
  (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)
(vlax-release-object ExcApp)
(progn
(setq Sht (vlax-get-property Wkbk 'ActiveSheet)
  UsedRange (vlax-get-property Sht 'UsedRange)
  Cells    (vlax-get-property UsedRange 'Cells)
)
(vlax-for Item Cells
   (setq Font (vlax-get-property Item 'Font))
   (setq
   RetLst
      (cons
(cons
   (vlax-get-property Item 'Address :vlax-true :vlax-true 1)
   (mapcar
      'vlax-variant-value
      (mapcar
'vlax-get-property
         (list Font Font Font Font Font Font Font Font Font
      Font Item Item Item Item Item
)
(list 'Bold 'Color 'FontStyle 'Italic 'Name 'Size 'Strikethrough 'Subscript 'Superscript
      'Underline 'Value  'Height 'HorizontalAlignment 'VerticalAlignment 'Width
         )
      )
            )
)
      RetLst
      )
   )
   (mapcar 'vlax-release-object (list Item Font))
)
(mapcar 'vlax-release-object (list ExcApp Wkbk Sht UsedRange Cells))
)
   )
)
  )
  (reverse RetLst)
)
[/pcode]
我现在只能到这里了，有时间再完成

ayl1004 · 发表于 2013-6-7 11:26:37

当然，如果你已经搞定了，就没必要继续发源码，反正我也不需要。

eachy · 发表于 2013-6-7 11:35:15

ayl1004 发表于 2013-6-7 11:26
当然，如果你已经搞定了，就没必要继续发源码，反正我也不需要。

取消限制,去看看

ayl1004 · 发表于 2013-6-7 11:36:45

发个我写的操作Excel的函数

(defun GetExcelData (ExcFile Bianhao / ExcObj WBKs
XlsFile ActSht Range Cells return
return0 EveryRow First
)
(setq ExcObj (vlax-get-or-create-object "Excel.Application")
WBKs (vlax-get-property ExcObj 'WorkBooks)
XlsFile (vlax-invoke-method WBKs 'open ExcFile)
ActSht (vlax-get-property XlsFile 'ActiveSheet)
Range (vlax-get-property ActSht 'usedRange)
EveryRow (vlax-get-property Range 'Rows)
return nil
First nil
)
(vlax-for item EveryRow
(setq return (cons (vlax-get-property item 'Cells) return))
)
(setq return (reverse return))
(while (and return (/= First Bianhao))
(setq return0 nil)
(vlax-for item (car return)
(setq return0 (cons (vlax-get-property item 'value2) return0))
)
(setq First (vlax-variant-value (last return0))
return (cdr return)
)
)
(vlax-invoke-method WBKs 'close)
(mapcar 'vlax-release-object
(list ExcObj WBKs XlsFile ActSht Range EveryRow)
)
(if (= First Bianhao)
(mapcar 'vlax-variant-value (reverse return0))
)
)

(defun GetExcelData (ExcFile   Bianhao         /           ExcObj    WBKs 
                     XlsFile   ActSht         Range           Cells     return 
                     return0   EveryRow         First 
                    ) 
  (setq ExcObj    (vlax-get-or-create-object "Excel.Application") 
        WBKs         (vlax-get-property ExcObj 'WorkBooks) 
        XlsFile         (vlax-invoke-method WBKs 'open ExcFile) 
        ActSht         (vlax-get-property XlsFile 'ActiveSheet) 
        Range         (vlax-get-property ActSht 'usedRange) 
        EveryRow (vlax-get-property Range 'Rows) 
        return         nil 
        First         nil 
  ) 
  (vlax-for item EveryRow 
    (setq return (cons (vlax-get-property item 'Cells) return)) 
  ) 
  (setq return (reverse return)) 
  (while (and return (/= First Bianhao)) 
    (setq return0 nil) 
    (vlax-for item (car return) 
      (setq return0 (cons (vlax-get-property item 'value2) return0)) 
    ) 
    (setq First (vlax-variant-value (last return0)) 
            return (cdr return) 
    ) 
  ) 
  (vlax-invoke-method WBKs 'close) 
  (mapcar 'vlax-release-object 
          (list ExcObj WBKs XlsFile ActSht Range EveryRow) 
  ) 
  (if (= First Bianhao) 
    (mapcar 'vlax-variant-value (reverse return0)) 
  ) 
)

Free-Lancer · 发表于 2013-6-7 11:38:52

本帖最后由 Free-Lancer 于 2013-6-7 11:41 编辑

ayl1004 发表于 2013-6-7 11:36
发个我写的操作Excel的函数

站长帮忙取消了，初步想法是按行/列读取 cell，将文字构造一个表，边框线构造一个表，读完 sheet 后再进行后期处理，写字和绘制表格线

ayl1004 · 发表于 2013-6-7 12:29:21

Free-Lancer 发表于 2013-6-7 11:38
站长帮忙取消了，初步想法是按行/列读取 cell，将文字构造一个表，边框线构造一个表，读完 sheet 后再进 ...

我的想法是根据address和每个方框的长、宽，然后输入插入点来绘制方框。难点是字体，另外的都简单

ayl1004 · 发表于 2013-6-7 12:39:10

本帖最后由 ayl1004 于 2013-6-7 12:40 编辑

这是我对MText的了解，也是没完成的，不过论坛上有Lee的程序了。

(defun FindCtrl (ChrLst)
(if (cadr ChrLst)
(if (= (car ChrLst) "\")
(cons (strcat "\" (cadr ChrLst)) (FindCtrl (cddr ChrLst)))
(cons (car ChrLst) (FindCtrl (cdr ChrLst)))
)
ChrLst
)
)
(defun GetAllSubLsts (PreLst SttItem EndItem / TmpLst TorNil RetLst)
(setq TmpLst nil
TorNil 0
RetLst nil
)
(while (setq Item (car PreLst))
(setq TmpLst (append TmpLst (list Item))
PreLst (cdr PreLst)
)
(cond
((member Item SttItem) (setq TorNil (1+ TorNil)))
((member Item EndItem) (setq TorNil (1- TorNil)))
(t nil)
)
(if (= TorNil 2)
(setq TorNil 1)
)
(if (= TorNil -1)
(setq TorNil 0)
)
(if (= TorNil 0)
(setq RetLst (append RetLst (list TmpLst))
TmpLst nil
)
)
)
(if TmpLst
(append
RetLst
(mapcar 'list (vl-remove-if (function (lambda (x) (member x SttItem))) TmpLst))
)
RetLst
)
)
(defun c:SetMTextAtLineEditor (/ Ename EList String ChrLst StrLst)
(if (and (setq Ename (car (entsel)))
(= (cdr (assoc 0 (setq EList (entget Ename)))) "MTEXT")
)
(progn
(setq String (cdr (assoc 1 EList))
ChrLst (vl-string->list String)
ChrLst (mapcar 'chr ChrLst)
)
(setq ChrLst (FindCtrl ChrLst))
(setq StrLst (GetAllSubLsts ChrLst '("\\A" "\\C" "\\F" "\\H" "\\Q" "\\T" "\\W") '(";"))
ChrLst (mapcar (function (lambda (x) (apply 'strcat x))) StrLst)
StrLst (mapcar 'car (vl-remove-if (function (lambda (x) (member (car x) '("\\A" "\\C" "\\F" "\\H" "\\Q" "\\T" "\\W")))) StrLst))
StrLst (vl-remove-if (function (lambda (x) (member x '("{" "}" "\\O" "\\o" "\\L" "\\l")))) StrLst)
StrLst (subst " " "\\~" (subst "\n" "\\P" (subst "\" "\\\" StrLst)))
)
(if (member "\\S" StrLst)
(setq StrLst (GetAllSubLsts StrLst '("\\S") '(";"))
StrLst (mapcar
(function (lambda (x) (if (= (car x) "\\S") (vl-remove "/" (vl-remove "#" (vl-remove "^" (vl-remove ";" (vl-remove "\\S" x))))) x)))
StrLst
)
StrLst (apply 'append StrLst)
)
)
(apply 'strcat StrLst)
)
)
)

(defun FindCtrl        (ChrLst) 
  (if (cadr ChrLst) 
    (if        (= (car ChrLst) "\") 
      (cons (strcat "\" (cadr ChrLst)) (FindCtrl (cddr ChrLst))) 
      (cons (car ChrLst) (FindCtrl (cdr ChrLst))) 
    ) 
    ChrLst 
  ) 
) 
(defun GetAllSubLsts (PreLst SttItem EndItem / TmpLst TorNil RetLst) 
  (setq        TmpLst nil 
        TorNil 0 
        RetLst nil 
  ) 
  (while (setq Item (car PreLst)) 
    (setq TmpLst (append TmpLst (list Item)) 
          PreLst (cdr PreLst) 
    ) 
    (cond 
      ((member Item SttItem) (setq TorNil (1+ TorNil))) 
      ((member Item EndItem) (setq TorNil (1- TorNil))) 
      (t nil) 
    ) 
    (if        (= TorNil 2) 
      (setq TorNil 1) 
    ) 
    (if        (= TorNil -1) 
      (setq TorNil 0) 
    ) 
    (if        (= TorNil 0) 
      (setq RetLst (append RetLst (list TmpLst)) 
            TmpLst nil 
      ) 
    ) 
  ) 
  (if TmpLst 
    (append 
      RetLst 
      (mapcar 'list (vl-remove-if (function (lambda (x) (member x SttItem))) TmpLst)) 
    ) 
    RetLst 
  ) 
) 
(defun c:SetMTextAtLineEditor (/ Ename EList String ChrLst StrLst) 
  (if (and (setq Ename (car (entsel))) 
           (= (cdr (assoc 0 (setq EList (entget Ename)))) "MTEXT") 
      ) 
    (progn 
      (setq String (cdr (assoc 1 EList)) 
            ChrLst (vl-string->list String) 
            ChrLst (mapcar 'chr ChrLst) 
      ) 
       
      (setq ChrLst (FindCtrl ChrLst)) 
       
      (setq StrLst (GetAllSubLsts ChrLst '("\\A" "\\C" "\\F" "\\H" "\\Q" "\\T" "\\W") '(";")) 
            ChrLst (mapcar (function (lambda (x) (apply 'strcat x))) StrLst) 
            StrLst (mapcar 'car (vl-remove-if (function (lambda (x) (member (car x) '("\\A" "\\C" "\\F" "\\H" "\\Q" "\\T" "\\W")))) StrLst)) 
            StrLst (vl-remove-if (function (lambda (x) (member x '("{" "}"  "\\O" "\\o" "\\L" "\\l")))) StrLst) 
            StrLst (subst " " "\\~" (subst "\n" "\\P" (subst "\" "\\\" StrLst))) 
      ) 
      (if (member "\\S" StrLst) 
        (setq StrLst (GetAllSubLsts StrLst '("\\S") '(";")) 
              StrLst (mapcar 
                       (function (lambda (x) (if (= (car x) "\\S") (vl-remove "/" (vl-remove  "#" (vl-remove "^" (vl-remove ";" (vl-remove "\\S" x))))) x))) 
                       StrLst 
                     ) 
              StrLst (apply 'append StrLst) 
        ) 
      ) 
      (apply 'strcat StrLst) 
    ) 
  ) 
)

Lispboy · 发表于 2013-6-7 13:19:37

ayl1004 发表于 2013-6-7 12:29
我的想法是根据address和每个方框的长、宽，然后输入插入点来绘制方框。难点是字体，另外的都简单

你说的难点是字体，能具体说说吗？

Free-Lancer · 发表于 2013-6-7 14:33:42

本帖最后由 Free-Lancer 于 2013-6-7 15:07 编辑

ayl1004 发表于 2013-6-7 12:29
我的想法是根据address和每个方框的长、宽，然后输入插入点来绘制方框。难点是字体，另外的都简单

字体在开始那个 VBA 中有处理方式，还没有研究这个，Excel的控制符和 AutoCAD 的还是有区别，实在不行就用正则表达式处理

Sub wz()
Char = RTrim(Left(c.Characters.Caption, 256))
If Char <> Empty Then
textStr = ""
For j = 1 To Len(Char)
If c.Characters(j, 1).Font.Underline = xlUnderlineStyleNone Then
cpt = c.Characters(j, 1).Caption
sonstr = ForeFontStr(c, j)
tempstr = ""
Do While j + 1 <= Len(Char)
sonstr1 = ForeFontStr(c, j + 1)
If sonstr1 = sonstr Then
j = j + 1
tempstr = tempstr + c.Characters(j, 1).Caption
Else
Exit Do
End If
Loop
textStr = textStr + "{" + sonstr + cpt + tempstr + "}"
Else
cpt = c.Characters(j, 1).Caption
sonstr = ForeFontStr(c, j)
tempstr = ""
Do While j + 1 <= Len(Char)
sonstr1 = ForeFontStr(c, j + 1)
If sonstr1 = sonstr Then
j = j + 1
tempstr = tempstr + c.Characters(j, 1).Caption
Else
Exit Do
End If
Loop
textStr = textStr + "{\L" + sonstr + cpt + tempstr + "\l}"
End If
Next j
End If
End Sub
'下面函数控制字体本身属性
Function ForeFontStr(m As Range, u As Integer) As String
a1 = "\F" + m.Characters(u, 1).Font.Name + ";" '字体
a2 = IIf(m.Characters(u, 1).Font.Superscript = True, "\H0.33x;\A2;", "") '上脚标
a3 = IIf(m.Characters(u, 1).Font.Subscript = True, "\H0.33x;\A0;", "") '下脚标
a4 = IIf(m.Characters(u, 1).Font.FontStyle = "倾斜", "\Q18;", "") '倾斜
a5 = IIf(m.Characters(u, 1).Font.FontStyle = "加粗", "\W1.2;", "") '加粗
a6 = IIf(m.Characters(u, 1).Font.FontStyle = "加粗倾斜", "\W1.2;\Q18;", "") ' 加粗倾斜
ForeFontStr = a1 + a2 + a3 + a4 + a5 + a6
End Function

Sub wz() 
 Char = RTrim(Left(c.Characters.Caption, 256)) 
 If Char <> Empty Then 
   textStr = "" 
   For j = 1 To Len(Char) 
      If c.Characters(j, 1).Font.Underline = xlUnderlineStyleNone Then 
        cpt = c.Characters(j, 1).Caption 
        sonstr = ForeFontStr(c, j) 
        tempstr = "" 
        Do While j + 1 <= Len(Char) 
           sonstr1 = ForeFontStr(c, j + 1) 
           If sonstr1 = sonstr Then 
              j = j + 1 
             tempstr = tempstr + c.Characters(j, 1).Caption 
        Else 
             Exit Do 
        End If 
        Loop 
           textStr = textStr + "{" + sonstr + cpt + tempstr + "}" 
         Else 
           cpt = c.Characters(j, 1).Caption 
           sonstr = ForeFontStr(c, j) 
           tempstr = "" 
           Do While j + 1 <= Len(Char) 
               sonstr1 = ForeFontStr(c, j + 1) 
               If sonstr1 = sonstr Then 
                  j = j + 1 
                 tempstr = tempstr + c.Characters(j, 1).Caption 
          Else 
            Exit Do 
          End If 
         Loop 
            textStr = textStr + "{\L" + sonstr + cpt + tempstr + "\l}" 
      End If 
     Next j 
   End If 
End Sub 
'下面函数控制字体本身属性 
Function ForeFontStr(m As Range, u As Integer) As String 
 a1 = "\F" + m.Characters(u, 1).Font.Name + ";" '字体 
 a2 = IIf(m.Characters(u, 1).Font.Superscript = True, "\H0.33x;\A2;", "") '上脚标 
 a3 = IIf(m.Characters(u, 1).Font.Subscript = True, "\H0.33x;\A0;", "") '下脚标 
 a4 = IIf(m.Characters(u, 1).Font.FontStyle = "倾斜", "\Q18;", "") '倾斜 
 a5 = IIf(m.Characters(u, 1).Font.FontStyle = "加粗", "\W1.2;", "") '加粗 
 a6 = IIf(m.Characters(u, 1).Font.FontStyle = "加粗 倾斜", "\W1.2;\Q18;", "") ' 加粗倾斜 
 ForeFontStr = a1 + a2 + a3 + a4 + a5 + a6 
End Function

ayl1004 · 发表于 2013-6-7 17:46:05

Lispboy 发表于 2013-6-7 13:19
你说的难点是字体，能具体说说吗？

就是Font对象的属性，要慢慢测试

ayl1004 · 发表于 2013-6-7 17:48:10

Free-Lancer 发表于 2013-6-7 14:33
字体在开始那个 VBA 中有处理方式，还没有研究这个，Excel的控制符和 AutoCAD 的还是有区别，实在不行就 ...

VBA我真的看不懂，只会在lisp中调用:L

Lispboy · 发表于 2013-6-7 18:23:21

ayl1004 发表于 2013-6-7 17:46
就是Font对象的属性，要慢慢测试

得到文字了，和CAD当前的字体（或者指定一个字体），也得到了框的长度、高度，算下文字写多大的宽度不就解决了吗？

st788796 · 发表于 2013-6-7 18:57:33

本帖最后由 st788796 于 2013-6-7 18:58 编辑

有很多控制符的，加粗，倾斜，上划线，下划线，上标，下标，变字体，变颜色…等等，还有对齐方式

Free-Lancer · 发表于 2013-6-7 21:08:01

ayl1004 发表于 2013-6-7 11:20
(defun c:tt (/ ExcApp RetLst Wkbk Sht UsedRange Cells Font)
(vl-load-com)
(alert "需要先打 ...

大致看了下，不能一股脑的都读出来，那样不利于后期在Lisp中处理，我的想法是按列读取 Cells ，形成两个表，一个记录边线，另外一个记录文字。

对边线表，子表为每个单元格，元素为横线和竖线的坐标，属于合并后没有线的不记录，这个线段表供fy:sortln使用

文字表，记录字串和字串的坐标，这个可以供单独的写字程序调用。

遍历 Cells 部分好办，目前还需要准备几个函数，
1 文字格式处理（把Excel控制符改为AutoCAD规则的控制符）
2 写字程序
3 对单个cell 获取需求信息的函数

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

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

点评

点评

点评

评分

点评

点评

评分

点评

点评

点评

点评