无聊，发几个小程序
最近又要写LISP程序了。一些小程序，供初学者参考。大侠就不要看了。;用多边形PL线范围窗选图元（DS）.lsp
(defun test (en / pt_list info pt_list x)
;(setq en (car (entsel "\nPlease select a polyline")))
(setq info(entget en))
(setq pt_lst (mapcar 'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 10) ) info )
)
)
(setq pt_lst pt_lst)
)
(defun c:ds()
(setq ent (car(entsel "\n选择一个多边形：")))
(setq pt_lst (test ent))
(setq ss(ssget"cp" pt_lst ))
(sssetfirst ss ss)
)
;图面所有圆转多段线.LSP,做GIS数据转换用。
(defun c:zz()
(command "undo" "be")
(setq os(getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setq ss(ssget "x" (list(cons 0 "circle"))))
(if ss
(progn
(setq ssnum(sslength ss)
i 0)
(repeat ssnum
(setq ent(ssname ss i)
info(entget ent)
center(cdr(assoc 10 info))
radius(cdr(assoc 40 info))
layer(cdr(assoc 8 info))
i (1+ i)
)
(command "layer" "s" layer "")
(command "polygon" 20 center "i" radius)
)
(command "erase" ss "" "")
(setvar "osmode" os)
(setvar "cmdecho" 1)
(command "undo" "e")
(princ "\n转换完成，共转换")(princ ssnum)(princ "个圆！")
)
(princ "\n当前图形中没有圆要素！")
)
(princ)
)
删除整个图面的重复要素（距离在0.05m以内）（ec）
说明：
1本程序可有效的删除0.05m以内的重复块、文本、圆。
2对于两条重复的线状地物，可删除顶点数目相同，对应顶点距离小于0.05m的重复线。
3如两条靠近的线的顶点数目相同，但对应顶点距离大于0.05m，则将一条线放到“不确定图层”，程序执行完毕后，请检查“不确定图层”内的线。
4本程序只判断相同顶点数目的两条线，故对于一条线重复了另外一条线的一部分的情况（此时这两条线的定点数目不一样），程序无法判断。再者，这种情况也有可能是正确的图形，所以只靠程序无法判断，只能人工检查。
5程序运行过程请不要在对图形执行任何操作，否则图面变动会引起程序出错。(defun c:ec()
(command "undo" "be")
(setvar "cmdecho" 0)
(command "zoom" "e")
(command "layer" "m" "不确定图层" "")
(VL-LOAD-COM)
(setq ss(ssget "x"))
(setq sslen(sslength ss))
(setq i 0)
(repeat sslen
(setq ent(ssname ss i))
(setq VOBJ (vlax-ename->vla-object ent))
(setq Y_N(vlax-erased-p VOBJ))
(if (= Y_N nil)
(progn
(setq info(entget ent)
leixing(cdr(assoc 0 info))
layer(cdr(assoc 8 info))
jidian(cdr(assoc 10 info))
ID (vla-get-handle VOBJ)
)
( vla-getboundingbox VOBJ 'maxzb 'minzb)
(setq maxzb (vlax-safearray->list maxzb))
(setq minzb (vlax-safearray->list minzb))
(setq ss2(ssget "c" maxzb minzb (list (cons 0 leixing) (cons 8 layer))))
(ssdel ent ss2)
(if (/= ss2 nil)
(progn
(setq sslen2(sslength ss2))
(setq j 0)
(repeat sslen2
(setq ent2(ssname ss2 j)
vobj2(vlax-ename->vla-object ent2)
id2(vla-get-handle VOBJ2)
)
(if (> (16to10 id2) (16to10 id))
(progn
(setq info2(entget ent2)
leixing2(cdr(assoc 0 info2))
layer2(cdr(assoc 8 info2))
jidian2(cdr(assoc 10 info2))
)
(setq dist(distance jidian2 jidian))
(if (= leixing2 leixing)
(if (= layer2 layer)
(if (< dist 0.05)
(progn
;块类型
(if (= leixing "INSERT")
(progn
(if (equal (assoc 2 info) (assoc 2 info2))
(command "erase" ent2 "")
)
)
)
;圆类型
(if (= leixing "CIRCLE")
(if (equal (assoc 40 info) (assoc 40 info2))
(command "erase" ent2 "")
)
)
;线类型
(if (or (= leixing"POLYLINE") (= leixing "LWPOLYLINE"))
(progn
(setq vtx (vla-get-Coordinates vobj))
(setq vtxlst (vlax-safearray->list (vlax-variant-value vtx)))
(setq vtx2 (vla-get-Coordinates vobj2))
(setq vtxlst2 (vlax-safearray->list (vlax-variant-value vtx2)))
(if (= (length vtxlst) (length vtxlst2))
(progn
(setq k 0)
(setq flat 0)
(repeat (/ (length vtxlst) 2)
(setq ptlst (list (nth k vtxlst) (nth (1+ k) vtxlst)))
(setq ptlst2(list (nth k vtxlst2) (nth (1+ k) vtxlst2)))
(if (> (distance ptlst ptlst2) 0.05)
(setq flat 1)
(setq k (+ k 2))
)
)
(if (= flat 0)
(command "erase" ent2 "")
(command "change" ent2 "" "p" "la" "不确定图层" "")
)
)
)
)
)
;直线类型
(if (= leixing "LINE")
(progn
(setq point1(cdr(assoc 11 info))
point2(cdr(assoc 11 info2))
)
(if (< (distance point1 point2) 0.05)
(command "erase" ent2 "")
)
))
;文本类型
(if (= leixing "TEXT")
(if (equal (assoc 1 info) (assoc 1 info2))
(command "erase" ent2 "")
)
)
;其他类型
(if (and (/= leixing "INSERT")(/= leixing "CIRCLE")(/= leixing"POLYLINE") (/= leixing "LWPOLYLINE")(/= leixing "TEXT")(/= leixing "LINE"))
(command "erase" ent2 "")
)
)
);基点距离小于0.05
);同层
);同型
);progn
);ent2创建时间迟于ent，ID2大于ID。
(setq j(1+ j))
);repeat ss2
);progn
);if
);progn
(setq ss2 null)
);ent在
(setq i(1+ i))
);repeat ss
(setvar "cmdecho" 0)
(command "undo" "e")
(princ "清理完毕！")
(alert "清理完毕！")
(princ)
)
;16进制转换位10进制
(defun 16to10(str / )
(setq len(strlen str))
(setq weizhi 1)
(setq num10 0)
(repeat len
(setq zifu(substr str weizhi 1))
(if (or (= zifu "A")(= zifu "a")) (setq zifu (ITOA 10)))
(if (or (= zifu "B")(= zifu "b")) (setq zifu (ITOA 11)))
(if (or (= zifu "C")(= zifu "c")) (setq zifu (ITOA 12)))
(if (or (= zifu "D")(= zifu "d")) (setq zifu (ITOA 13)))
(if (or (= zifu "E")(= zifu "e")) (setq zifu (ITOA 14)))
(if (or (= zifu "F")(= zifu "f")) (setq zifu (ITOA 15)))
(setq num10(+ num10(* (atoi zifu) (expt 16 (- len weizhi)))))
(setq weizhi(1+ weizhi))
)
(setq num10 num10)
)
查两个图层相交的点
;程序说明：程序运行之后不要再动鼠标或操作CAD了，否则程序会中断。
; 程序运行完毕后，会建立“交点图层”。在所有打架的地方画上1.5米半径的圆。
; 请使用“逐一查找”程序来处理打架的地方。
(defun c:dd()
(command "undo" "be")
(setvar "cmdecho" 0)
(vl-load-com)
(setq ent1 (entsel "\n选择图层1中的任一图元:"))
(setq lay1(cdr(assoc 8 (entget(car ent1)))))(princ "所选择的图层是")(princ lay1)
(setq ent2 (entsel "\n选择图层2中的任一图元:"))
(setq lay2(cdr(assoc 8 (entget(car ent2)))))(princ "所选择的图层是")(princ lay2)
(command "zoom" "e")
(command "_layer" "m" "交点图层" "c" 1 "" "")
(if (= lay1 lay2)
(progn
(print "\n你所选择的两个图元在同一层里，确认查同一层中交叉的情况吗？如果是请输入<Y>确认，否请按<ESC>键退出重来！")
(setq aa (getstring ))
;;; (if (or (= aa "Y" ) (= aa "y"))
;;; )
))
(princ "\n程序正在运行，请不要再操作CAD，否则会造成程序退出！请休息一下，耐心等候......")
(if (/= lay1 lay2)
(progn
(setq ss1(ssget "x" (list (cons 0"*LINE,ARC,CIRCLE,ELLIPSE")(cons 8 lay1))))
(setq ss2(ssget "x" (list (cons 0"*LINE,ARC,CIRCLE,ELLIPSE")(cons 8 lay2))))
(if (< (sslength ss1)(sslength ss2))
(progn
(setq ss ss1)
(setq lay lay2)
)
(progn
(setq ss ss2)
(setq lay lay1)
)
)
(setq i 0)
(repeat (sslength ss)
(setq ent1(ssname ss i))
(vla-getboundingbox(vlax-ename->vla-object ent1) 'll 'ur)
(setq ll(vlax-safearray->list ll))
(setq ur(vlax-safearray->list ur))
(defun c:zy()
(c:zy)
)
(defun c:zy()
(vl-load-com)
(if (setq ss(ssget "x" '((8 . "交点图层"))))
(progn
(setq
ent0(ssname ss 0)
ent(vlax-ename->vla-object ent0))
(vla-getboundingbox ent 'ptmin 'ptmax)
(setq ptmax(vlax-safearray->list ptmax)
ptmin(vlax-safearray->list ptmin)
)
(command "zoom" "w" ptmax ptmin)
(command "erase" ent0)
)
(princ"\n交点图层没有圆！")
)
(princ)
)
顶一下 不错的程序，支持源码共享 不错，希望您多无聊几次 本帖最后由 作者 于 2008-7-10 20:56:45 编辑 <br /><br /> <p>简化一点</p><p>;16进制转换位10进制<br/>(defun 16to10(str / )<br/> (setq len(strlen str))<br/> (setq weizhi 1)<br/> (setq num10 0)<br/> (repeat len<br/> (setq zifu (substr str weizhi 1))<br/> (cond<br/> ((and (>= (ascii (strcase zifu)) 65) (<= (ascii (strcase zifu)) 70)) (setq zifu (- (ascii (strcase zifu)) 55)))<br/> ((and (>= (ascii zifu) 48) (<= (ascii zifu) 57)) (setq zifu (atoi zifu)))<br/> )<br/> (setq num10 (+ (* num10 16) zifu))<br/> (setq weizhi (1+ weizhi))<br/> )<br/> num10<br/> )</p> <font face="黑体" size="4">查两个图层相交的点，用不了</font> <p>想新建一个简单的标注样式，格式与STANDRAD相同，仅仅是箭头类型是"倾斜",请问LISP怎样写，我是这样先:(command "dimblk" "_oblique")<br/>再建立标注样式:(defun c:TEST ()</p><p> (command "DIMSCALE" 1)<br/> (command "DIMSCALE" 1)<br/> (command "DIMASZ" 1.5)....</p><p>问题是若command "dimblk" "_oblique"也在TEST里,仅仅会建立一个<strong>替代</strong>标注样式</p><p><br/></p> xd-xdcad发表于2008-7-10 20:21:00static/image/common/back.gif想新建一个简单的标注样式，格式与STANDRAD相同，仅仅是箭头类型是\"倾斜\",请问LISP怎样写，我是这样先:(command \"dimblk\" \"_oblique\")再建立标注样式:(defun c:TEST ()  
<p>用：</p><p>(command "-dimstyle" "s" "dimstyle_name")</p>