快速读取线条表格数据

dcl1214 · 发表于 2024-10-21 14:27:56

经常遇到一写表格需要读取，所以写了一个快速读取方法，但是，遇到杂乱的表格，我也写了一个，调用的是cgal来分析的（以后分享，需要cgal的支撑）

(defun $kxbg$ (pt1 pt2 lst / entitys $zheng-li$ msg $fen-zu$ pts result
fz ss xts)
;框选表格，非中线的表格，太烂的表格不行，还有一个函数$kxbg2$准确率高但是效率低
;示例$kxbg$ (getpoint) (getpoint) (list (CONS "标题位置" "顶部")(cons "选择集" (ssget))))
(defun $fen-zu$ (entitys / a b
coords current data datas
dxf-0 dxf-10 dxf-11 entdata
hf hori hori-line horzone
hr new-datas swap text-height
vertical vertical-line verzone
vf vr verzone-key
horzone-key h-jbs v-jbs
)
(foreach entity entitys
(setq entData (entget entity))
(setq dxf-0 (cdr (assoc 0 entData)))
(cond
((wcmatch dxf-0 "[,LINE,LWPOLYLINE,]")
(setq dxf-10 (cdr (assoc 10 entData)))
(setq dxf-11 (cdr (assoc 11 entData)))
(if (and (not dxf-11) (wcmatch dxf-0 "[,LWPOLYLINE,]"))
(progn
(setq dxf-11
(cdr (cadr (vl-remove-if-not
(function (lambda (a)
(member (car a) (list '10 '11))
)
)
entData
)
)
)
)
)
)
(progn
(cond ((< (abs (- (car dxf-10)
(car dxf-11)
)
)
0.18
) ;竖向直线
(setq
vertical (cons (car dxf-10) vertical)
)
(setq vertical-line (cons entity vertical-line))
)
((< (abs (- (cadr dxf-10)
(cadr dxf-11)
)
)
0.18
) ;水平直线
(setq hori (cons (cadr dxf-10) hori))
(setq hori-line (cons entity hori-line))
)
)
)
)
((and (eq dxf-0 "TEXT")
(cdr (assoc 1 entData))
(> (strlen (cdr (assoc 1 entData))) 0)
)
;表格内文字
(IF (= (cdr (assoc 1 entData)) "M30100866")
(PRINT)
)
(progn
(vla-getboundingbox
(vlax-ename->vla-object entity)
'a
'b
) ;外包围
(setq a (vlax-safearray->list a))
(setq b (vlax-safearray->list b))
;(makerec a b)
(setq
coords (mapcar (function (lambda (x y) (* (+ x y) 0.5)))
a
b
)
) ;居中点
(setq datas (cons (cons (cdr (assoc 1 entData))
coords
)
datas
)
)
)
)
)
)
(setq
v-jbs (mapcar (function (lambda (a) (cdr (assoc 5 (entget a)))))
vertical-line
)
)
(setq
h-jbs (mapcar (function (lambda (a) (cdr (assoc 5 (entget a)))))
hori-line
)
)
(setq swap nil)
(setq vertical (vl-sort vertical '<))
(while (progn (setq data (car vertical))
(setq vertical (cdr vertical))
)
(if (> (abs (- data (car vertical))) 0.18)
(setq swap (cons data swap))
)
)
(setq swap (cons data swap))
(setq vertical (reverse swap)
swap nil
)
(setq hori (vl-sort hori '<))
(while (progn (setq data (car hori))
(setq hori (cdr hori))
)
(if (> (abs (- data (car hori))) 0.18)
(setq swap (cons data swap))
)
)
(setq swap (cons data swap))
(setq hori (reverse swap))
(setq swap nil)
(setq verzone (mapcar 'list vertical (cdr vertical)))
(setq verzone-key
(mapcar
(function
(lambda (a i / key)
(cons i a)
)
)
verzone
(wire:range (length verzone))
)
)
(setq horzone (mapcar 'list hori (cdr hori)))
(setq horzone-key
(mapcar
(function
(lambda (a i / key)
(cons i a)
)
)
horzone
(wire:range (length horzone))
)
)
(IF horzone
()
(PRINT "horzone 空值")
)
(setq
datas (vl-sort datas
(FUNCTION (lambda (a b) (< (cadr a) (cadr b))))
)
)
(IF verzone
(PROGN
(setq current 0)
(setq new-datas '())
(foreach data datas
(setq current nil)
(setq current (VL-SOME
(FUNCTION
(LAMBDA (A / pts pt1 pt2)
(if (and
(setq pt1 (cadr a))
(setq pt2 (caddr a))
(and (> (cadr data) pt1)
(< (cadr data) pt2)
)
)
(car a)
)
)
)
verzone-key
)
)
(if current
(setq new-datas (cons (subst current (cadr data) data)
new-datas
)
)
)
)
)
)
(setq datas new-datas)
(setq
datas (vl-sort datas
(FUNCTION (lambda (a b) (< (caddr a) (caddr b))))
)
)
(setq current 0)
(setq new-datas '())
(foreach data datas
(setq current nil)
(setq current (VL-SOME
(FUNCTION
(LAMBDA (A / pts pt1 pt2)
(if (and
(setq pt1 (cadr a))
(setq pt2 (caddr a))
(and (> (caddr data) pt1)
(< (caddr data) pt2)
)
)
(car a)
)
)
)
horzone-key
)
)
(setq new-datas (cons (subst current (caddr data) data)
new-datas
)
)
)
(setq datas new-datas)
(setq new-datas '())
(foreach data datas
(PROGN
(if (and (car data)
(= (type (cadr data)) 'INT)
(= (type (caddr data)) 'INT)
)
(setq new-datas (cons (list (car data)
(cadr data)
(caddr data)
)
new-datas
)
)
)
)
)
(setq datas new-datas)
(setq new-datas '())
(setq datas (reverse datas))
(list datas
(list (cons "表格横向线条" h-jbs)
(cons "表格竖向线条" v-jbs)
)
)
)
(defun $zheng-li$ (dataz lst / a bts btwz data old old-cdr y y-key ys)
(SETQ BTWZ (CDR (ASSOC "标题位置" lst)))
(SETQ YS (MAPCAR 'CADDR dataz)) ;Y轴
(SETQ YS (DELSAME YS)) ;排重
(SETQ YS (VL-SORT YS '>)) ;排序
(SETQ Y-KEY NIL)
(while (setq a (car dataz))
(SETQ Y (CADDR A))
(SETQ OLD (ASSOC Y Y-KEY))
(SETQ OLD-CDR (CDR OLD))
(SETQ OLD-CDR (CONS A OLD-CDR))
(SETq Y-KEY (VL-REMOVE OLD Y-KEY))
(SETq Y-KEY (CONS (CONS Y OLD-CDR) Y-KEY))
(setq dataz (cdr dataz))
) ;按照Y轴建立KEY
(cond ((= BTWZ "底部") t) ;标题在底部的时候，rows不翻转(上面是cons拼接的，上面的被拼接到下面去了)
(t (setq Y-KEY (reverse Y-KEY)))
;默认标题在顶部，所以，这里翻转一下(上面是cons拼接的，上面的被拼接到下面去了，翻转后才能到上面去)
)
(SETQ DATA
(MAPCAR (FUNCTION (LAMBDA (A / A-CDR)
(SETQ A-CDR (CDR A))
(VL-SORT A-CDR
(FUNCTION (LAMBDA (E1 E2)
(< (CADR E1) (CADR E2))
)
)
)
)
)
Y-KEY
)
) ;每个X轴排序
(SETQ BTS (CAR DATA))
(MAPCAR
(FUNCTION
(lambda (A)
(MAPCAR (FUNCTION
(LAMBDA (B / tag v)
(setq tag (car b))
(setq
v (vl-some (function (lambda (c)
(if (= (cadr c) (cadr b))
;c的X轴等于B的X轴
(car c) ;返回第一个值
)
)
)
a
)
)
(or v (setq v ""))
(cons tag v)
)
)
BTS
)
)
)
(CDR DATA)
) ;整理数据
)
(setq msg (cdr (assoc "提示语" lst)))
(IF (and PT1 PT2)
()
(PROGN
(setq pts ($shu-biao-tuo-zhuai$ MSG)) ;获取用户鼠标框选的坐标
(SETQ PT1 (CAR PTS))
(SETQ PT2 (LAST PTS))
)
)
(or (and lst
(setq ss (cdr (assoc "选择集" lst)))
(setq entitys (vl-remove-if
(function listp)
(mapcar (function cadr) (ssnamex SS))
)
)
)
(and lst
(setq entitys (cdr (assoc "图元列表" lst)))
)
(and pt1
pt2
(SETQ
SS (ssget "CP"
(2PT->4PT (LIST pt1 pt2))
(LIST (CONS 0 "TEXT,LINE,LWPOLYLINE"))
)
)
(setq entitys (vl-remove-if
(function listp)
(mapcar (function cadr) (ssnamex SS))
)
)
)
)
(setq ss nil)
(setq fz nil)
(setq xts nil)
(mapcar 'set (list 'fz 'xts) ($fen-zu$ entitys)) ;分组
(setq result ($zheng-li$ fz lst)) ;整理
(setq result (mapcar (function (lambda (a) (append a xts))) result))
(setq ss nil)
result
)

(defun $kxbg$ (pt1 pt2 lst / entitys $zheng-li$  msg $fen-zu$ pts result 
         fz ss xts) 
          ;框选表格，非中线的表格，太烂的表格不行，还有一个函数$kxbg2$准确率高但是效率低 
  ;示例<img src="static/image/smiley/default/sad.gif" smilieid="2" border="0" alt="" />$kxbg$ (getpoint) (getpoint) (list (CONS "标题位置" "顶部")(cons "选择集" (ssget)))) 
  (defun $fen-zu$ (entitys    /     a      b 
       coords     current   data      datas 
       dxf-0      dxf-10   dxf-11      entdata 
       hf        hori   hori-line  horzone 
       hr        new-datas   swap      text-height 
       vertical   vertical-line      verzone 
       vf        vr   verzone-key 
       horzone-key     h-jbs      v-jbs 
      ) 
    (foreach entity entitys 
      (setq entData (entget entity)) 
      (setq dxf-0 (cdr (assoc 0 entData))) 
      (cond 
  ((wcmatch dxf-0 "[,LINE,LWPOLYLINE,]") 
   (setq dxf-10 (cdr (assoc 10 entData))) 
   (setq dxf-11 (cdr (assoc 11 entData))) 
   (if (and (not dxf-11) (wcmatch dxf-0 "[,LWPOLYLINE,]")) 
     (progn 
       (setq dxf-11 
        (cdr (cadr (vl-remove-if-not 
         (function (lambda (a) 
               (member (car a) (list '10 '11)) 
             ) 
         ) 
         entData 
             ) 
       ) 
        ) 
       ) 
     ) 
   ) 
   (progn 
     (cond ((< (abs (- (car dxf-10) 
           (car dxf-11) 
        ) 
         ) 
         0.18 
      )      ;竖向直线          
      (setq 
        vertical (cons (car dxf-10) vertical) 
      ) 
      (setq vertical-line (cons entity vertical-line)) 
     ) 
     ((< (abs (- (cadr dxf-10) 
           (cadr dxf-11) 
        ) 
         ) 
         0.18 
      )      ;水平直线         
      (setq hori (cons (cadr dxf-10) hori)) 
      (setq hori-line (cons entity hori-line)) 
     ) 
     ) 
   ) 
  ) 
  ((and (eq dxf-0 "TEXT") 
        (cdr (assoc 1 entData)) 
        (> (strlen (cdr (assoc 1 entData))) 0) 
   ) 
          ;表格内文字 
   (IF (= (cdr (assoc 1 entData)) "M30100866") 
     (PRINT) 
   ) 
   (progn 
     (vla-getboundingbox 
       (vlax-ename->vla-object entity) 
       'a 
       'b 
     )        ;外包围 
     (setq a (vlax-safearray->list a)) 
     (setq b (vlax-safearray->list b)) 
          ;(makerec a b) 
     (setq 
       coords (mapcar (function (lambda (x y) (* (+ x y) 0.5))) 
          a 
          b 
        ) 
     )        ;居中点 
     (setq datas (cons (cons (cdr (assoc 1 entData)) 
           coords 
           ) 
           datas 
           ) 
     ) 
   ) 
  ) 
      ) 
    ) 
    (setq 
      v-jbs (mapcar (function (lambda (a) (cdr (assoc 5 (entget a))))) 
        vertical-line 
      ) 
    ) 
    (setq 
      h-jbs (mapcar (function (lambda (a) (cdr (assoc 5 (entget a))))) 
        hori-line 
      ) 
    ) 
    (setq swap nil) 
    (setq vertical (vl-sort vertical '<)) 
    (while (progn (setq data (car vertical)) 
      (setq vertical (cdr vertical)) 
     ) 
      (if (> (abs (- data (car vertical))) 0.18) 
  (setq swap (cons data swap)) 
      ) 
    ) 
    (setq swap (cons data swap)) 
    (setq vertical (reverse swap) 
    swap     nil 
    ) 
    (setq hori (vl-sort hori '<)) 
    (while (progn (setq data (car hori)) 
      (setq hori (cdr hori)) 
     ) 
      (if (> (abs (- data (car hori))) 0.18) 
  (setq swap (cons data swap)) 
      ) 
    ) 
    (setq swap (cons data swap)) 
    (setq hori (reverse swap)) 
    (setq swap nil) 
    (setq verzone (mapcar 'list vertical (cdr vertical))) 
    (setq verzone-key 
     (mapcar 
       (function 
         (lambda (a i / key) 
     (cons i a) 
         ) 
       ) 
       verzone 
       (wire:range (length verzone)) 
     ) 
    ) 
    (setq horzone (mapcar 'list hori (cdr hori))) 
    (setq horzone-key 
     (mapcar 
       (function 
         (lambda (a i / key) 
     (cons i a) 
         ) 
       ) 
       horzone 
       (wire:range (length horzone)) 
     ) 
    ) 
    (IF  horzone 
      () 
      (PRINT "horzone 空值") 
    ) 
    (setq 
      datas (vl-sort datas 
         (FUNCTION (lambda (a b) (< (cadr a) (cadr b)))) 
      ) 
    ) 
    (IF  verzone 
      (PROGN 
  (setq current 0) 
  (setq new-datas '()) 
  (foreach data datas 
    (setq current nil) 
    (setq  current  (VL-SOME 
        (FUNCTION 
          (LAMBDA (A / pts pt1 pt2) 
            (if (and 
            (setq pt1 (cadr a)) 
            (setq pt2 (caddr a)) 
            (and (> (cadr data) pt1) 
           (< (cadr data) pt2) 
            ) 
          ) 
        (car a) 
            ) 
          ) 
        ) 
        verzone-key 
      ) 
    ) 
    (if current 
      (setq new-datas (cons (subst current (cadr data) data) 
          new-datas 
          ) 
      ) 
    ) 
  ) 
      ) 
    ) 
    (setq datas new-datas) 
    (setq 
      datas (vl-sort datas 
         (FUNCTION (lambda (a b) (< (caddr a) (caddr b)))) 
      ) 
    ) 
    (setq current 0) 
    (setq new-datas '()) 
    (foreach data datas 
      (setq current nil) 
      (setq current (VL-SOME 
          (FUNCTION 
      (LAMBDA  (A / pts pt1 pt2) 
        (if (and 
        (setq pt1 (cadr a)) 
        (setq pt2 (caddr a)) 
        (and (> (caddr data) pt1) 
             (< (caddr data) pt2) 
        ) 
            ) 
          (car a) 
        ) 
      ) 
          ) 
          horzone-key 
        ) 
      ) 
      (setq new-datas (cons (subst current (caddr data) data) 
          new-datas 
          ) 
      ) 
    ) 
    (setq datas new-datas) 
    (setq new-datas '()) 
    (foreach data datas 
      (PROGN 
  (if (and (car data) 
     (= (type (cadr data)) 'INT) 
     (= (type (caddr data)) 'INT) 
      ) 
    (setq  new-datas (cons  (list (car data) 
              (cadr data) 
              (caddr data) 
        ) 
        new-datas 
        ) 
    ) 
  ) 
      ) 
    ) 
    (setq datas new-datas) 
    (setq new-datas '()) 
    (setq datas (reverse datas)) 
    (list datas 
    (list  (cons "表格横向线条" h-jbs) 
    (cons "表格竖向线条" v-jbs) 
    ) 
    ) 
  ) 
  (defun $zheng-li$ (dataz lst / a bts btwz data old old-cdr y y-key ys) 
    (SETQ BTWZ (CDR (ASSOC "标题位置" lst))) 
    (SETQ YS (MAPCAR 'CADDR dataz))  ;Y轴 
    (SETQ YS (DELSAME YS))    ;排重 
    (SETQ YS (VL-SORT YS '>))    ;排序 
    (SETQ Y-KEY NIL) 
    (while (setq a (car dataz)) 
      (SETQ Y (CADDR A)) 
      (SETQ OLD (ASSOC Y Y-KEY)) 
      (SETQ OLD-CDR (CDR OLD)) 
      (SETQ OLD-CDR (CONS A OLD-CDR)) 
      (SETq Y-KEY (VL-REMOVE OLD Y-KEY)) 
      (SETq Y-KEY (CONS (CONS Y OLD-CDR) Y-KEY)) 
      (setq dataz (cdr dataz)) 
    )          ;按照Y轴建立KEY 
    (cond ((= BTWZ "底部") t)    ;标题在底部的时候，rows不翻转(上面是cons拼接的，上面的被拼接到下面去了) 
    (t (setq Y-KEY (reverse Y-KEY))) 
          ;默认标题在顶部，所以，这里翻转一下(上面是cons拼接的，上面的被拼接到下面去了，翻转后才能到上面去) 
    ) 
    (SETQ DATA 
     (MAPCAR (FUNCTION (LAMBDA (A / A-CDR) 
             (SETQ A-CDR (CDR A)) 
             (VL-SORT  A-CDR 
          (FUNCTION (LAMBDA (E1 E2) 
                (< (CADR E1) (CADR E2)) 
              ) 
          ) 
             ) 
           ) 
       ) 
       Y-KEY 
     ) 
    )          ;每个X轴排序 
    (SETQ BTS (CAR DATA)) 
    (MAPCAR 
      (FUNCTION 
  (lambda  (A) 
    (MAPCAR (FUNCTION 
        (LAMBDA (B / tag v) 
          (setq tag (car b)) 
          (setq 
      v (vl-some (function (lambda (c) 
                 (if (= (cadr c) (cadr b)) 
          ;c的X轴等于B的X轴 
             (car c) ;返回第一个值 
                 ) 
               ) 
           ) 
           a 
        ) 
          ) 
          (or v (setq v "")) 
          (cons tag v) 
        ) 
      ) 
      BTS 
    ) 
  ) 
      ) 
      (CDR DATA) 
    )          ;整理数据 
  ) 
  (setq msg (cdr (assoc "提示语" lst))) 
  (IF (and PT1 PT2) 
    () 
    (PROGN 
      (setq pts ($shu-biao-tuo-zhuai$ MSG)) ;获取用户鼠标框选的坐标   
      (SETQ PT1 (CAR PTS)) 
      (SETQ PT2 (LAST PTS)) 
    ) 
  ) 
  (or (and lst 
     (setq ss (cdr (assoc "选择集" lst))) 
     (setq entitys (vl-remove-if 
         (function listp) 
         (mapcar (function cadr) (ssnamex SS)) 
       ) 
     ) 
      ) 
      (and lst 
     (setq entitys (cdr (assoc "图元列表" lst))) 
      ) 
      (and pt1 
     pt2 
     (SETQ 
       SS  (ssget "CP" 
           (2PT->4PT (LIST pt1 pt2)) 
           (LIST (CONS 0 "TEXT,LINE,LWPOLYLINE")) 
    ) 
     ) 
     (setq entitys (vl-remove-if 
         (function listp) 
         (mapcar (function cadr) (ssnamex SS)) 
       ) 
     ) 
      ) 
  ) 
  (setq ss nil) 
  (setq fz nil) 
  (setq xts nil) 
  (mapcar 'set (list 'fz 'xts) ($fen-zu$ entitys)) ;分组 
  (setq result ($zheng-li$ fz lst))  ;整理 
  (setq result (mapcar (function (lambda (a) (append a xts))) result)) 
  (setq ss nil) 
  result 
)

自贡黄明儒 · 发表于 2024-10-21 15:02:01

感觉你这个简单了，因为代码太短，一般都喜欢长的

huisguiji · 发表于 2024-10-21 15:21:00

具体是做什么用的？

自贡黄明儒 · 发表于 2024-10-21 16:25:21

huisguiji 发表于 2024-10-21 15:21
具体是做什么用的？

嗯，楼主太懒了，应该有个动画

清水白粥 · 发表于 2024-10-21 19:35:05

APPLOAD 已成功加载 kxbg.lsp。
命令: ; 错误: 输入的字符串有缺陷

大佬，这个应该怎么解决

dcl1214 · 发表于 2024-10-22 09:52:34

自贡黄明儒发表于 2024-10-21 15:02
感觉你这个简单了，因为代码太短，一般都喜欢长的

我有调用cgal的代码，哪个准确率极高，效率低

dcl1214 · 发表于 2024-10-22 09:57:36

自贡黄明儒发表于 2024-10-21 16:25
嗯，楼主太懒了，应该有个动画

如果是倾斜的表格，需要用我的cte功能，cte功能做了很多判断，包括表格里面有合并单元格、倾斜等等

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

[经验] 快速读取线条表格数据

本帖子中包含更多资源

点评