绘制横断面的代码出现参数错误
(vl-load-com)
(defun SORT-SE (SE DXF INT FUZZ K / ENT INDEX LST NEWLST
NEWSE TMP)
;;建立排序列表
(setq LST '()
INDEX
0
)
(repeat (sslength SE)
(setq ENT
(entget (ssname SE INDEX))
TMP (cdr (assoc DXF
ENT))
)
(if (and
INT
(= (type INT)
'INT)
(= (type TMP)
'list)
(< INT (length
TMP))
)
(setq TMP (nth INT
TMP))
)
(setq LST
(cons
(list TMP (cdr (assoc 5
ENT)))
LST
)
)
(setq INDEX (1+
INDEX))
)
;;排序操作
(if (and
FUZZ
(or
(= (type FUZZ)
'INT)
(= (type FUZZ)
'REAL)
)
(or
(= (type TMP)
'INT)
(= (type TMP)
'REAL)
)
)
(setq NEWLST
(vl-sort
LST
(function (lambda (E1
E2)
(< (+ (car E1) FUZZ) (car
E2))
)
)
)
)
(setq
NEWLST
(vl-sort LST
(function (lambda (E1 E2)
(< (car E1) (car
E2))
)
)
)
)
)
;;如果K为T，则倒置
(if
K
(setq NEWLST (reverse NEWLST))
)
;;组织排序后的选择集
(setq NEWSE (ssadd))
(foreach TMP
NEWLST
(setq NEWSE (ssadd (handent (cadr TMP))
NEWSE))
)
;;返回值
NEWSE
)
;_结束defun
;;;=============================================================
;;;测试
(defun
C:hdm (/ S1 S2 I SIZE)
(setq xy_list '())
(setq en_jz
(entsel "请选中基准线:"))
(setq en (entsel "选择一条直线:"))
(setq stp
(getpoint "请输入横断面起点："))
(setq size 0.1)
(SETQ S1 (ssget '((0
. "POINT"))))
(SETQ n 0)
;;;-------------------分配点表
--------
(repeat (sslength s1)
(setq lst (cons
(ssname s1 n) lst)
n (1+ n)
)
)
;;;---进行XY值比较计算后对列表排序----------------
(setq
x (mapcar '(lambda (x) (car (cdr (assoc 10 (entget
x))))) lst)
)
(setq
y (mapcar '(lambda (x) (cadr (cdr (assoc
10 (entget x)))))
lst
)
)
(setq maxx (eval (cons 'max x))
minx (eval (cons 'min
x))
)
(setq maxy (eval (cons 'max y))
miny
(eval (cons 'min y))
)
(setq dx (- maxx
minx)
dy (- maxy miny)
)
(princ dy)
(if
(> dx dy)
;;x坐标排序：
(setq S2
(SORT-SE S1 10 0 (* 0.6 SIZE) nil))
;;y坐标排序：
(setq S2 (SORT-SE S1 10 1 (* 0.6 SIZE)
t))
)
;;;-----------投影各点到断面线上-------------
(progn
(setq I 0)
(repeat (sslength
S2)
(setq pen_data (entget (ssname s2
i)))
(setq ppt (assoc 10
pen_data))
(setq pp (cdr
ppt))
(setq Perpt
(vlax-curve-getClosestPointTo (car en) pp T))
;;找出垂点
(entmake (APPEND '((0 .
"LINE")
(100 . "AcDbEntity")
(100 .
"AcDbLine")
(8 .
"0")
)
(LIST (CONS 10 pp) (CONS 11 perpt))
)
)
(princ
"\n")
(princ (cadddr (assoc 10 (entget (ssname
S2 I)))))
;;显示排序结果。
(if (= i
0)
(progn
(setq perpt1 perpt)
(setq mpt
(vlax-curve-getclosestpointTo (car en_jz) perpt1 t))
(setq st_jz
(distance perpt1 mpt))
(setq gc1 (cadddr (assoc 10 (entget
(ssname S2 I)))))
(setq xy_list (cons spt
xy_list))
)
(progn
(setq jl (distance perpt
perpt1))
(setq perpt1 perpt)
(setq gc2 (cadddr
(assoc 10 (entget (ssname S2 I)))))
(setq gaoc (- gc2
gc1))
;(setq gc1 gc2)
(setq x
(+ (car spt) jl))
(setq y (+ (cadr spt) gaoc))
(setq xpt (list x y))
(setq xy_list (cons xpt
xy_list))
)
)
(setq I (1+ I))
)
)
(setq xy_list (reverse xy_list))
(command
"pline" (foreach pt xy_list (command pt)))
(princ)
)
(setq x (mapcar '(lambda (x) (car (cdr (assoc 10 (entget x))))) lst))
==>
(setq x (mapcar '(lambda (e) (car (cdr (assoc 10 (entget e))))) lst))
(setq xy_list (cons spt xy_list))
spt无赋值
页:
[1]