错误: DXF 组不正确: (10)

lyq子易 · 发表于 2013-10-30 23:19:00

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

(vl-load-com)
(defun c:lj ()
 (lyq-dgxlj)
)

;;; 等高线连接
(defun lyq-dgxlj ()
 (setq dgxss (ssget '(( 0 . "LWPOLYLINE")(8 . "dgx"))))
 (setq n 0)
 (setq leng 1000)
 (repeat (sslength dgxss)
(setq ssn (ssname dgxss n))
(setq ssn (vlax-ename->vla-object ssn))
(if (< (vla-get-Length ssn) leng)
 (setq leng (vla-get-Length ssn))
)
(setq n (1+ n))
 )
 (alert (strcat "请输入不大于最短线段长为：\n" (itoa (fix leng))
 "的阈值\n*****否则*****后果自负"
 )
 )
 (setq ds (getreal "\n请输入阈值：")) ; 获取最短线长度，设定阈值
 (setq n 0)
 (setq elemin (cdr (assoc 38 (entget (ssname dgxss 0)))))
 (setq elemax (cdr (assoc 38 (entget (ssname dgxss 0)))))
 (repeat (sslength dgxss)
(setq elevation (cdr (assoc 38 (entget (ssname dgxss n)))))
(setq elemin (min
 elemin
 elevation
 )
)
(setq elemax (max
 elemin
 elevation
 )
)
(setq n (1+ n))
 )
 (setq elevation elemin)
 (while (<= elevation elemax)
(setq dgxss1 (ssget "x" (list (CONS 0 "LWPOLYLINE")(cons 8 "dgx") (cons 38 elevation))))
(if (/= dgxss1 nil)
 (lyq-lianjie dgxss1 ds)
)
(setq elevation (1+ elevation))
 )
 (princ)
)

;;; ***********************************
;;; ***********************************
(defun lyq-lianjie(ss ds)
 (setq duandian ())
 (setq n 0)
 (repeat (sslength ss)
(setq ssn (ssname ss n))
(setq startp (lyq-startp ssn)
 endp (lyq-endp ssn)
)
(setq duandian (cons startp duandian))
(setq duandian (cons endp duandian))
(setq n (1+ n))
 ) ; 生成端点列表
 (setq n 0)
 (repeat (sslength ss)
(setq ssn (ssname ss n))
(setq startp (lyq-startp ssn)
 endp (lyq-endp ssn)
)
(setq duandian (vl-remove startp duandian))
(setq duandian (vl-remove endp duandian))
(setq neap (neapoint duandian startp))
(if (< mdist ds)
 (progn
(lyq-emove ssn startp neap)
(setq duandian (vl-remove neap duandian))
 )
)
(setq neap (neapoint duandian endp))
(if (< mdist ds)
 (progn
(lyq-emove ssn endp neap)
(setq duandian (vl-remove neap duandian))
 )
)
(setq n (1+ n))
 ) ; 移动符合条件的顶点
 (command "pedit" "m" ss "" "j" 0 "")
)

;;; 返回点表中距离点最近的点
(defun neapoint (pointlist point / m mpoint neap)
 (if (/= pointlist nil)
(progn
 (setq neap (car pointlist))
 (setq mdist (distance neap point))
 (setq m 0)
 (repeat (length pointlist)
(setq mpoint (nth m pointlist))
(setq dist (distance mpoint point))
(if (> mdist dist)
 (setq neap mpoint
mdist dist
 )
)
(setq m (1+ m))
 )
)
 )
 neap
)

;;; 将顶点e1移动至e2
(defun lyq-emove (obj e1 e2 / ent)
 (setq ent (entget obj))
 (setq ent (subst
 (cons '10 e2)
 (cons '10 e1)
 ent
 )
 )
 (entmod ent)
 (entupd obj)
)
(defun lyq-EndP (lw-obj)
 (lyq-3d->2d (vlax-curve-getendPoint lw-obj))
)

(defun lyq-StartP (lw-obj)
 (lyq-3d->2d (vlax-curve-getStartPoint lw-obj))
)

(defun lyq-3d->2d (3dpoint)
 (list (car 3dpoint) (cadr 3dpoint))
)

st788796 · 发表于 2013-10-31 07:57:24

本帖最后由 st788796 于 2013-10-31 08:07 编辑

大致看了下，先不说哪里错误，首先写的太乱，思路不能这样，要这样写，自己测试下
另外，DWG文件压缩为 RAR 再上传

(defun c:tt (/ ss len fuzz sl i el ll s);_变量一定要回收，否则有构造表的时候下次可
;能把上次的表内容加进来
;;实体列表转为选择集
(defun ents->ss (el / ss)
(setq ss (ssadd))
(foreach x el
(ssadd x ss)
)
ss
)
(if (and (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "DGX"))))
(> (sslength ss) 1) ;_加个判断，一般不会出现
(setq len (getdist "\n输入最小阀值: "))
(setq fuzz (getdist "\n输入最小间隙: "))
) ;_一次把条件都输入
(progn
(setq sl (sslength ss)
i sl
)
(repeat sl
(setq el (cons (ssname ss (setq i (1- i))) el))
) ;_这里仅构造实体列表
(setq el (vl-remove-if
'(lambda (x)
(< (vlax-curve-getdistatparam
x
(vlax-curve-getendparam x)
)
len
);_线长这样求
)
el
) ;_把短线移出
el (vl-sort el
'(lambda (e1 e2)
(< (cdr (assoc 38 (entget e1)))
(cdr (assoc 38 (entget e2)))
)
)
) ;_将pline 按标高排序，这样等高线是相邻的
)
;;接下来按标高分组
(setq ll (list (list (car el))))
(foreach x el
(if (equal (cdr (assoc 38 (entget x)))
(cdr (assoc 38 (entget (caar ll))))
)
(setq ll (cons (cons x (car ll)) (cdr ll)))
(setq ll (cons (list (list x)) ll))
) ;_按标高分成一个个子表
)
(foreach x ll;_依次处理每个标高组
(setq s (ents->ss x))
(command ".pedit" "m" s "" "j" fuzz "" "");_忘了哪个版本起有了这个 J 间隙选项
)
)
)
(princ)
)

