500币求面积提取输出EXL

flytoday · 发表于 2011-12-12 19:30

本帖最后由 flytoday 于 2011-12-12 21:47 编辑

第一步：软件输入指定命令。。画a，b，c线，并能附于它长度属性值。

第二步：选取所画板中交叉线，定义板编号，弹出对话框，手工输入板厚值。

第三步：输入指定命令，属性提取输出EXL表

图纸图一输出图2

Gu_xl · 发表于 2011-12-12 19:30

本帖最后由 Gu_xl 于 2011-12-14 18:31 编辑

给你写了一段，看能否满足要求？为简便起见，输出的结果到CSV文件！
命令：TT 画十字交叉线，该命令将所划线自动变成无名块，并添加如下属性：板编号、板厚、a线长度、b线长度、c线长度，长度值默认为直线长度！，双击块可编辑属性，录入板编号、板厚
命令:tt1 自动输出cSV文件！文件默认存在"c:\\data.csv"

;;;构造匿名块
(defun MakeUnNameBlock (ss pt h a b c bh thickness / count entlist ent blk)
(setq pt (trans pt 1 0))
(entmake (list '(0 . "BLOCK")
'(2 . "*U")
'(70 . 3)
(cons 10 pt)
)
)
(setq count 0)
(repeat (sslength ss)
(setq entlist (entget (setq ent (ssname ss count))))
(setq count (1+ count))
(entmake entlist)
)
(setq count 0)
(repeat (sslength ss)
(setq ent (ssname ss count))
(setq count (1+ count))
(entdel ent)
)
(setq blk (entmake '((0 . "ENDBLK"))))
(regapp "flytoday")
(if blk
(progn
(entmake (list (cons 0 "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1) ;_ 属性跟随标志,1跟随，0不跟随
(cons 2 blk)
(cons 10 pt)
(cons 41 1.0)
(cons 42 1.0)
(cons 43 1.0)
'(-3 ("flytoday" (1000 . "flytoday")))
)
)
;;;插入板编号属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 pt)
(cons 40 h)
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 bh)
(cons 7 "Standard")
(cons 72 0)
(cons 11 pt)
'(100 . "AcDbAttribute")
(cons 2 "板编号")
(cons 70 0)
(cons 74 2)
)
)
;;;插入厚度属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (polar pt (* -0.5 pi) (* 1.5 h)))
(cons 40 h)
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 thickness)
(cons 7 "standard")
(cons 72 0)
(cons 11 (polar pt (* -0.5 pi) (* 1.5 h)))
'(100 . "AcDbAttribute")
(cons 2 "厚度")
(cons 70 0)
(cons 74 2)
)
)
;;;插入a线长度属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (polar pt (* -0.5 pi) (* 3 h)))
(cons 40 h)
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 a)
(cons 7 "standard")
(cons 72 0)
(cons 11 (polar pt (* -0.5 pi) (* 3 h)))
'(100 . "AcDbAttribute")
(cons 2 "a线长度")
(cons 70 1)
(cons 74 2)
)
)
;;;插入b线长度属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (polar pt (* -0.5 pi) (* 4.5 h)))
(cons 40 h)
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 b)
(cons 7 "standard")
(cons 72 0)
(cons 11 (polar pt (* -0.5 pi) (* 4.5 h)))
'(100 . "AcDbAttribute")
(cons 2 "b线长度")
(cons 70 1)
(cons 74 2)
)
)
(if c
;;;插入c线长度属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (polar pt (* -0.5 pi) (* 6 h)))
(cons 40 h)
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 c)
(cons 7 "standard")
(cons 72 0)
(cons 11 (polar pt (* -0.5 pi) (* 6 h)))
'(100 . "AcDbAttribute")
(cons 2 "c线长度")
(cons 70 1)
(cons 74 2)
)
)
)
;;;结束标志
(entmake '((0 . "SEQEND")))
)
)
blk
)
;;;构造线
(defun makeline (p1 p2)
(entmake (list (cons 0 "line")
(cons 10 (trans p1 1 0))
(cons 11 (trans p2 1 0))
)
)
)
;;;MakeText 生成文字函数,参数：标注点文字字高宽比旋转角倾角
(defun MakeText (xy Txt ZG KB XZ Qj / xyL TxtL ZGL KBL XZL QJL)
(setq xy (trans xy 1 0));;;坐标换算为世界坐标
(setq xyL (cons 10 xy)
TxtL (cons 1 Txt)
ZGL (cons 40 ZG)
KBL (cons 41 KB)
XZL (cons 50 XZ)
QJL (cons 51 QJ)
)
(setq TextL (list '(0 . "TEXT")
'(67 . 0)
'(100
.
"AcDbText"
)
xyL
ZGL
TxtL
XZL
KBL
QJL
'(7 . "standard")
)
)
(entmake TextL)
)
;;;计算两点的中点
(defun MidPoint (p1 p2)
(if (and (> (length p1) 2)(> (length p2) 2))
(list (* 0.5 (+ (car p1) (car p2))) (* 0.5 (+ (cadr p1) (cadr p2))) (* 0.5 (+ (caddr p1) (caddr p2))))
(list (* 0.5 (+ (car p1) (car p2))) (* 0.5 (+ (cadr p1) (cadr p2))))
)
)
;;;划线程序
(defun c:tt (/ OLDERR OSMODE CMDECHO ORTHOMODE
SS A B C P1 P2 P3
P4 P0 KD FLAG *error*
)
(defun *error* (msg)
(setq *error* olderr)
(Setvar "osmode" osmode)
(Setvar "cmdecho" cmdecho)
(Setvar "orthomode" orthomode)
(princ msg)
)
(setq olderr *error*)
(setq osmode (getvar "osmode"))
(Setvar "osmode" 687)
(setq cmdecho (getvar "cmdecho"))
(Setvar "cmdecho" 0)
(setq orthomode (getvar "orthomode"))
(Setvar "orthomode" 1)
(or txtHeight
(setq txtHeight (getreal "\n输入字高<2>:"))
)
(if (null txtHeight)
(setq txtHeight 2)
)
(while (not flag)
(setq ss (ssadd)
a nil
b nil
c nil
)
(princ "\n绘a线:")
(initget 7)
(setq p1 (getpoint "\n直线第一点:"))
(initget 7)
(setq p2 (getpoint p1 "\n直线第二点:"))
(makeline p1 p2)
(setq a (rtos (distance p1 p2) 2 3))
(ssadd (entlast) ss)
(MakeText (midpoint p1 (MidPoint p1 p2)) "a" txtHeight 0.8 0 0)
(ssadd (entlast) ss)
(princ "\n绘b线:")
(initget 7)
(setq p3 (getpoint "\n直线第一点:"))
(initget 7)
(setq p4 (getpoint p3 "\n直线第二点:"))
(makeline p3 p4)
(setq b (rtos (distance p3 p4) 2 3))
(ssadd (entlast) ss)
(MakeText (midpoint p3 (MidPoint p3 p4)) "b" txtHeight 0.8 0 0)
(ssadd (entlast) ss)
;(setq p0 (inters p1 p2 p3 p4 nil))
(setq p0 (midpoint
(apply 'mapcar (cons 'min (list p1 p2 p3 p4)))
(apply 'mapcar (cons 'max (list p1 p2 p3 p4)))
)
)
(progn
(princ "\n绘c线:")
(if (and
(setq p1 (getpoint "\n直线第一点:"))
(setq p2 (getpoint p1 "\n直线第二点:"))
)
(progn
(makeline p1 p2)
(ssadd (entlast) ss)
(setq c (rtos (distance p1 p2) 2 3))
(MakeText (midpoint p1 (MidPoint p1 p2)) "c" txtHeight 0.8 0 0)
(ssadd (entlast) ss)
)
)
(setq bh (getstring "\n板编号:"))
(setq thickness (getreal"\n厚度:"))
(if (null thickness) (setq thickness "") (setq thickness (rtos thickness 2 3)))
(MakeUnNameBlock ss p0 txtHeight a b c bh thickness)
(initget 7 "Yes No ")
(setq Kd (getkword "\n[继续Yes/No]<Yes>"))
(setq Flag (= kd "No"))
)
)
(setq *error* olderr)
(Setvar "osmode" osmode)
(Setvar "cmdecho" cmdecho)
(Setvar "orthomode" orthomode)
(princ)
)
;;;双击图块，通过属性输入板编号和厚度值
;;;导出数据(c:tt1)
(defun c:tt1 (/ SS F N EN LL ENL BBH THICKNESS A B C filename data)
(setq ss (ssget (list '(0 . "insert") '(-3 ("flytoday")))))
(if ss
(progn
(setq filename (getfiled "保存文件名" "data" "csv" 1))
(if filename
(progn
(if (findfile filename)
(setq f (open filename "a")) ;_ 文件已存在，自动追加
(progn
(setq f (open filename "w")) ;_ 文件不存在，新建文件
(write-line ",a,b,c,板厚" f)
)
)
(repeat (setq n (sslength ss))
(setq en (ssname ss (setq n (1- n))))
(setq ll nil)
(while
(and (setq en (entnext en))
(= "ATTRIB"
(cdr (assoc 0 (setq enl (entget en)))))
)
(setq ll (cons (cdr (assoc 1 enl)) ll))
)
(if ll
(progn
(setq data (cons (reverse ll) data))
)
)
)
(setq data
(vl-sort data
'(lambda (a b)
(< (atof (cadr a)) (atof (cadr b))))))
(foreach ll data
(setq bbh (car ll)
thickness (cadr ll)
a (caddr ll)
b (cadddr ll)
c (car (cddddr ll))
)
(WRITE-LINE
(strcat bbh
","
a
","
b
","
(if c
c
""
)
","
thickness
)
f
)
)
(close f)
;(startapp "notepad.exe" filename)
)
)
)
)
(princ)
)

