社区 › AutoCAD与GIS测绘 › 路基水泥搅拌桩（CLRCLE）坐标导出并编号 ，73哥函数

树櫴希德 发表于 2015-9-7 16:26:45

路基水泥搅拌桩（CLRCLE）坐标导出并编号 ，73哥函数

路基水泥搅拌桩（CLRCLE）坐标导出并编号 ，73哥函数(defun makepl(argments);;argments==>(list pts 闭合标志 全局宽度 线宽 图层 颜色 厚度 线型)pts以后可省略
(entmakex(append(mapcar'cons'(0 100 100 43 370 8 62 39 6)(append'("LWPOLYLINE""AcDbEntity""AcDbPolyline")(cddr argments)))
      (cons(cons 90(length(car argments)))
         (cons(cons 70(if(cadr argments)(cadr argments)0))(mapcar'(lambda(x)(cons 10 x))(car argments)))))))
(defun poinpl(p pt);;:点是否在指定点表内
(equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8))
(defun plinexy(e)
(mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))
)
(defun SsgetW(arg / a);;选择指定矩形区域内(不限屏幕范围)
(ssget"X"(apply'append(list'((-4 . "<and")(-4 . ">=,>="))
         (setq a(list(car arg)(cadr arg))
         a(mapcar'(lambda(x)(mapcar x a))'(car cadr))
         a(mapcar'(lambda(y)(cons 10(mapcar'(lambda(x)(apply y x))a)))'(min max))
         a(list(car a)'(-4 . "<=,<=")(cadr a)))
         (cddr arg)
         '((-4 . "and>")))))
)
(defun SsgetCP(arg / a i pt s b);;根据多线段图元名或者其坐标点表进行(ssget"CP"...)但不限屏幕范围
(if(listp(setq a(car arg)))
    (setq pt a a(vlax-ename->vla-object(makepl(list pt))))
    (setq pt(plinexy a)a(vlax-ename->vla-object a)))
(if(setq i -1
   s(SsgetW(append(mapcar'(lambda(x)(mapcar'(lambda(y)(apply x y))
          (mapcar'(lambda(x)(mapcar x pt))'(car cadr))))'(min max))(cdr arg)))
   s(if(SSMEMB(vlax-vla-object->ename a)s)(ssdel(vlax-vla-object->ename a)s)s))
    (repeat(sslength s)
      (setq i(1+ i)e(ssname s i))
      (if(not(or(>(vlax-safearray-get-u-bound(vlax-variant-value(vla-intersectwith(vlax-ename->vla-object e)a 0))1)1)
    (poinpl(cdr(assoc 10(entget e)))pt)))
(setq b(cons e b)))))
(if(listp(car arg))(vla-Delete a))
(foreach a b(setq s(ssdel a s)))s)
(defun SsgetWP(arg / a i pt s b);;根据多线段图元名或者其坐标点表进行(ssget"WP"...)但不限屏幕范围
(if(listp(setq a(car arg)))
    (setq pt a a(vlax-ename->vla-object(makepl(list pt))))
    (setq pt(plinexy a)a(vlax-ename->vla-object a)))
(if(setq i -1
   s(SsgetW(append(mapcar'(lambda(x)(mapcar'(lambda(y)(apply x y))
          (mapcar'(lambda(x)(mapcar x pt))'(car cadr))))'(min max))(cdr arg)))
   s(if(SSMEMB(vlax-vla-object->ename a)s)(ssdel(vlax-vla-object->ename a)s)s))
    (repeat(sslength s)
      (setq i(1+ i)e(ssname s i))
      (if(or(>(vlax-safearray-get-u-bound(vlax-variant-value(vla-intersectwith(vlax-ename->vla-object e)a 0))1)1)
   (not(poinpl(cdr(assoc 10(entget e)))pt)))
(setq b(cons e b)))))
(if(listp(car arg))(vla-Delete a))
(foreach a b(setq s(ssdel a s)))s)



;;;
(defun maketext (zb gd /cld )
(setq cld (polar zb (* 0.25 pi) (* 2 gd) ))
(entmake (list
'(0 . "LINE")
'(67 . 0)
'(8 . "0")
(list 10 (car zb) (cadr zb) 0)
(cons 11 cld )
'(210 0.0 0.0 1.0)
)
)
;;;
(entmake (list
'(0 . "LINE")
'(67 . 0)
'(8 . "0")
(cons 10 cld)
(cons 11 ( polar cld 0 (* 10 gd)) )
'(210 0.0 0.0 1.0)
)
)
;;;;
(entmake (list
'(0 . "text")
(list 10 (+ (car cld) gd) (car(cdr cld)) )
(cons 40 gd)
(cons 1 ( strcat "X=" (rtos (cadr zb) 2 3)))
'(50 . 0)
)
)
(entmake (list
'(0 . "text")
(list 10 (+ (car cld) gd)
(- (car(cdr cld)) (+ gd (/ gd 3)) )
)
(cons 40 gd)
(cons 1 (strcat "Y="(rtos (car zb) 2 3)))
'(50 . 0)
)
)
(princ)
)
;
(defun maketext1 (zb gd /cld )
(setq cld (polar zb (* 0.25 pi) (* 2 gd) ))
(entmake (list
'(0 . "LINE")
'(67 . 0)
'(8 . "0")
(list 10 (car zb) (cadr zb) 0)
(cons 11 cld )
'(210 0.0 0.0 1.0)
)
)
;;;
(entmake (list
'(0 . "LINE")
'(67 . 0)
'(8 . "0")
(cons 10 cld)
(cons 11 ( polar cld 0 (* 10 gd)) )
'(210 0.0 0.0 1.0)
)
)
;;;;
(entmake (list
'(0 . "text")
(list 10 (+ (car cld) gd) (car(cdr cld)) )
(cons 40 gd)
(cons 1 ( strcat "X=" (rtos (/ (cadr zb) 1000) 2 3)))
'(50 . 0)
)
)
(entmake (list
'(0 . "text")
(list 10 (+ (car cld) gd)
(- (car(cdr cld)) (+ gd (/ gd 3)) )
)
(cons 40 gd)
(cons 1 (strcat "Y="(rtos (/ (car zb) 1000) 2 3)))
'(50 . 0)
)
)
(princ)
)

;货物分两组（样品 库存）
(defun lst->2lst(lst / lst1 lst2)
(setq lst1 '() lst2 '())
(foreach a lst
    (if (member a lst2)
      (setq lst1 (cons a lst1))
      (setq lst2 (cons a lst2))
    )
)
(cons (reverse lst2) (reverse lst1))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:gczbh1 (/ p qianzhui blc zg ss i lstt e kkkk ptlst ff sjzb xx ee zhuobiao lst )

(setq blc (getint "\n请输入比例尺1:"))
(setvar 'userr1 blc);设置比例尺
(setq zg(* 0.002 blc));字高
(setq ss (SsgetWP (list(car (entsel))'(0 . "circle") )) )
(setq i 0)
(setq lst '())


(repeat (sslength ss)
(setq insert_name (ssname ss i))
(setq sjzb (cdr (assoc 10(entget insert_name))))

;(setq e(get_inpoint insert_name))
   
(setq lst (append lst (list sjzb)))

(setq i (1+ i))
)
;(setq ptlst (HH:ssPts:Sort lst "xyz" 0.0))
;@树櫴希德 点表按照特定点逆时针排序~
(setq p (getpoint "\n指定排序方向"))
(setq qianzhui(getstring "\n请输入前缀："))
;(setq ptlst(mapcar 'cdr (vl-sort (mapcar 'cons (mapcar '(lambda(x) (angle x p)) lst) lst) '(lambda (x y) (< (car x) (car y))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq ptlst (vl-sort (car (lst->2lst (reverse lst)))
                   ;以下根据x坐标对表排序
   '(lambda (e1 e2)
            (< (car e1) (car e2) )
      (= (anglee1 p))   )   )    )
;;;;;;;;;;;;;;;;;-----------------------------------


(initget "1 2")
(prompt "\n坐标是否缩小1000倍:")
(setq kkkk (getkword "\n 1. 不用缩小1000倍　　\2. 缩小1000倍：<1>"))
(if (= kkkk nil) (setq kkkk "1"))
(setq ii 1)
(setqff (open (getfiled "请输入要保存的数据文件名" "" "dat" 1) "w"))
( cond ((= kkkk "1")
   (progn
(foreach n ptlst

   (entmake (list '(0 . "text") (cons 10 n) '(7 . "HZ") (cons 40 (* 1 zg))(cons 1 (strcat qianzhui (rtos ii 2 0))   )))
(maketext n (* 1 zg))
(write-line (strcat qianzhui (vl-princ-to-string ii)"," ","(vl-princ-to-string (car n)) ","(vl-princ-to-string (cadr n))","(vl-princ-to-string (caddr n))
) ff)

(setq ii (1+ ii))
    ) (close ff)))
( (= kkkk "2")
(progn
(foreach n ptlst

   (entmake (list '(0 . "text") (cons 10 n) '(7 . "HZ") (cons 40 (* 1000 zg))(cons 1 (strcat qianzhui (rtos ii 2 0))   )))
(maketext1 n (* 1000 zg))
(write-line (strcat qianzhui (vl-princ-to-string ii)"," ","(vl-princ-to-string (/ (car n) 1000)) ","(vl-princ-to-string (/ (cadr
n) 1000))","(vl-princ-to-string (/ (caddr n) 1000))
) ff)

(setq ii (1+ ii))
    )(close ff)
)
)

   

)







)

quester 发表于 2015-9-8 11:20:57

测绘版楼主出了好多实用的程序！

VBALISPER 发表于 2015-9-8 13:41:52

出成果了.赞一个

tigcat 发表于 2020-11-28 22:35:50

楼主出了几个桩基编号的程序，感觉都很棒。刚学lisp的人可能会有点摸不着头脑
简要说明：1、楼主示范gif是桩以m为单位展示的，比如桩直径0.4m，字高比例为0.002*你输入的1:X的X，如果你的图时mm为单位，X输10000以上可能才看的见字高。
2、前缀字符。如果图纸名称无“HZ”字体样式，则前缀字符在图纸中无法生成，但输出dat表中有
展望：这个程序由于具有选取多段线给多段线里面桩编号功能，可拓展为以承台为个体，按承台位置的上下左右排序，再以每个承台里面的桩上下左右编号。
总之，是个很棒的程序。开始使用时由于字体原因没摸着头脑，看到相关的代码后就顺畅了。楼主程序扩展性很强！

zst1978 发表于 2021-12-16 12:16:02

非常谢谢大侠分享

查看完整版本: 路基水泥搅拌桩（CLRCLE）坐标导出并编号 ，73哥函数