(defun c:tt (/ ss len fuzz sl i el ll s);_变量一定要回收，否则有构造表的时候下次可 
     ;能把上次的表内容加进来 
  ;;实体列表转为选择集 
  (defun ents->ss (el / ss) 
    (setq ss (ssadd)) 
    (foreach x el 
      (ssadd x ss) 
    ) 
    ss 
  ) 
  (if (and (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "DGX")))) 
    (> (sslength ss) 1) ;_加个判断，一般不会出现 
    (setq len (getdist "\n输入最小阀值: ")) 
    (setq fuzz (getdist "\n输入最小间隙: ")) 
      ) ;_一次把条件都输入 
    (progn 
      (setq sl (sslength ss) 
     i  sl 
      ) 
      (repeat sl 
 (setq el (cons (ssname ss (setq i (1- i))) el)) 
      ) ;_这里仅构造实体列表 
      (setq el (vl-remove-if 
   '(lambda (x) 
      (< (vlax-curve-getdistatparam 
    x 
    (vlax-curve-getendparam x) 
         ) 
         len 
      );_线长这样求 
    ) 
   el 
        ) ;_把短线移出 
     el (vl-sort el 
   '(lambda (e1 e2) 
      (< (cdr (assoc 38 (entget e1))) 
         (cdr (assoc 38 (entget e2))) 
      ) 
    ) 
        ) ;_将pline 按标高排序，这样等高线是相邻的 
      ) 
      ;;接下来按标高分组 
      (setq ll (list (list (car el)))) 
      (foreach x el 
 (if (equal (cdr (assoc 38 (entget x))) 
     (cdr (assoc 38 (entget (caar ll)))) 
     ) 
   (setq ll (cons (cons x (car ll)) (cdr ll))) 
   (setq ll (cons (list (list x)) ll)) 
 ) ;_按标高分成一个个子表 
      ) 
      (foreach x ll;_依次处理每个标高组 
 (setq s (ents->ss x)) 
 (command ".pedit" "m" s "" "j" fuzz "" "");_忘了哪个版本起有了这个 J 间隙选项 
      ) 
    ) 
  ) 
  (princ) 
)

st788796 · 发表于 2013-10-31 09:18:37

本帖最后由 st788796 于 2013-10-31 09:26 编辑

如果用等效的 XDAPI + XD-Lisp-Lib 就像下面的程序

(defun c:tt (/ ss len fuzz el s)
(if (and (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "DGX"))))
(> (sslength ss) 1) ;_加个判断，一般不会出现
(setq len (getdist "\n输入最小阀值: "))
(setq fuzz (getdist "\n输入最小间隙: "))
)
(progn
(XD::Begin)
(setq el (mapcar '(lambda (x)
(list (xdrx_getpropertyvalue x "Elevation") x)
)
(xdrx_pickset->ents ss)
)
el (XD::List:GroupByIndex el 0)
)
(foreach x el
(setq s (XD::Entity->Pickset x))
;;(command-s ".pedit" "m" s "" "j" fuzz "");_高版本用这个更高效
(vl-cmdf ".pedit" "m" s "" "j" fuzz "")
)
)
(XD::End)
)
(princ)
)

