批量宗地编号程序

yn1985321 · 发表于 2014-5-31 19:36:40

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

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

×

;这个程序是批量宗地编号程序，是从下至上，从右到左的，我想改成自上至下，从左到右。那位大神请帮改一下啊谢谢
(defun c:zdbh()
  (setq ss (ssget (list '(0 . "LWPOLYLINE"))))
  (setq n 0 k 1)
  (repeat (sslength ss)
(setq na (ssname ss n))
(setq po (Get_center_relative na))
(command "text" "j" "mc" po 2.5 0 k "")
(setq k (1+ k))
(setq n (1+ n))
)
  )
(defun Get_center_relative (ename /  Pts 2R Mk Mkline  points DelLine Tssred
   i lst  N  Newlst DistList    R Number  Tssbak TssSub  Pt)
(setq Obj    (Vlax-Ename->Vla-Object ename)
Tssbak  (Vlax-Get Obj 'Thickness )
TssSub  (Vlax-Put Obj 'Thickness 0 ))
(setq Pts    (GetBoundingBox ename)
2R    (MJ:MIDPOINT (CAR Pts) (CADR Pts))
Mk    (entmake (list (cons 0 "LINE")(cons 8 "JMDSS")(cons 10 (polar 2R 0.0 1000))(cons 11 (polar 2R 3.14159 1000))))
Mkline  (entlast)
points  (vlax-invoke (vlax-ename->vla-object ename) 'IntersectWith (vlax-ename->vla-object Mkline) acExtendOtherEntity)
Tssred  (Vlax-Put Obj 'Thickness (eval Tssbak) )
DelLine (entdel Mkline)
i    0
lst    nil
)
  (repeat (/ (length points) 3)
   (setq lst (append lst (list (list (nth i points) (nth (1+ i) points) (nth (+ 2 i) points)))))
   (setq i (+ i 3))
  )
  (setq lst (px lst))
  (if (>= (length lst) 4)
   (progn
(setq N    0
  Newlst nil)
(repeat (/ (length lst) 2)
   (setq Newlst (append Newlst (list (list (nth N lst) (nth (1+ N) lst)))))
   (setq N (+ 2 N))
)
(setq DistList nil
      R       0)
(repeat (length Newlst)
   (setq Number (nth R Newlst)
         DistList (append DistList  (list(distance (car Number) (cadr Number)))))
   (setq R (1+ R))
)
(setq  Pt (nth (vl-position (car (vl-sort DistList '>)) DistList) Newlst))
(MJ:MIDPOINT (car pt) (cadr pt));返回值
   )
   (MJ:MIDPOINT (car lst) (cadr lst));返回值
  )
)
(defun MJ:MIDPOINT (P1 P2)
  (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2)
)
(defun GetBoundingBox (ent / ll ur)
(vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
(mapcar 'vlax-safearray->list (list ll ur))
)
(defun px (X)
(vl-sort  X
         (function (lambda (e1 e2)
                     (< (car e1) (car e2)) ) ) )
)

st788796 · 发表于 2014-5-31 20:08:22

用xd::list:tablesort可以自己指定排序方式

st788796 · 发表于 2014-6-1 11:03:06

(defun c:tt (/ ss lst i)
(if (setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
(progn
(setq lst (mapcar '(lambda (x / box)
(setq box (xdrx_entity_box x))
(list
(xdrx_line_midp (car box) (caddr box))
x
)
)
(xdrx_pickset->ents ss)
)
lst (xd::list:tablesort lst 1 3 1e-3) ;_ 1 列 3 左上角
lst (mapcar '(lambda (x) (mapcar 'car x)) lst)
i 0
)
(foreach x lst
(foreach a x
(xdrx_text_make a (itoa (setq i (1+ i))) 25. 0.)
)
)
)
)
(princ)
)

yn1985321 · 发表于 2014-6-1 13:40:11

no function definition: XDRX_PICKSET->ENTS

yn1985321 · 发表于 2014-6-1 13:41:03

运行后出现这个no function definition: XDRX_PICKSET->ENTS

奶茶1号 · 发表于 2017-5-23 10:34:29

学习学习，厉害了

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

[研讨] 批量宗地编号程序

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