;;;构造匿名块 
(defun MakeUnNameBlock (ss pt h a b c bh thickness / count entlist ent blk) 
(setq pt (trans pt 1 0)) 
  (entmake (list '(0 . "BLOCK") 
   '(2 . "*U") 
   '(70 . 3) 
   (cons 10 pt) 
    ) 
  ) 
  (setq count 0) 
  (repeat (sslength ss) 
    (setq entlist (entget (setq ent (ssname ss count)))) 
    (setq count (1+ count)) 
    (entmake entlist) 
  ) 
  (setq count 0) 
  (repeat (sslength ss) 
    (setq ent (ssname ss count)) 
    (setq count (1+ count)) 
    (entdel ent) 
  ) 
  (setq blk (entmake '((0 . "ENDBLK")))) 
  (regapp "flytoday") 
  (if blk 
    (progn 
      (entmake (list (cons 0 "INSERT") 
       '(100 . "AcDbEntity") 
       '(100 . "AcDbBlockReference") 
       '(66 . 1) ;_ 属性跟随标志,1跟随，0不跟随 
       (cons 2 blk) 
       (cons 10 pt) 
       (cons 41 1.0) 
       (cons 42 1.0) 
       (cons 43 1.0) 
       '(-3 ("flytoday" (1000 . "flytoday"))) 
        ) 
      ) 
;;;插入板编号属性 
      (entmake (list 
   '(0 . "ATTRIB") 
   '(100 . "AcDbEntity") 
   '(100 . "AcDbText") 
   (cons 10 pt) 
   (cons 40 h) 
   (cons 50 0) 
   (cons 41 0.8) 
   (cons 51 0) 
   (cons 1 bh) 
   (cons 7 "Standard") 
   (cons 72 0) 
   (cons 11 pt) 
   '(100 . "AcDbAttribute") 
   (cons 2 "板编号") 
   (cons 70 0) 
   (cons 74 2) 
        ) 
      ) 
;;;插入厚度属性 
      (entmake (list 
   '(0 . "ATTRIB") 
   '(100 . "AcDbEntity") 
   '(100 . "AcDbText") 
   (cons 10 (polar pt (* -0.5 pi) (* 1.5 h))) 
   (cons 40 h) 
   (cons 50 0) 
   (cons 41 0.8) 
   (cons 51 0) 
   (cons 1 thickness) 
   (cons 7 "standard") 
   (cons 72 0) 
   (cons 11 (polar pt (* -0.5 pi) (* 1.5 h))) 
   '(100 . "AcDbAttribute") 
   (cons 2 "厚度") 
   (cons 70 0) 
   (cons 74 2) 
        ) 
      ) 
;;;插入a线长度属性 
      (entmake (list 
   '(0 . "ATTRIB") 
   '(100 . "AcDbEntity") 
   '(100 . "AcDbText") 
   (cons 10 (polar pt (* -0.5 pi) (* 3 h))) 
   (cons 40 h) 
   (cons 50 0) 
   (cons 41 0.8) 
   (cons 51 0) 
   (cons 1 a) 
   (cons 7 "standard") 
   (cons 72 0) 
   (cons 11 (polar pt (* -0.5 pi) (* 3 h))) 
   '(100 . "AcDbAttribute") 
   (cons 2 "a线长度") 
   (cons 70 1) 
   (cons 74 2) 
        ) 
      ) 
;;;插入b线长度属性 
      (entmake (list 
   '(0 . "ATTRIB") 
   '(100 . "AcDbEntity") 
   '(100 . "AcDbText") 
   (cons 10 (polar pt (* -0.5 pi) (* 4.5 h))) 
   (cons 40 h) 
   (cons 50 0) 
   (cons 41 0.8) 
   (cons 51 0) 
   (cons 1 b) 
   (cons 7 "standard") 
   (cons 72 0) 
   (cons 11 (polar pt (* -0.5 pi) (* 4.5 h))) 
   '(100 . "AcDbAttribute") 
   (cons 2 "b线长度") 
   (cons 70 1) 
   (cons 74 2) 
        ) 
      ) 
      (if c 
;;;插入c线长度属性 
(entmake (list 
     '(0 . "ATTRIB") 
     '(100 . "AcDbEntity") 
     '(100 . "AcDbText") 
     (cons 10 (polar pt (* -0.5 pi) (* 6 h))) 
     (cons 40 h) 
     (cons 50 0) 
     (cons 41 0.8) 
     (cons 51 0) 
     (cons 1 c) 
     (cons 7 "standard") 
     (cons 72 0) 
     (cons 11 (polar pt (* -0.5 pi) (* 6 h))) 
     '(100 . "AcDbAttribute") 
     (cons 2 "c线长度") 
     (cons 70 1) 
     (cons 74 2) 
   ) 
) 
      ) 
;;;结束标志 
      (entmake '((0 . "SEQEND"))) 
    ) 
  ) 
  blk 
) 
;;;构造线 
(defun makeline (p1 p2) 
  (entmake (list (cons 0 "line") 
   (cons 10 (trans p1 1 0)) 
   (cons 11 (trans p2 1 0)) 
    ) 
  ) 
) 
;;;MakeText 生成文字函数,参数： 标注点 文字 字高 宽比 旋转角 倾角 
(defun MakeText (xy Txt ZG KB XZ Qj / xyL TxtL ZGL KBL XZL QJL) 
   (setq xy (trans xy 1 0));;;坐标换算为世界坐标 
      (setq xyL  (cons 10 xy) 
     TxtL (cons 1 Txt) 
     ZGL  (cons 40 ZG) 
     KBL  (cons 41 KB) 
     XZL  (cons 50 XZ) 
     QJL  (cons 51 QJ) 
      ) 
      (setq TextL (list '(0 . "TEXT") 
   '(67 . 0) 
   '(100 
     . 
     "AcDbText" 
    ) 
   xyL 
   ZGL 
   TxtL 
   XZL 
   KBL 
   QJL 
   '(7 . "standard") 
    ) 
      ) 
      (entmake TextL) 
    ) 
;;;计算两点的中点 
(defun MidPoint (p1 p2) 
  (if (and (> (length p1) 2)(> (length p2) 2)) 
      (list (* 0.5 (+ (car p1) (car p2))) (* 0.5 (+ (cadr p1) (cadr p2))) (* 0.5 (+ (caddr p1) (caddr p2)))) 
      (list (* 0.5 (+ (car p1) (car p2))) (* 0.5 (+ (cadr p1) (cadr p2)))) 
  )   
  ) 
;;;划线程序 
(defun c:tt (/      OLDERR  OSMODE  CMDECHO ORTHOMODE       
      SS      A      B      C      P1      P2      P3 
      P4      P0      KD      FLAG *error* 
     ) 
  (defun *error* (msg) 
    (setq *error* olderr) 
    (Setvar "osmode" osmode) 
    (Setvar "cmdecho" cmdecho) 
    (Setvar "orthomode" orthomode) 
    (princ msg) 
  ) 
  (setq olderr *error*) 
  (setq osmode (getvar "osmode")) 
  (Setvar "osmode" 687) 
  (setq cmdecho (getvar "cmdecho")) 
  (Setvar "cmdecho" 0) 
  (setq orthomode (getvar "orthomode")) 
  (Setvar "orthomode" 1) 
  (or txtHeight 
      (setq txtHeight (getreal "\n输入字高<2>:")) 
  ) 
  (if (null txtHeight) 
    (setq txtHeight 2) 
  ) 
  (while (not flag) 
    (setq ss (ssadd) 
   a  nil 
   b  nil 
   c  nil 
    ) 
    (princ "\n绘a线:") 
    (initget 7) 
    (setq p1 (getpoint "\n直线第一点:")) 
    (initget 7) 
    (setq p2 (getpoint p1 "\n直线第二点:")) 
    (makeline p1 p2) 
    (setq a (rtos (distance p1 p2) 2 3)) 
    (ssadd (entlast) ss) 
    (MakeText (midpoint p1 (MidPoint p1 p2)) "a" txtHeight 0.8 0 0) 
    (ssadd (entlast) ss) 
    (princ "\n绘b线:") 
    (initget 7) 
    (setq p3 (getpoint "\n直线第一点:")) 
    (initget 7) 
    (setq p4 (getpoint p3 "\n直线第二点:")) 
    (makeline p3 p4) 
    (setq b (rtos (distance p3 p4) 2 3)) 
    (ssadd (entlast) ss) 
    (MakeText (midpoint p3 (MidPoint p3 p4)) "b" txtHeight 0.8 0 0) 
    (ssadd (entlast) ss) 
    ;(setq p0 (inters p1 p2 p3 p4 nil)) 
    (setq p0 (midpoint 
        (apply 'mapcar (cons 'min (list p1 p2 p3 p4))) 
       (apply 'mapcar (cons 'max (list p1 p2 p3 p4))) 
        ) 
   ) 
    (progn 
(princ "\n绘c线:") 
(if (and 
       (setq p1 (getpoint "\n直线第一点:")) 
       (setq p2 (getpoint p1 "\n直线第二点:")) 
     ) 
   (progn 
     (makeline p1 p2) 
     (ssadd (entlast) ss) 
     (setq c (rtos (distance p1 p2) 2 3)) 
    (MakeText (midpoint p1 (MidPoint p1 p2)) "c" txtHeight 0.8 0 0) 
    (ssadd (entlast) ss) 
   ) 
) 
      (setq bh (getstring "\n板编号:")) 
      (setq thickness (getreal"\n厚度:")) 
      (if (null thickness) (setq thickness "") (setq thickness (rtos thickness 2 3))) 
(MakeUnNameBlock ss p0 txtHeight a b c bh thickness) 
(initget 7 "Yes No  ") 
(setq Kd (getkword "\n[继续Yes/No]<Yes>")) 
(setq Flag (= kd "No")) 
      ) 
  ) 
  (setq *error* olderr) 
  (Setvar "osmode" osmode) 
  (Setvar "cmdecho" cmdecho) 
  (Setvar "orthomode" orthomode) 
  (princ) 
) 
;;;双击图块，通过属性输入板编号和厚度值 
;;;导出数据(c:tt1) 
(defun c:tt1  (/ SS F N EN LL ENL BBH THICKNESS A B C filename data) 
  (setq ss (ssget (list '(0 . "insert") '(-3 ("flytoday"))))) 
  (if ss 
    (progn 
      (setq filename (getfiled "保存文件名" "data" "csv" 1)) 
      (if filename 
(progn 
   (if (findfile filename) 
     (setq f (open filename "a")) ;_ 文件已存在，自动追加 
     (progn 
       (setq f (open filename "w")) ;_ 文件不存在，新建文件 
       (write-line ",a,b,c,板厚" f) 
       ) 
     ) 
   (repeat (setq n (sslength ss)) 
     (setq en (ssname ss (setq n (1- n)))) 
     (setq ll nil) 
     (while 
       (and (setq en (entnext en)) 
     (= "ATTRIB" 
        (cdr (assoc 0 (setq enl (entget en))))) 
     ) 
        (setq ll (cons (cdr (assoc 1 enl)) ll)) 
        ) 
     (if ll 
       (progn 
  (setq data (cons (reverse ll) data)) 
  ) 
       ) 
     ) 
   (setq data 
   (vl-sort data 
     '(lambda (a b) 
        (< (atof (cadr a)) (atof (cadr b)))))) 
   (foreach ll  data 
     (setq bbh     (car ll) 
    thickness (cadr ll) 
    a     (caddr ll) 
    b     (cadddr ll) 
    c     (car (cddddr ll)) 
    ) 
     (WRITE-LINE 
       (strcat bbh 
        "," 
        a 
        "," 
        b 
        "," 
        (if c 
   c 
   "" 
   ) 
        "," 
        thickness 
        ) 
       f 
       ) 
     ) 
   (close f) 
;(startapp "notepad.exe" filename) 
   ) 
) 
      ) 
    ) 
  (princ) 
  )