lyq子易 · 发表于 2013-10-31 10:12:57

st788796 发表于 2013-10-31 07:57
大致看了下，先不说哪里错误，首先写的太乱，思路不能这样，要这样写，自己测试下
另外，DWG文件压缩为 RA ...

跟原来的作用不一样，麻烦测试下

风冷雨 · 发表于 2013-10-31 10:53:14

我分享下，用用，好用会回帖。。。。。

st788796 · 发表于 2013-10-31 21:17:20

http://bbs.xdcad.net/thread-671385-1-1.html

lyq子易 · 发表于 2013-11-1 09:21:00

本帖最后由 lyq子易于 2013-11-1 09:22 编辑

(defun c:tt (/ myerr olderr ss len fuzz sl i el ll s ents->ss modpl) ;_变量一定要回收，否则有构造表的时候下次可
 ;能把上次的表内容加进来
 (defun myerr ()
(setq *error* olderr
 myerr nil
)
(princ "\n*Cancel!")
(command ".undo" "end")
(princ)
 )
 ;;实体列表转为选择集
 (defun ents->ss (el / ss)
(setq ss (ssadd))
(foreach x el
 (ssadd x ss)
)
ss
 )
 (defun modpl (e p tf / el)
(setq el (entget e))
(if tf
 (entmod (subst (list 10 (car p) (cadr p))
 (assoc 10 el)
 el
 )
 )
 (entmod (reverse (subst (list 10 (car p) (cadr p))
 (assoc 10 (reverse el))
 (reverse el)
 )
 )
 )
)
 )
 (if (and (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "DGX"))))
 (> (sslength ss) 1) ;_加个判断，一般不会出现
 (setq len (getdist "\n输入最小阀值: "))
 (setq fuzz (getdist "\n输入最小间隙: "))
 ) ;_一次把条件都输入
(progn
 (setq olderr *error*
 *error* myerr
 )
 (command ".undo" "be")
 (setq sl (sslength ss)
 i sl
 )
 (repeat sl
 (setq el (cons (ssname ss (setq i (1- i))) el))
 ) ;_这里仅构造实体列表
 (setq el (vl-remove-if
 '(lambda (x)
 (< (vlax-curve-getdistatparam
 x
 (vlax-curve-getendparam x)
 )
 len
 )
 )
 el
 ) ;_把短线移出
 el (vl-sort el
 '(lambda (e1 e2)
 (< (cdr (assoc 38 (entget e1)))
 (cdr (assoc 38 (entget e2)))
 )
 )
 ) ;_将pline 按标高排序，这样等高线是相邻的
 )
 ;;接下来按标高分组
 (setq ll (list (list (car el))))
 (if (cdr el)
 (progn
 (foreach x (cdr el)
 (if (equal (cdr (assoc 38 (entget x)))
 (cdr (assoc 38 (entget (caar ll))))
 )
 (setq ll (cons (cons x (car ll)) (cdr ll)))
 (setq ll (cons (list x) ll))
 ) ;_按标高分成一个个子表
 )
 (setq ll
 (mapcar '(lambda (x / a b c sp ep lst p1 p2 xx)
 (setq xx x)
 (while x
 (setq a (car x)
 b (cdr x)
 sp (vlax-curve-getstartpoint a)
 ep (vlax-curve-getendpoint a)
 )
 (while b
 (setq c (car b)
 lst (list
 (vlax-curve-getstartpoint c)
 (vlax-curve-getendpoint c)
 )
 )
 (if (setq p1
 (vl-remove-if-not
 '(lambda (p) (equal sp p fuzz))
 lst
 )
 )
 (modpl a (car p1) t)
 )
 (if (setq p2
 (vl-remove-if-not
 '(lambda (p) (equal ep p fuzz))
 lst
 )
 )
 (modpl a (car p2) nil)
 )
 (setq b (cdr b))
 )
 (setq x (cdr x))
 )
 xx
 )
 (vl-remove-if '(lambda (l) (= (length l) 1)) ll)
 )
 )
 (foreach x ll
 (setq s (ents->ss x))
 (command ".pedit" "m" s "" "j" 0 "")
 )
 )
 )
 (command ".undo" "end")
 (setq *error* olderr)
)
 )
 (princ)
)F:\lisp\GIF动画录制\1.gif

lyq子易 · 发表于 2013-11-1 09:25:20

通过st788796一天的辛苦帮助，终于成型，嘿嘿，非常感谢

qq5225646 · 发表于 2020-12-9 09:08:07

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

[求助] 错误: DXF 组不正确: (10)

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

点评