打个酱油占个位,反正别人不知道,哈哈！
;1.【选择集处理】8分
;已知一个选择集，要求从选择集中筛选出符合下列描述的对象：
;(1)圆环(由2个半圆组成的封闭多段线)、矩形(由多段线构成的封闭的直角平行四边形)；
;(2)忽略LWEIGHT命令概念的线宽，多段线线宽为0；
;(3)起点、终点重合即可被认为封闭。
(defun iscpl (ent / 42lst entlst entype obj ptlst pw x y)
(setq obj (gps->e2o ent) entlst (entget ent) entype (cdr(assoc 0 entlst)))
(if
(and
(= entype "LWPOLYLINE")
(VLAX-CURVE-ISCLOSED obj)
(not(vl-catch-all-error-p(setq pw(vl-catch-all-apply 'vla-get-ConstantWidth(list obj)))))
(zerop pw)
)
(progn
(setq 42lst (vl-remove-if-not '(lambda(x)(= 42(car x)))entlst))
(cond
((= 2 (length 42lst)) ;圆环
(not(apply 'or (mapcar '(lambda(y)(zerop(cdr y)))42lst)))
)
((or (= 4 (length 42lst)) (= 5 (length 42lst))) ;矩形
(setq ptlst (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= 10(car x)))entlst)))
(and
(apply 'and (mapcar '(lambda(y)(zerop(cdr y)))42lst))
(=
(abs(- (angle(nth 1 ptlst)(nth 2 ptlst))(angle(nth 1 ptlst)(nth 0 ptlst))))
(abs(- (angle(nth 2 ptlst)(nth 3 ptlst))(angle(nth 2 ptlst)(nth 1 ptlst))))
(* 0.5 pi)
)
)
)
(T nil)
)
)
)
)
(defun test (ss / ent lst n)
(repeat (setq n (sslength ss))
(setq ent (ssname ss (setq n (1- n))))
(if (not(iscpl ent))(setq lst (cons ent lst)))
)
(foreach n lst(ssdel n ss))
(sssetfirst nil ss)
ss
)
;|
2.【几何运算】9分
已知一条端点为A和B的直线，将该直线以A端点为基点旋转89度，再以B端点为基点
缩放3.5倍，用几何方法求出直线的2个新端点。禁用polar、command、vl-cmdf函数
|;
(defun test(a b / ang len x+ y+)
(setq len(distance a b)ang(+(angle a b)(*(/ 89 180.0)pi)))
(setq x+(* len(cos ang))y+(* len (sin ang)))
(list
(mapcar '+ a(list x+ y+ 0))
(mapcar '- a(list(* 2 x+)(* 2 y+)0))
)
)
;3.【点集处理】15分
; 已知一个包含若干个三维点的表，若表中相邻两个点之间的距离大于100，则
; 在两点之间添加中点，直到表中相邻两个点之间距离小于或等于100。
; 限用递归法
(defun newptlst(lst / mid pt1 pt2)
(cond ((<(length lst)2)lst)
(T
(setq pt1 (car lst) pt2 (cadr lst))
(if (<= (distance pt1 pt2) 100)
(cons pt1 (newptlst (cdr lst)))
(progn
(setq mid(mapcar '(lambda(x y)(* 0.5(+ x y)))pt1 pt2))
(setq lst(append(list pt1 mid)(cdr lst)))
(newptlst lst)
)
)
)
)
)
;4.【图形对象操作】8分
;??已知一个云线(由REVCLOUD命令绘制的包含若干弧段的多段线)，用VLISP方法
;??将云线翻转(即把弧段的凸度方向调整为反方向)，禁用command、vl-cmdf函数
(defun RevCloud (ent / newlst)
(foreach n (entget ent)
(if (and(=(car n)42)(not(zerop(cdr n))))
(setq newlst (cons(cons 42(-(cdr n)))newlst))
(setq newlst (cons n newlst))
)
)
(entmod (reverse newlst))
)
;5.【非图形对象操作】20分
;? ?在禁用炸开命令的前提下，将将MLINE转换为LINE。
;;;多线样式
(defun Kdub:Mlinestyle-Get (Name / mlsty-DICT MLSty)
(if (setq mlsty-DICT (dictsearch (Namedobjdict) "ACAD_MLINESTYLE"))
(while
(and mlsty-DICT
(not (setq MLSty (if (and (assoc 3 mlsty-DICT) (= (strcase (cdr (assoc 3 mlsty-DICT))) (strcase Name)))
(list (strcase Name) (cdr (cadr (member (assoc 3 mlsty-DICT) mlsty-DICT))))
)
)
)
)
(setq mlsty-DICT (cdr (member (assoc 3 mlsty-DICT) mlsty-DICT)))
)
)
MLSty
)
;;Expects pts to be a list of 2D or 3D points
(defun makePline (spc pts)
(if (= (length (car pts)) 2) ; 2d point list
(setq pts (apply 'append pts))
(setq
pts (apply 'append (mapcar '(lambda (x) (list (car x) (cadr x))) pts))
)
)
(setq
pts (vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble (cons 0 (1- (length pts))))
pts
)
)
)
(vla-addlightweightpolyline spc pts)
)
;;;基本完成了,没有考虑图层,线型.
(defun exmline (ent / dq entlst n obj plst spc)
(setq entlst (entget ent))
(foreach n entlst
(if (member (car n) '(10 11))
(setq plst (cons (cdr n) plst))
)
)
(setqdq (cdr(assoc 70 entlst)) bl (cdr(assoc 40 entlst)))
(setqobj (makePline (vla-get-modelspace(vla-get-ActiveDocument(vlax-get-acad-object))) plst))
(setq mstyle (Kdub:Mlinestyle-Get(vla-get-stylename (gps->e2o ent)) ))
(setq mstylelst (entget (cadr mstyle)))
(setq dis (apply '+ (mapcar '(lambda(x)(if(=(car x)49)(abs(cdr x))0))mstylelst)))
(cond
((= dq 0)
(vla-Offset obj (* -1 dis bl))
)
((= dq 1)
(vla-Offset obj (* 0.5 dis bl))
(vla-Offset obj (* -0.5 dis bl))
(vla-delete obj)
)
((= dq 2)
(vla-Offset obj (* dis bl))
)
)
(entdel ent)
(princ)
)
;6.【曲线计算】10分
; 已知共面且不相交的一直线和一圆弧，求两个对象之间的最小距离。
(vlax-curve-getClosestPointTo obj pt)
;有空再写吧.
;7.【非图形对象操作】10分
;分解图元所在编组(GROUP)，即清除编组定义。禁用command、vl-cmdf函数。
;炸开图中所有组
;同一个物体可能在几个不同的组
(defun explodeGroups(obj / e g lst vla-groups)
(setq vla-groups(vla-get-Groups(vla-get-activedocument(vlax-get-acad-object))))
(vlax-for g vla-groups
(vlax-for e g
(if (equal(vla-get-ObjectID e)(vla-get-ObjectID Obj))
(setq lst (cons g lst))
)
)
)
(foreach g lst
(princ (strcat "\n 对象所在 "(vla-get-Name g)" 组被分解!"))
(vla-delete g)
)
(vlax-release-object vla-groups)
(princ)
)
;8.【实用技巧】20分
; 找出指定fas程序文件中的所有命令(C:开头的函数)。
; 提示：fas可能已加载。测试文件见附件test.fas。
(defun c:Compare( / #newatoms #oldatoms file n ret str x)
(vl-load-com)
(defun atoms(str)
(vl-remove-if-not
(function(lambda(n)(wcmatch n str)))
(atoms-family 1)
)
)
(setq #oldatoms (mapcar '(lambda(x)(list x(eval(read x))))(atoms "C:*")))
(if (setq file (getfiled "选择加载文件" "" "fas;lsp;vlx" 2))
(progn
(load file "")
(setq #newatoms(mapcar '(lambda(x)(list x(eval(read x))))(atoms "C:*")))
(setq ret(vl-remove 'nil (mapcar '(lambda(x)(if(equal(assoc(car x)#oldatoms)x)nil (car x)))#newatoms)))
(princ ret)
)
)
(princ)
)
怎么都占了沙发？
本帖最后由 caoyin 于 2012-1-1 06:42 编辑
先做两题简单的
;;;第1题
(defun TEST-1 (SS / IsCircle IsRectang I EN OBJ LST CW)
;;判断对象是否构成是圆--凸度法
(defun IsCircle (PlObj / BLG LST)
(setq BLG -1)
(vl-catch-all-apply '(lambda ()
(while (setq LST (cons (vla-GetBulge PLOBJ (setq BLG (1+ BLG))) LST)))
))
(and (= (length LST) 2) (apply '= LST) (zerop (apply '- LST)))
)
;;判断对象是否是矩形--对角线法
(defun IsRectang (PLOBJ / N PP P LST)
(setq N (fix (vlax-curve-getEndParam PLOBJ)) PP N)
(while (and PP (setq P (vlax-curve-getPointAtParam PLOBJ PP)))
(if (or (= PP N) (zerop (vla-GetBulge PLOBJ PP)))
(setq LST (cons P LST) PP (1- PP))
(setq PP nil)
)
)
(and PP
(= (length LST) 5)
(equal (distance (car LST) (caddr LST))
(distance (cadr LST) (cadddr LST))
1E-6
)
)
)
(repeat (setq I (sslength SS))
(setq EN(ssname SS (setq I (1- I)))
OBJ (vlax-ename->vla-object EN)
)
(if (and (= (vla-get-objectname OBJ) "AcDbPolyline")
(not (vl-catch-all-error-p
(vl-catch-all-apply
'(lambda () (setq CW (vla-get-ConstantWidth OBJ)))
)))
(zerop CW)
(equal (vlax-curve-getstartPoint OBJ)
(vlax-curve-getendPoint OBJ)
1E-6
)
(or (IsCircle OBJ) (IsRectang OBJ))
)
(setq LST (cons EN LST))
)
)
LST
)
;;;第4题
;;;(test4 (vlax-ename->vla-object (car(entsel)))) (defun TEST-4 (OBJ / N)
(repeat (setq N (fix (vlax-curve-getEndParam OBJ)))
(setq N (1- N))
(vla-setBulge OBJ N (- (vla-getBulge OBJ N)))
)
)
建议文字表述算法,具体代码可以多种实现
第8题可以讨论下，我的代码如下：(defun getcommandname (file / acadapp documents
actdoc mnlfile tmpfile tmpf
value str1
)
(vl-load-com)
(setq acadapp (vlax-get-acad-object)
documents (vla-get-documents acadapp)
actdoc (vla-get-activedocument acadapp)
)
(setq mnlfile (findfile "acad.mnl")
tmpfile (strcat (vl-filename-directory mnlfile) "\\tmpfile.lsp")
tmpf (open tmpfile "w")
)
(princ (vl-prin1-to-string
'(defun
findfunc
(file / abcdoc lst1 lst2 lst3)
(vl-load-com)
(setq
abcdoc
(vla-get-activedocument (vlax-get-acad-object))
)
(mapcar
'(lambda (x)
(if (or (wcmatch x "C:*")
(wcmatch x "c:*")
)
(setq lst1 (cons x lst1))
)
)
(atoms-family 1)
)
(load file (princ))
(mapcar
'(lambda (x)
(if (or (wcmatch x "C:*")
(wcmatch x "c:*")
)
(setq lst2 (cons x lst2))
)
)
(atoms-family 1)
)
(mapcar
'(lambda (x)
(if (not (member x lst1))
(setq lst3 (cons x lst3))
)
)
lst2
)
(vl-bb-set 'a lst3)
(vla-close abcdoc)
)
)
tmpf
)
(princ (strcat "\n(findfunc " (vl-prin1-to-string file) " )")
tmpf
)
(close tmpf)
;;;从头到尾依次读取指定文件的每一行，
;;;如果文件存在指定的字符串，就返回这
;;;条字符串，并停止搜索，否则返回nil。
(defun readeveryline (fd string / str)
(if (setq str (read-line fd))
(if (/= string str)
(readeveryline fd string)
str
)
)
)
(setq tmpf (open mnlfile "r")
str1 (strcat "(load " (vl-prin1-to-string tmpfile) " (princ))")
)
(if (readeveryline tmpf str1)
(close tmpf)
(progn (close tmpf)
(setq tmpf (open mnlfile "a"))
(princ (strcat "\n" str1) tmpf)
(close tmpf)
)
)
(vla-add documents "")
(setq value (vl-bb-ref 'a))
(vl-bb-set 'a nil)
(vl-file-delete tmpfile)
value
)只不过有点问题，以前就没发上来
问题是没把新建的文档给关闭
本帖最后由 nzl1116 于 2012-1-6 09:39 编辑
自己能解决了，在第二文档里激活第一个文档，在第一个文档里再关闭第二个文档
思路：考虑到当前文档有可能已经加载test.fas，于是就新建一个文档，在新建的文档里获取test.fas文件的C:*命令名，然后通过黑板变量来传递返回值。;;;8.【实用技巧】20分
;;; 找出指定fas程序文件中的所有命令(C:开头的函数)。
;;; 提示：fas可能已加载。测试文件见附件test.fas
;;;-----------------------------------------------------;;;
;;;---------------- getcommandname file ----------------;;;
;;; (getcommandname file) ;;;
;;; 获取指定文件中定义的C:*命令名 ;;;
;;;-----------------------------------------------------;;;
(defun getcommandname (file / acadapp documents
actdoc mnlfile tmpfile tmpf
value str1 abcDoc
)
(vl-load-com)
(setqacadapp (vlax-get-acad-object)
documents (vla-get-documents acadapp)
actdoc (vla-get-activedocument acadapp)
)
;;寻找自动加载的"acad.mnl"文件，并在同目录下创建"tmpfile.lsp"文件
(setqmnlfile(findfile "acad.mnl")
tmpfile(strcat (vl-filename-directory mnlfile) "\\tmpfile.lsp")
tmpf(open tmpfile "w")
)
;;在tmpfile.lsp"文件里写入 findfunc 函数定义
(princ (vl-prin1-to-string
'(defun findfunc (file / lst1 lst2 lst3)
(mapcar
'(lambda (x)
(if (or (wcmatch x "C:*")
(wcmatch x "c:*")
)
(setq lst1 (cons x lst1))
)
)
(atoms-family 1)
)
(load file (princ))
(mapcar
'(lambda (x)
(if (or (wcmatch x "C:*")
(wcmatch x "c:*")
)
(setq lst2 (cons x lst2))
)
)
(atoms-family 1)
)
(mapcar
'(lambda (x)
(if (not (member x lst1))
(setq lst3 (cons x lst3))
)
)
lst2
)
(vl-bb-set 'a lst3)
) ;_ 结束defun
) ;_ 结束 vl-princ1-to-string
tmpf
) ;_ 结束 princ
;;在文件的后面添加两行代码
;;(findfunc file) ;_ 执行自定义函数
;;(vl-load-com) ;_ 在第二个文档的名称空间里加载ActiveX支持[?这一步不知道是否需要]
;;(vla-Activate actDoc) ;_ 激活前一个文档，把控制权交还给它
(princ (strcat "\n(findfunc " (vl-prin1-to-string file) " )")
tmpf
)
(princ "\n(vl-load-com)" tmpf)
(princ "\n(vla-Activate actdoc)" tmpf)
;;关闭"tmpfile.lsp"文件
(close tmpf)
;;从头到尾依次读取指定文件的每一行，
;;如果文件存在指定的字符串，就返回这
;;条字符串，并停止搜索，否则返回nil。
(defun readeveryline (fd string / str)
(if(setq str (read-line fd))
(if (/= string str)
(readeveryline fd string)
str
)
)
)
;;打开"acad.mnl"文件，依次读取每一行
;;寻找是不是存在(load tmpfile (princ))这一行代码
;;若不存在，就在文件里添加
(setqtmpf (open mnlfile "r")
str1 (strcat "(load " (vl-prin1-to-string tmpfile) " (princ))")
)
(if (readeveryline tmpf str1)
(close tmpf)
(progn (close tmpf)
(setq tmpf (open mnlfile "a"))
(princ (strcat "\n" str1) tmpf)
(close tmpf)
)
)
;;新建一个文档，同时，把控制权交给它
(setq abcDoc (vla-add documents ""))
;;第二个文档执行完所有的代码后，自动把控制权交还给第一个文档
;;第一个文档得到控制权后，就关闭第二个文档
(vla-close abcDoc)
;;从黑板读取变量值
(setq value (vl-bb-ref 'a))
;;删除黑板的变量
(vl-bb-set 'a nil)
;;删除文件
(vl-file-delete tmpfile)
value
)
还是G版强悍啊，这么多源码，研究透了可不得了
本帖最后由 highflybir 于 2012-1-6 02:23 编辑
只解答最后一道题目：
(defun c:test(/ FunLst name)
(setq FunLst nil)
(foreach name (ATOMS-FAMILY 1)
(if (= "C:" (substr name 1 2))
(setq funlst (cons (eval (read name)) funlst))
)
)
;;这时候再重新装载程序
(load "d:\\tddownload\\test.fas") ;目录依据情况而定
(princ "\ntest.fas含有C:开头函数是:")
(foreach name (atoms-family 1)
(if (= "C:" (substr name 1 2))
(if (not (member (eval (read name)) funLst))
(princ (strcat "\n函数名:" name))
)
)
)
(princ)
)
本帖最后由 狂刀lxx 于 2012-1-6 11:54 编辑
看了gu_xl的第一题答案，觉得程序写的很长。提出另外一种思路，抛砖引玉。思路是用vlax-curve-getendparam 判断段数，用面积公式判断是否是圆或矩形。
;| by dreamskylxx-2012.1.6适用lwpolyline，polyline
适用外观闭合（不论最后一段是否是通过CL参数来进行闭合）
圆环适用于两端圆环不一定是半圆
排除多段线重合情况（如看似一个完整圆环，但是实际上有≥3段圆弧段组成）
|;
(defun tt1 (ss / AA C D1 D2 E I L1 L2 O PA SS1 SS2)
(setq i -1)
(while (setq e (ssname ss (setq i(1+ i))))
(setq o (vlax-ename->vla-object e))
(if(wcmatch (vla-get-objectname o) "*Polyline")
(setq pa(vlax-curve-getendparam o)))
(cond
((= 2.0 pa)
(setq c(vla-get-length o)
aa(vlax-curve-getarea o))
(if (equal aa (/ (* c c)(* 4. PI)) 1e-6)
;;(and (equal aa (/ (* c c)(* 4. PI)) 1e-6);;如果一定要判断是完整的半圆组成
;; (equal c (* 2. (vlax-curve-getdistatparam O 1.)) 1e-6))
(setq ss1 (cons e ss1)))
)
((= 4.0 pa)
(setq d1(vlax-curve-getdistatparam O 1.)
d2(vlax-curve-getdistatparam O 2.)
l1 d1
l2 (- d2 d1)
aa(vlax-curve-getarea o))
(if (equal aa (* l1 l2) 1e-6)
(setq ss2 (cons e ss2)))
)
(T nil)
)
)
(list ss1 ss2)
)
;;;; 以下是测试程序.
(defun c:ttt();;测试矩形多义线
(setq ss(ssget)
fss (tt1 ss))
(SETQ SSS(SSADD))
(MAPCAR '(LAMBDA(X)(SSADD X SSS))(caDr fss))
(sssetfirst NIL SSS)
)
(defun c:ttt2();;测试圆环多义线
(setq ss(ssget)
fss (tt1 ss))
(SETQ SSS(SSADD))
(MAPCAR '(LAMBDA(X)(SSADD X SSS))(car fss))
(sssetfirst NIL SSS)
)
第2题，其实polar是很好用的，不能用这个函数，难道不能写一个替代函数么？呵呵
思路是不违反题目要求前提下，写一个替代polar功能的函数，从而使程序代码和结构简洁明了。
测试代码同 gu_lx中的c:tt2(gu_lx的我测试了一下，是不是忘了缩放比例了？)
;|2.【几何运算】9分已知一条端点为A和B的直线，将该直线以A端点为基点旋转89度，再以B端点为基点
缩放3.5倍，用几何方法求出直线的2个新端点。禁用polar、command、vl-cmdf函数|;
(defun tt2 (LINE ANG SCALE FLAG / ent pt1 pt2 len an pt2x pt1x) ;;by dreamskylxx-2012.1.6
(setq ent (entget LINE)
pt1 (cdr(assoc 10 ent))
pt2 (cdr(assoc 11 ent))
len (distance pt1 pt2))
(if (not flag)(setq pt pt1 pt1 pt2 pt2 pt));;对调
(setq an (angle pt1 pt2) pt2x(polarx pt1 (+ ang an) len)
pt1x(polarx pt2x (angle pt2x pt1 ) (* len scale))
ent (SUBST (cons 10 pt1x)(assoc 10 ent)ent)
ent (SUBST (cons 11 pt2x)(assoc 11 ent)ent))
(entmod ent)
)
;; 替代polar函数.
(defun polarx (pt an di)
(setq x (* di (cos an))
y (* di (sin an)))
(mapcar '+ (list x y (nth 2 pt)) pt)
)
第3题, 参照gu_xl的思路，用更紧凑和通俗的格式重写一次，比较纯粹。今晚太晚了，明天有空再玩玩
;;///////////第3题//////////////////////////////////////////;;
;|3.【点集处理】15分
已知一个包含若干个三维点的表，若表中相邻两个点之间的距离大于100，则
在两点之间添加中点，直到表中相邻两个点之间距离小于或等于100。
限用递归法。
|;
;(TT3x (list '(0 0 0) '(200 0 0) '(250 0 0) '(450 0 0) '(600 0 0)))
;->((0 0 0) (100.0 0.0 0.0) (200 0 0) (250 0 0) (350.0 0.0 0.0) (450 0 0) (525.0 0.0 0.0) (600 0 0))
(defun tt3x (pts / p1 p2)
(if (cdr pts)
(progn
(setq p1 (car pts)
p2 (cadr pts)
)
(if (<= (distance p1 p2) 100)
(cons p1 (tt3x (cdr pts)))
(tt3x (cons p1 (cons (mapcar '(lambda (a b) (* 0.5 (+ a b))) p1 p2) (cdr pts))))
)
)
(car pts)
)
)