flytoday · 发表于 2011-12-12 19:46

不知道哪位大侠愿意停下你的脚步研究下哈。。。
就算哪位大侠有兴趣挑战下哈。。。。。。。。。

【KAIXIN】 · 发表于 2011-12-12 19:51

顶一个高手出来，我对面积方面可是一窍不通！

flytoday · 发表于 2011-12-12 20:46

qjchen xpy1964院长的作品，你请他往下编下这个 :) 发表于 11 分钟前

院长啊偶哪请滴动晕。。

我等等。。。等，。。。。。

chpmould · 发表于 2011-12-12 21:08

完善这个还是有一定的工作量,LZ何不先自己试着折腾一下...

flytoday · 发表于 2011-12-12 21:18

折腾不了。。扑腾下也没有办法

完整武器 · 发表于 2011-12-12 22:12

算工程量？顶你哦

仲文玉 · 发表于 2011-12-12 22:50

财主

flytoday · 发表于 2011-12-12 23:08

本帖最后由 flytoday 于 2011-12-12 23:13 编辑

Gu_xl 老大谢谢您。。但是您那个。。字高我怎么输入后不会。体现a,b字样啊。。。
还有那个双击输入不了板编号与板厚啊
还有
这种情况不效啊

不过真很感谢您很热心了
能改改吗

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

500币求面积提取输出EXL

最佳答案

点评

相关帖子

评分

本帖子中包含更多资源