[分享]：整理了一些常用的函数，有一些用得比较频繁，陆续增加中

xiao_longxin · 发表于 2006-4-22 20:07:20

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

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

×

对一些函数进行了升级，再增加了几个函数

;;目录：
;;1
;;以字符串为分隔符把行文字读入表中
;;例：(read->biao "jksdi,kkik,oo" ",")
;;返回：("jksdi" "kkik" "oo")
;;2生成cad图元：TEXT\LINE\PLINE\CIRCLE
;;3
;;返回两曲线交点坐标
;;4
;;判断一点是否在一封闭区域内
;;5
;;表排序通用函数
;;6
;;取得实体外矩形框
;;7
;;取弧的 ( <起點> <中點> <終點>)
;;8
;;判断点在直线上的位置:上、左、右
;;9
;;由全路径返回盘符
;;10
;;由全路径返回扩展名
;;11
;;由全路径和文件名返回不带扩展名的文件名
;;12
;;由全路径及文件名返回局部的文件名
;;13
;;由全路径和文件名返回局部的路径
;;14
;;将一个字符串按BASE的做为基数的进制转换为十进制的整数值
;;15
;;将一个整数转换成一个按BASE基数指定的进制的字符串值
;;16
;;返回多义线顶点的坐标
;;17
;;判断多义线是顺时针还是逆时针
;;18
;;从点列表(point list)得到坐标范围(coordinate extents).
;;19
;;取得当前绘图区屏幕的左下角和右上角的坐标
;;20
;;表中指定位置插入新元素或删除指定位置元素
;;21
;;对表按指定索引重新排序
;;Visual LISP 扩展功能加载到 AutoLISP
(vl-load-com)
;;1
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;By Longxin 明经通道 2006.03
;;以字符串为分隔符把行文字读入表中
;;例：(read->biao "jksdi,kkik,oo" ",")
;;返回：("jksdi" "kkik" "oo")
(defun read->biao (str fgf / biao s1 i)
(setq biao nil)
(setq i (vl-string-search fgf str))
(while i
(setq s1 (substr str 1 i))
(setq str (substr str (+ 2 i)))
(setq biao (append biao (list s1)))
(setq i (vl-string-search fgf str))
)
(append biao (list str))
)
;;2
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;By Longxin 明经通道 2006.04
;;;生成一个TEXT实体
;;例：(maketext 文字　三维点字高旋转角度宽高比倾斜对齐样式字型)
;;，对齐样式：0 : 中心,11：左上，12：左中，13：左下，21：中上，22：正中，23：中下，31：右上，32：右中，33：右下
;;旋转角度与倾斜：以(度)为单位
(defun maketext (text pt zg ang kgb qx dqys zx / p1 p2 y1 y2)
(setq p2 (append '(10) pt)
p1 (append '(11) pt)
zg (cons '40 zg)
text (cons '1 text)
qx (cons '51 (* pi (/ qx 180.0)))
ang (cons '50 (* pi (/ ang 180.0)))
kgb (cons '41 kgb)
)
(if (not zx)
(setq zx "standard")
)
(setq zx (cons '7 zx))
(cond ((= dqys 0)
(setq y1 (cons 72 4)
y2 (cons 73 0)
)
)
((= dqys 11)
(setq y1 (cons 72 0)
y2 (cons 73 3)
)
)
((= dqys 12)
(setq y1 (cons 72 0)
y2 (cons 73 2)
)
)
((= dqys 13)
(setq y1 (cons 72 0)
y2 (cons 73 1)
)
)
((= dqys 21)
(setq y1 (cons 72 1)
y2 (cons 73 3)
)
)
((= dqys 22)
(setq y1 (cons 72 1)
y2 (cons 73 2)
)
)
((= dqys 23)
(setq y1 (cons 72 1)
y2 (cons 73 1)
)
)
((= dqys 31)
(setq y1 (cons 72 2)
y2 (cons 73 3)
)
)
((= dqys 32)
(setq y1 (cons 72 2)
y2 (cons 73 2)
)
)
((= dqys 33)
(setq y1 (cons 72 2)
y2 (cons 73 1)
)
)
)
(entmake (list
'(0
.
"TEXT"
)
p2
text
zg
ang
kgb
qx
zx
'(71
.
0
)
y1
y2
p1
)
)
;;(command "point" pt)
)
;;生成一个LINE
;;参数：pt1:起点，pt2:终点,均为三维点,即(x y z)
(DEFUN MAKELINE (PT1 PT2 /)
(setq pT1 (append '(10) pt1)
pT2 (append '(11) pt2)
)
(entmake (list
'(0
.
"LINE"
)
pT1
PT2
)
)
)
;;生成一条pline
;;参数：
;;plist:坐标点表，如：((x1 y1 z1) (x2 y2 z2) (x2 y2 z2))或((x1 y1) (x2 y2) (x2 y2))
;;tudulist:各点之间的凸度表，与plist相对应，可为nil
;;bg：标高
;;clo:是否闭合，1:闭合，0：不闭合
;;(defun c:test ()
;;(setq a '((102.946 68.6354 3) (112.102 97.4851 3) (125.484 59.4879 3) (103.651 52.4513 3))
;; b '(-1.02092 -0.485629 0 -1.31201)
;;)
;;(makepline a b 211 1)
;;)
(defun makepline (plist clo bg tudulist / dxf n i pt)
(setq bg (cons 38 bg)
i 0
n (length plist)
dxf nil
)
(if (= clo 1)
(entmake (list '(0 . "POLYLINE") '(66 . 1) '(70 . 1) bg))
(entmake (list '(0 . "POLYLINE") '(66 . 1) bg))
)
(repeat n
(setq pt (nth i plist)
pt (list (nth 0 pt) (nth 1 pt))
)
(if tudulist
(entmake (list (cons 0 "VERTEX")
(cons 10 pt)
(cons 42 (nth i tudulist))
)
)
(entmake (list (cons 0 "VERTEX")
(cons 10 pt)
)
)
)
(setq i (1+ i))
)
(entmake '((0 . "SEQEND")))
(princ)
)
;;生成一条circle
;;参数：pt:圆心(三维点即(x y z))，r:半径
(DEFUN MAKEcircle (PT r /)
(setq pT (append '(10) pt)
r (cons 40 r)
)
(entmake (list
'(0
.
"circle"
)
pT
r
)
)
)
;;3
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;By Mccad 明经通道
;;返回两曲线交点坐标
;;例：(GetInterPointlist objet1 objet2)
;;返回：((x1 y1 z1) (x2 y2 z2) (x3 y3 z3))
(defun GetInterPointlist (ent_1 ent_2 / ent1 ent2
ax_ent_1 ax_ent_2 intpoints i
j k disp int_list
)
;(setq ent1 (entsel "\n选择第一条曲线:"))
;(setq ent2 (entsel "\n选择第二条曲线:"))
;(setq ent_1 (car ent1)
;ent_2 (car ent2)
;)
(setq int_list nil)
(setq ax_ent_1 (vlax-ename->vla-object ent_1)
ax_ent_2 (vlax-ename->vla-object ent_2)
)
(setq intpoints (vla-intersectwith ax_ent_1 ax_ent_2 acextendnone))
(setq intpoints (vlax-variant-value intpoints))
(if (> (vlax-safearray-get-u-bound intpoints 1) 0)
(progn
(setq i 0)
(setq j 0)
(setq disp "")
(repeat
(/ (+ 1
(- (vlax-safearray-get-u-bound intpoints 1)
(vlax-safearray-get-l-bound intpoints 1)
)
)
3
)
(setq
disp (list
(vlax-safearray-get-element intpoints j)
(vlax-safearray-get-element intpoints (+ 1 j))
(vlax-safearray-get-element intpoints (+ 2 j))
)
)
(setq i (+ 2 i)
j (+ 3 j)
)
(setq int_list (append int_list (list disp)))
)
)
)
(setq int_list int_list)
)
;;注意　，如果两条均为spline，则反回的交点数只有一半
;;4
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;By Xiao_longxin 明经通道
;;有一不规则多边形由点a1(x1,y1)、a2(x2,y2).....an(xn,yn)依次连接而成，如何求证点p(x,y)是在多边形内还是多边形外？
;;将直线PAi记作ki.将ki旋转到ki+1(令kn+1=k1)的角记为βi(规定逆时针为正，顺时针为负,如果βi大于180就变成βi－360)。
;;从直观上看有下面的结论
;;若P在形内，诸β的代数和为360度；
;;若P在形外，诸β的代数和为0。
;;pt_list 为((x y z) (x y z)......(x y z))即围成多边形的表
;;pt 为要判断的点
;;自相交多边形适用，不适用于曲线
(defun inorout (pt_list pt / e1 pt n i j va va_count)
(setq i 0
va_count 0
n (length pt_list)
pt_list (append pt_list (list (car pt_list)))
)
(repeat n
(setq va (- (angle pt (nth i pt_list))
(angle pt (nth (1+ i) pt_list))
)
)
(cond ((> va pi) (setq va (- va pi)))
((< va (* -1 pi)) (setq va (+ va pi)))
)
(setq va_count (+ va_count va)
i (1+ i)
)
)
(if (< (abs (- (abs va_count) pi)) 0.000001)
't
'nil
)
)
;;另一种算法
;;By Longxin 明经通道 2006.04
;;;;;判断一点是否在一个封闭的区域内，支持曲线(pline拟合、spline、圆、椭圆)
;;算法：设曲线为逆时针
;;如果一点p在封闭曲线内，则过点p的曲线的法线与曲线交于p',可得法线方位角p-p'=ang1
;;求得p'点在曲线上的切线p'-p1，方位角为ang2
;;则法线与切线的方位角之差为：pi/2
;;依此方法，可求得在封闭曲线内的点
;;参数：ename,曲线图无名
;; pt，三维点
;;返回：t---pt点在曲线内
;; nil--pt点在曲线上或者外
(defun inorout_s (ename pt / obj ptnear parm yspt1 yspt2 ang1 ang2)
;;(command "point" pt)
(setq obj (vlax-ename->vla-object ename)
ptnear (vlax-curve-getClosestPointTo obj pt)
;取得点到曲线的最近点
)
;;(command "point" ptnear)
(setq ang1 (angle ptnear pt) ;最近点在曲线上的法线方位角
parm (vlax-curve-getParamAtPoint obj ptnear)
;最近点在曲线上的参数
yspt1 (vlax-curve-getFirstDeriv obj parm)
;取得该点的第一衍生,即切线的衍生方向增量
yspt1 (list (+ (nth 0 ptnear) (nth 0 yspt1))
(+ (nth 1 ptnear) (nth 1 yspt1))
(nth 2 ptnear)
)
ang2 (angle ptnear yspt1) ;最近点在曲线上的切线方位角
ang1 (- ang1 ang2)
)
(if (< ang1 0)
(setq ang1 (+ (* 2 pi) ang1)) ;使值恒为正
)
;;(print ang1)
;;(if (PlineCCW_obj ename)
;;(print "\n逆")
;;(print "\n顺")
;;)
(if (PlineCCW_obj ename) ;判断曲线的顺、逆
(if (< ang1 pi)
t ;如果曲线为逆时针，且法线与切线角度之差小于180度
nil ;如果曲线为逆时针，且法线与切线角度之差大于180度
)
(if (< ang1 pi)
nil ;如果曲线不为逆时针，且法线与切线角度之差小于180度
t ;如果曲线不为逆时针，且法线与切线角度之差大于180度
)
)
)
;;5
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;By Longxin 明经通道 2005.06
;;表排序通用函数
;;例：(order_LIST TJ 表条件)
;;返回：排序后的表
;;;主程序
(defun order (coord_list tj / coord_ord coord_I i j k n tj_ tj_c tj_1
tj_2)
(setq n (length coord_list))
(setq k (length tj))
(setq tj_ "(cond ((")
(setq tj_1 (nth 0 (nth 0 tj)))
(setq tj_2 tj_1)
(setq tj_1 (strcat tj_1 " p1"))
(setq tj_2 (strcat tj_2 " p2"))
(repeat (nth 1 (nth 0 tj))
(setq tj_1 (strcat tj_1 ")"))
(setq tj_2 (strcat tj_2 ")"))
)
(setq tj_ (strcat tj_ (nth 2 (nth 0 tj)) " " tj_1 tj_2 ") t) "))
(setq tj_c "((and ")
(setq i 1)
(repeat (- k 1)
(setq tj_c (strcat tj_c "(= " tj_1 " " tj_2 ")"))
(setq tj_1 (nth 0 (nth i tj)))
(setq tj_2 tj_1)
(setq tj_1 (strcat tj_1 " p1"))
(setq tj_2 (strcat tj_2 " p2"))
(repeat (nth 1 (nth i tj))
(setq tj_1 (strcat tj_1 ")"))
(setq tj_2 (strcat tj_2 ")"))
)
(setq tj_ (strcat tj_
tj_c
"("
(nth 2 (nth i tj))
" "
tj_1
tj_2
")) t) "
)
)
(setq i (1+ i))
)
(setq tj_ (strcat tj_ "(t nil))"))
(setq
coord_i
(vl-sort-i coord_list
(function (lambda (p1 p2)
(eval (read tj_))
)
)
)
)
(setq j 0)
(repeat n
(setq
coord_ord (append coord_ord
(list (nth (nth j coord_i) coord_list))
)
)
(setq j (1+ j))
)
(setq coord_ord coord_ord)
)
;;;;测试程序
;;(defun c:test (/ coord tt)
;; (setq coord
;; '(
;; (1 (1 . 2) 3 ("kkj" 4) (3 0))
;; (1 (1 . 4) 1 ("skj" 45) (2 3))
;; (1 (1 . 2) 3 ("Aej" 45) (7 1))
;; (1 (2 . 3) 2 ("ser" 4) (9 2))
;; (2 (6 . 2) 2 ("Serj" 9) (1 4))
;; (3 (3 . 5) 1 ("kkjsd" 35) (7 6))
;; (2 (4 . 7) 2 ("Akjdd" 3) (5 4))
;; (3 (3 . 3) 3 ("sekj" 446) (3 4))
;; (2 (2 . 2) 2 ("serj" 9) (1 4))
;; (1 (8 . 2) 2 ("wggj" 46) (2 4))
;; (1 (1 . 4) 1 ("kkj" 9) (4 4))
;; (3 (3 . 3) 3 ("sekj" 446) (3 4))
;; (1 (8 . 2) 2 ("wggj" 46) (2 4))
;; )
;; )
;;每个条件的第一项为要排序的依据，注意后面的括号没有，第二项即为后括号的个数，第三项为按升还是降排序
;; (setq tt '(
;; ("(nth 0 (nth 3 " 2 ">") 　　;;第一条件，依据数据("kkj" 4)中的'kkj'
;; ("(nth 0" 1 "<")　　　　　　　;;第二条件，依据数据'1'
;; ("(car (nth 1 " 2 "<")　　　　;;第三条件，依据数据(1 . 4)中的　1
;; ("(nth 1 (nth 4 " 2 ">")　　 ;;第四条件，依据数据(3 0)中的　0
;; ("(nth 1 (nth 3" 2 ">")　　　 ;;第五条件，依据数据("kkj" 4)中的　4
;; )
;; )
;; (order coord tt)
;;)
;;6
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;By Longxin 明经通道 2005.06
;;取得实体外矩形框
;;例：(getbox 图元名)
;;返回：((x1 y1 z1)_min (x2 y2 z2)_max)
(defun getbox (e1 / obj minpoint maxpoint)
(setq obj (vlax-ename->vla-object e1)) ;转换图元名
(vla-GetBoundingBox obj 'minpoint 'maxpoint)
;取得包容图元的最大点和最小点
(setq minpoint (vlax-safearray->list minpoint)) ;把变体数据转化为表
(setq maxpoint (vlax-safearray->list maxpoint)) ;把变体数据转化为表
;;(command "box" minpoint maxpoint 2)
(setq obj (list minpoint maxpoint))
)
;;7
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;取弧的 ( <起點> <中點> <終點>)
;;Date 2004-05-13
;;make by ＢＤＹＣＡＤ
;;例：(arc_3point (CAR(ENTSEL)))
;;参数：图元名
;;返回值:( <起點> <中點> <終點>)
(defun arc_3point (a / cenp radius STP ENPmp arcmidpoint)
(setq cenp (cdr (assoc 10 (entget a))))
(setq radius (cdr (assoc 40 (entget a))))
(setq STP (vlax-curve-getPointAtParam A (vlax-curve-getstartparam A)))
(setq ENP (vlax-curve-getPointAtParam A (vlax-curve-getEndParam A)))
(setqarcmidpoint
(polar
(polar stp (angle stp enp) (/ (distance STP ENP) 2.0))
(angle cenp
(polar stp (angle stp enp) (/ (distance STP ENP) 2.0))
)
(- radius
(distance (polar stp (angle stp enp) (/ (distance STP ENP) 2.0))
cenp
)
)
)
)
(list stp enp arcmidpoint)
)
;;8
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;判断点在直线上的位置
;;语法：(pntonline p1 p2 p3 wc)
;;参数
;;p1,p2：直线上的两点，例如直线上的起点和端点，三维点
;;p3：所要判断的点，三维点
;;wc:阀值，即当三点的夹角小于WC值时认为P3点在线上，以秒为单位
;;返回值 :实数
;;等于0时点在线上，大于0时点在线的左侧，小于0时点在线的右侧
(defun pntonline (p1 p2 p3 wc / p c B C P z)
(setq p p3)
(setq z (apply '+
(mapcar '(lambda (b)
(setq c (- (* (car p) (cadr b)) (* (cadr p) (car b)))
p b
)
c
)
(list p1 p2 p3)
)
)
)
(if (< (abs z) (* wc 0.0614658))
(setq z 0)
(setq z z)
)
)
;;9
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;由全路径返回盘符
;;语法
;;(JustDrive cFileName)
;;参数
;;cFileName:str 要检查的文件完整路径
;;返回值
;;[STR]
;;样例
;;(setq a "C:\\MyFolder\\MyFile.txt")
;;; (JustDrive a) ; 返回 "C:"
(defun JustDrive (cFileName / return)
(if (> (strlen cFileName) 1) ; 查看第二个字符是否为“:”
(progn
(setq return (substr cfileName 1 2))
(if (not (= ":" (substr return 2 1)))
(setq return "")
) ;_ end of if
) ;_ end of progn
(setq return "")
) ;_ end of if
return
) ;_ end of defun
;;10
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;由全路径返回扩展名
;;语法
;;(JustExt cFileName)
;;参数
;;cFileName:str 要检查的全路径
;;返回值
;;[STR]
;;样例
;;(setq a "C:\\MyFolder\\MyFile.txt")
;;(JustExt a) ; 返回 "txt"
(defun JustExt (cFileName / dotLoc)
(setq dotLoc (rat "." cfileName))
(if (> dotLoc 0)
(substr cFilename (1+ dotLoc))
""
) ;_ end of if
) ;_ end of defun
;;11
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;由全路径和文件名返回不带扩展名的文件名
;;语法
;;(JustStem cFileName)
;;参数
;;cFileName：str 要检查的完整路径
;;返回值
;;[STR]
;;样例
;;(setq a "C:\\MyFolder\\MyFile.txt")
;;(JustStem a) ; 返回 "MyFile"
(defun JustStem (cFileName / fName DotLoc)
(setq fName (justFName cFileName))
(setq DotLoc (rat "." fName))
(if (> DotLoc 0)
(substr fName 1 (1- DotLoc))
fName
) ;_ end of if
) ;_ end of defun
;;12
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;由全路径及文件名返回局部的文件名
;;语法
;;(JustFName cFileName)
;;参数
;;cFileName:str 要全的完整路径
;;返回值
;;[STR]
;;样例
;;(setq a "C:\\MyFolder\\MyFile.txt")
;;(JustStem a) ; 返回 "MyFile.txt"
(defun JustFName (cFileName / bsLoc ColonLoc)
;; Check for BackSlash
(setq bsLoc (rat "\" cfileName))
(if (> bsLoc 0)
(substr cFilename (1+ bsLoc))
(progn
;; 检查盘号 ":"
(setq ColonLoc (rat ":" cfileName))
(if (> ColonLoc 0)
(substr cFilename (1+ ColonLoc))
cFileName
) ;_ end of if
) ;_ end of progn
) ;_ end of if
) ;_ end of defun
;;13
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;由全路径和文件名返回局部的路径
;;语法
;;(JustPath cFileName)
;;参数
;;cFileName:检查的字符串
;;返回值
;;[STR]
;;样例
;;(setq a "C:\\MyFolder\\MyFile.txt")
;;(JustPath a) ; 返回 "C:\MyFolder"
(defun JustPath (cFileName / bsLoc)
(setq bsLoc (rat "\" cfileName))
(if (> bsLoc 0)
(substr cFilename 1 (1- bsLoc))
""
) ;_ end of if
) ;_ end of defun
;;14
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;将一个字符串按BASE的做为基数的进制转换为十进制的整数值
;;语法
;;(baseToDecimal base val )
;;参数
;;base:一个代表所要转换的进制(BASE2、BASE8等)基数整数。
;;val:一个进行转换的字符串。
;;返回值
;;十进制的整数值
;;样例
;;(baseToDecimal 16 "FA")
(defun baseToDecimal (base val / pos power result tmp)
(setqpos (1+ (strlen val))
power
-1
result
0
val
(strcase val)
)
(while (> (setq pos (1- pos)) 0)
(setq result
(+
result
(* (if (> (setq tmp (ascii (substr val pos 1))) 64)
(- tmp 55)
(- tmp 48)
)
(expt base (setq power (1+ power)))
)
)
)
)
result
)
;;15
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;将一个整数转换成一个按BASE基数指定的进制的字符串值
;;语法
;;(decimalToBase base val )
;;参数
;;base:一个代表所要转换的进制(BASE2、BASE8等)基数整数。
;;val:一个要转换的整数。
;;返回值
;;字符串
;;样例
;;(decimalToBase 16 250)
(defun decimalToBase (base val / result tmp)
(setq result "")
(while (> val 0)
(setq result (strcat (if (> (setq tmp (rem val base)) 9)
(chr (+ tmp 55))
(itoa tmp)
)
result
)
val (fix (/ val base))
)
)
result
)
;;16
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;By Longxin 明经通道 2001.08
;;返回多义线顶点的坐标
;;语法
;;(coords ename )
;;参数
;;ename:图元名
;;返回值
;;坐标列表，三维点
(defun coords (ename / dxf type_line xy_count)
(setq dxf (entget ename)
TYPE_LINE (CDR (ASSOC 0 DXF))
)
(COND ((= TYPE_LINE "POLYLINE")
(SETQ XY_COUNT (POL_coord eNAME))
)
((= TYPE_LINE "LWPOLYLINE")
(SETQ XY_COUNT (LW_coord ename))
)
((= TYPE_LINE "LINE")
(SETQ XY_COUNT (LINE_coord DXF))
)
)
)
;;;;;;;
(defun line_coord (dxf / pt1 pt2 count_xy)
(setq pt1 (cdr (assoc 10 dxf))
pt2 (cdr (assoc 11 dxf))
count_xy (list pt1 pt2)
)
)
;;;;;;;;;;;;;;;;;;;
(defun POL_coord (E1 / dxf XY E2 count_xy pd)
(setq count_xy nil
dxf
(entget e1)
DXF
(MEMBER (ASSOC 330 DXF) DXF)
E2
(ENTNEXT E1)
DXF
(ENTGET E2)
)
(setq e1 (cdr (assoc 0 dxf)))
(while (= e1 "VERTEX")
(setq e1 (cdr (assoc 10 dxf)))
(setq pd (cdr (assoc 70 dxf)))
(if (/= pd 16)
(setq count_xy (cons e1 count_xy))
)
(setq e1 e2)
(SETQ E2 (ENTNEXT E1)
DXF (ENTGET E2)
e1 (cdr (assoc 0 dxf))
)
)
(setq COUNT_XY (reverse count_xy))
)
;;;;;;;;;;;;;;;;;;;;;;;
(defun LW_coord (e1 / dxf XY COUNT_XY h)
(setq dxf (entget e1)
xy (ASSOC 10 DXF)
h (list (cdr (ASSOC 38 DXF)))
COUNT_XY nil
)
(WHILE XY
(SETQ DXF (MEMBER XY DXF)
XY (CDR (ASSOC 10 DXF))
DXF (CDR DXF)
COUNT_XY (CONS (append XY h) COUNT_XY)
XY (ASSOC 10 DXF)
)
)
(setq COUNT_XY (reverse COUNT_XY))
)
;;17
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;判断多义线或者坐标例表是否逆时针
;;语法：(PlineCCW pline)
;;参数：
;;pline:多义线图元名或者坐标例表如((x1 y1 z1) (x2 y2 z2))\((x1 y1) (x2 y2))
;;返回值:T OR nil
;;T:逆时针
;;NIL:顺时针
(defun PlineCCW (pline /)
(if (= (type pline) 'LIST)
(PlineCCW_list pline) ;如果pline为坐标例表，则调用LIST处理函数
(PlineCCW_obj pline) ;否则调用obj处理函数
)
)
;;;;;
(defun GEO_CCW (p0 p1 p2 p3 / ang1 ang2 ang3)
(setq ang1 (angle p0 p1))
(setq ang2 (angle p0 p2))
(setq ang1 (- ang2 ang1))
(if (> (abs ang1) pi)
(setq ang1 (+ (* -2 pi (/ ang1 (abs ang1))) ang1))
)
(setq ang3 (angle p0 p3))
(setq ang2 (- ang3 ang2))
(if (> (abs ang2) pi)
(setq ang2 (+ (* -2 pi (/ ang2 (abs ang2))) ang2))
)
(if (> (* ang1 ang2) 0)
(/ ang1 (abs ang1))
(cond
((> (abs ang1) (abs ang2))
(if (= ang2 0)
0
(/ ang2 (abs ang2))
)
)
((<= (abs ang1) (abs ang2))
(if (= ang1 0)
0
(/ ang1 (abs ang1))
)
)
)
)
)
;;;;;图元名的处理函数
(defun PlineCCW_obj
(pline / pline step param nParam
pt pt1 pt2 ptc i mp
CCWLST new_pline
)
(setq step 100)
(setq mp (vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
)
)
;;求得PLINE外围矩形的中心坐标
(vla-getboundingbox
(vlax-ename->vla-object pline)
'pt1
'pt2
)
(setq pt1 (vlax-safearray->list pt1)
pt2 (vlax-safearray->list pt2)
ptc (list (/ (+ (car pt1) (car pt2)) 2.0)
(/ (+ (cadr pt1) (cadr pt2)) 2.0)
)
)
;;end求得PLINE外围矩形的中心坐标
(setq param (/ (vlax-curve-getDistAtParam
pline
(vlax-curve-getEndParam pline)
)
step
)
)
(setq i 0)
(repeat (1- step)
(setq nParam (* i param))
(setq pt (vlax-curve-getPointAtdist pline nParam))
(setq pt1 (vlax-curve-getPointAtdist
pline
(+ (* (/ 0.5 step) param) nParam)
)
)
(setq pt2 (vlax-curve-getPointAtdist
pline
(+ (* (/ 1.0 step) param) nParam)
)
)
(setq CCWLST (append CCWLST (list (GEO_CCW ptc pt pt1 pt2))))
(setq i (1+ i))
)
(if (> (length (vl-remove 1.0 CCWLST))
(length (vl-remove -1.0 CCWLST))
)
nil
t
)
) ;end defun PlineCCW_obj
;;;;;;坐标例表的处理函数
(defun plineccw_list (plist / temp new)
(makepline plist 1 0 nil)
(setq new (entlast)
temp (PlineCCW_obj new)
)
(entdel new)
temp
)
;end defun PlineCCW_list
;;18
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;//王咣生
;;从点列表(point list)得到坐标范围(coordinate extents).
;;例如: (GetExtents '((1 0 0) (2 2 0) (1 2 0)))
;;;;返回：((x1 y1 z1)_min (x2 y2 z2)_max)
(defun GetExtents (plist /)
(list
(apply 'mapcar (cons 'min plist))
(apply 'mapcar (cons 'max plist))
)
)
;;19
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;取得当前绘图区屏幕的左下角和右上角的坐标
;;返回：((x1 y1 z1)_min (x2 y2 z2)_max)
(defun coord_screen (/ c03 c08 c04 c05 c07 c06 c09 c01 c02)
(setq c03 (getvar "viewctr")
c03 (trans c03 1 2)
c08 (getvar "viewsize")
c04 (getvar "screensize")
c07 (car c04)
c06 (cadr c04)
c09 (/ (* c08 c07) c06)
c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08)))
c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08)))
c01 (trans c01 2 1)
c02 (trans c02 2 1)
)
(list c01 c02)
)
;;20
;| (xl-subi lst ilst nlst)---------作者: 狂刀 [[url]www.xdcad.net[/url]]
功能 : 表中指定位置插入新元素或删除指定位置元素
参数 : lst = 表 ;
ilst = 索引值或索引值表;
nlst = 插入的元素或对应索引值表数量的插入元素表,nil 时为删除;
返回值 : 成功返回新表，否则返回原表;
注意 : 1 插入/删除位置为相对原表的位置，从 0 计数;
实　例　 :
(xl-subi '(1 2 3 4 5 6) '(1 4) '(0 0) ) ;;->(1 0 2 3 4 0 5 6)
(xl-subi '(1 2 3 4 5 6) '(1 4) '(0 nil)) ;;->(1 0 2 3 4 6)
(xl-subi '(1 2 3 4 5 6) '(1 4) '(0 )) ;;->(1 0 2 3 4 6)
(xl-subi '(1 2 3 4 5 6) '(1 4) nil);;->(1 3 4 6)
(xl-subi '(1 2 3 4 5 6) 2 0);;->(1 2 0 3 4 5 6)
(xl-subi '(1 2 3 4 5 6) 2 nil);;->(1 2 4 5 6)
|;
(defun xl-subi (lst ilst nlst / i a) ;; by 狂刀.2005.8
(if (/= 'LIST (type ilst))(setq ilst (list ilst)))
(if (/= 'LIST (type nlst))(setq nlst (list nlst)))
(apply 'append (mapcar '(lambda(x)
(setq i (if i (1+ i) 0))
(if (= (car ilst) i)
(progn
(setq ilst (cdr ilst)
a (car nlst)
nlst (cdr nlst))
(if a (list a x)nil)
)
(list x)
)
)
lst)
)
)
;;21
;;对表按指定索引重新排序
;;如：(order-i '(1 3 6 2 3) 1)---->(3 6 2 3 1)
(defun order-i (lst i / n j mi)
(setq n (length lst)
j i)
(repeat (- n i)
(setq mi (append mi (list (nth j lst)))
j (1+ j))
)
(setq j 0)
(repeat i
(setq mi (append mi (list (nth j lst)))
j (1+ j))
)
mi
)

;;目录： 
 
 
;;1 
;;以字符串为分隔符把行文字读入表中 
;;例：(read->biao "jksdi,kkik,oo" ",") 
;;返回：("jksdi" "kkik" "oo") 
 
;;2生成cad图元：TEXT\LINE\PLINE\CIRCLE 
 
;;3 
;;返回两曲线交点坐标 
 
;;4 
;;判断一点是否在一封闭区域内 
 
;;5 
;;表排序通用函数 
 
;;6 
;;取得实体外矩形框 
 
;;7 
;;取弧的  ( <起點> <中點> <終點>) 
 
;;8 
;;判断点在直线上的位置:上、左、右 
 
;;9 
;;由全路径返回盘符 
 
;;10 
;;由全路径返回扩展名 
 
;;11 
;;由全路径和文件名返回不带扩展名的文件名 
 
;;12 
;;由全路径及文件名返回局部的文件名 
 
;;13 
;;由全路径和文件名返回局部的路径 
 
;;14 
;;将一个字符串按BASE的做为基数的进制转换为十进制的整数值 
 
;;15 
;;将一个整数转换成一个按BASE基数指定的进制的字符串值 
 
;;16 
;;返回多义线顶点的坐标 
 
;;17 
;;判断多义线是顺时针还是逆时针 
 
;;18 
;;从点列表(point list)得到坐标范围(coordinate extents). 
 
;;19 
;;取得当前绘图区屏幕的左下角和右上角的坐标 
 
;;20 
;;表中指定位置插入新元素或删除指定位置元素 
 
;;21 
;;对表按指定索引重新排序 
 
 
 
 
;;Visual LISP 扩展功能加载到 AutoLISP 
(vl-load-com) 
 
;;1 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;By Longxin 明经通道 2006.03 
;;以字符串为分隔符把行文字读入表中 
;;例：(read->biao "jksdi,kkik,oo" ",") 
;;返回：("jksdi" "kkik" "oo") 
(defun read->biao (str fgf / biao s1 i) 
  (setq biao nil) 
  (setq i (vl-string-search fgf str)) 
  (while i 
    (setq s1 (substr str 1 i)) 
    (setq str (substr str (+ 2 i))) 
    (setq biao (append biao (list s1))) 
    (setq i (vl-string-search fgf str)) 
  ) 
  (append biao (list str)) 
) 
 
 
;;2 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;By Longxin 明经通道 2006.04 
;;;生成一个TEXT实体 
;;例：(maketext 文字　三维点 字高 旋转角度 宽高比 倾斜 对齐样式 字型) 
;;，对齐样式：0 : 中心,11：左上，12：左中，13：左下，21：中上，22：正中，23：中下，31：右上，32：右中 ，33：右下 
;;旋转角度与倾斜：以(度)为单位 
(defun maketext        (text pt zg ang kgb qx dqys zx / p1 p2 y1 y2) 
  (setq        p2   (append '(10) pt) 
        p1   (append '(11) pt) 
        zg   (cons '40 zg) 
        text (cons '1 text) 
        qx   (cons '51 (* pi (/ qx 180.0))) 
        ang  (cons '50 (* pi (/ ang 180.0))) 
        kgb  (cons '41 kgb) 
  ) 
  (if (not zx) 
    (setq zx "standard") 
  ) 
  (setq zx (cons '7 zx)) 
   
  (cond        ((= dqys 0) 
         (setq y1 (cons 72 4) 
               y2 (cons 73 0) 
         ) 
        ) 
 
        ((= dqys 11) 
         (setq y1 (cons 72 0) 
               y2 (cons 73 3) 
         ) 
        ) 
        ((= dqys 12) 
         (setq y1 (cons 72 0) 
               y2 (cons 73 2) 
         ) 
        ) 
        ((= dqys 13) 
         (setq y1 (cons 72 0) 
               y2 (cons 73 1) 
         ) 
        ) 
        ((= dqys 21) 
         (setq y1 (cons 72 1) 
               y2 (cons 73 3) 
         ) 
        ) 
        ((= dqys 22) 
         (setq y1 (cons 72 1) 
               y2 (cons 73 2) 
         ) 
        ) 
        ((= dqys 23) 
         (setq y1 (cons 72 1) 
               y2 (cons 73 1) 
         ) 
        ) 
        ((= dqys 31) 
         (setq y1 (cons 72 2) 
               y2 (cons 73 3) 
         ) 
        ) 
        ((= dqys 32) 
         (setq y1 (cons 72 2) 
               y2 (cons 73 2) 
         ) 
        ) 
        ((= dqys 33) 
         (setq y1 (cons 72 2) 
               y2 (cons 73 1) 
         ) 
        ) 
  ) 
 
  (entmake (list 
             '(0 
               . 
               "TEXT" 
              ) 
             p2 
             text 
             zg 
             ang 
             kgb 
             qx 
             zx 
             '(71 
               . 
               0 
              ) 
             y1 
             y2 
             p1 
           ) 
  ) 
  ;;(command "point" pt) 
) 
 
;;生成一个LINE 
;;参数：pt1:起点，pt2:终点,均为三维点,即(x y z) 
(DEFUN MAKELINE        (PT1 PT2 /) 
  (setq        pT1 (append '(10) pt1) 
        pT2 (append '(11) pt2) 
  ) 
  (entmake (list 
             '(0 
               . 
               "LINE" 
              ) 
             pT1 
             PT2 
           ) 
  ) 
) 
 
;;生成一条pline 
;;参数： 
;;plist:坐标点表，如：((x1 y1 z1) (x2 y2 z2) (x2 y2 z2))或((x1 y1) (x2 y2) (x2 y2)) 
;;tudulist:各点之间的凸度表，与plist相对应，可为nil 
;;bg：标高 
;;clo:是否闭合，1:闭合，0：不闭合 
;;(defun c:test () 
;;(setq        a '((102.946 68.6354 3) (112.102 97.4851 3) (125.484 59.4879 3) (103.651 52.4513 3)) 
;;        b '(-1.02092 -0.485629 0 -1.31201) 
;;) 
;;(makepline a b 211 1) 
;;) 
 
(defun makepline (plist clo bg tudulist / dxf n i pt) 
  (setq        bg  (cons 38 bg) 
        i   0 
        n   (length plist) 
        dxf nil 
  ) 
 
  (if (= clo 1) 
    (entmake (list '(0 . "POLYLINE") '(66 . 1) '(70 . 1) bg)) 
    (entmake (list '(0 . "POLYLINE") '(66 . 1) bg)) 
  ) 
  (repeat n 
    (setq pt (nth i plist) 
          pt (list (nth 0 pt) (nth 1 pt)) 
    ) 
    (if        tudulist 
      (entmake (list (cons 0 "VERTEX") 
                     (cons 10 pt) 
                     (cons 42 (nth i tudulist)) 
               ) 
      ) 
      (entmake (list (cons 0 "VERTEX") 
                     (cons 10 pt) 
               ) 
      ) 
    ) 
    (setq i (1+ i)) 
  ) 
  (entmake '((0 . "SEQEND"))) 
  (princ) 
) 
 
;;生成一条circle 
;;参数：pt:圆心(三维点即(x y z))，r:半径 
(DEFUN MAKEcircle (PT r /) 
  (setq        pT (append '(10) pt) 
        r  (cons 40 r) 
  ) 
  (entmake (list 
             '(0 
               . 
               "circle" 
              ) 
             pT 
             r 
           ) 
  ) 
) 
 
 
;;3 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;By Mccad 明经通道 
;;返回两曲线交点坐标 
;;例：(GetInterPointlist objet1 objet2) 
;;返回：((x1 y1 z1) (x2 y2 z2) (x3 y3 z3)) 
(defun GetInterPointlist (ent_1           ent_2    /             ent1     ent2 
                          ax_ent_1 ax_ent_2 intpoints              i 
                          j           k            disp     int_list 
                         ) 
                                        ;(setq ent1 (entsel "\n选择第一条曲线:")) 
                                        ;(setq ent2 (entsel "\n选择第二条曲线:")) 
                                        ;(setq ent_1 (car ent1) 
                                        ;ent_2 (car ent2) 
                                        ;) 
  (setq int_list nil) 
  (setq        ax_ent_1 (vlax-ename->vla-object ent_1) 
        ax_ent_2 (vlax-ename->vla-object ent_2) 
  ) 
  (setq intpoints (vla-intersectwith ax_ent_1 ax_ent_2 acextendnone)) 
  (setq intpoints (vlax-variant-value intpoints)) 
  (if (> (vlax-safearray-get-u-bound intpoints 1) 0) 
    (progn 
      (setq i 0) 
      (setq j 0) 
      (setq disp "") 
      (repeat 
        (/ (+ 1 
              (- (vlax-safearray-get-u-bound intpoints 1) 
                 (vlax-safearray-get-l-bound intpoints 1) 
              ) 
           ) 
           3 
        ) 
         (setq 
           disp        (list 
                  (vlax-safearray-get-element intpoints j) 
 
                  (vlax-safearray-get-element intpoints (+ 1 j)) 
 
                  (vlax-safearray-get-element intpoints (+ 2 j)) 
                ) 
         ) 
         (setq i (+ 2 i) 
               j (+ 3 j) 
         ) 
         (setq int_list (append int_list (list disp))) 
      ) 
    ) 
  ) 
  (setq int_list int_list) 
) 
;;注意　，如果两条均为spline，则反回的交点数只有一半 
 
 
 
;;4 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;By Xiao_longxin 明经通道 
;;有一不规则多边形由点a1(x1,y1)、a2(x2,y2).....an(xn,yn)依次连接而成，如何求证点p(x,y)是在多边形内还是多边形外？ 
;;将直线PAi记作ki.将ki旋转到ki+1(令kn+1=k1)的角记为βi(规定逆时针为正，顺时针为负,如果βi大于180就变成βi－360)。 
;;从直观上看有下面的结论 
;;若P在形内，诸β的代数和为360度； 
;;若P在形外，诸β的代数和为0。 
 
;;pt_list 为((x y z) (x y z)......(x y z))即围成多边形的表 
;;pt 为要判断的点 
;;自相交多边形适用，不适用于曲线 
(defun inorout (pt_list pt / e1 pt n i j va va_count) 
  (setq        i         0 
        va_count 0 
        n         (length pt_list) 
        pt_list         (append pt_list (list (car pt_list))) 
  ) 
  (repeat n 
    (setq va (-        (angle pt (nth i pt_list)) 
                (angle pt (nth (1+ i) pt_list)) 
             ) 
    ) 
    (cond ((> va pi) (setq va (- va pi))) 
          ((< va (* -1 pi)) (setq va (+ va pi))) 
    ) 
    (setq va_count (+ va_count va) 
          i           (1+ i) 
    ) 
  ) 
  (if (< (abs (- (abs va_count) pi)) 0.000001) 
    't 
    'nil 
  ) 
) 
 
;;另一种算法 
;;By Longxin 明经通道 2006.04 
;;;;;判断一点是否在一个封闭的区域内，支持曲线(pline拟合、spline、圆、椭圆) 
;;算法：设曲线为逆时针 
;;如果一点p在封闭曲线内，则过点p的曲线的法线与曲线交于p',可得法线方位角p-p'=ang1 
;;求得p'点在曲线上的切线p'-p1，方位角为ang2 
;;则法线与切线的方位角之差为：pi/2 
;;依此方法，可求得在封闭曲线内的点 
;;参数：ename,曲线图无名 
;;      pt，三维点 
;;返回：t---pt点在曲线内 
;;      nil--pt点在曲线上或者外 
(defun inorout_s (ename pt / obj ptnear parm yspt1 yspt2 ang1 ang2) 
  ;;(command "point" pt) 
  (setq        obj    (vlax-ename->vla-object ename) 
        ptnear (vlax-curve-getClosestPointTo obj pt) 
                                        ;取得点到曲线的最近点 
  ) 
  ;;(command "point" ptnear) 
  (setq        ang1  (angle ptnear pt)                ;最近点在曲线上的法线方位角 
        parm  (vlax-curve-getParamAtPoint obj ptnear) 
                                        ;最近点在曲线上的参数 
        yspt1 (vlax-curve-getFirstDeriv obj parm) 
                                        ;取得该点的第一衍生,即切线的衍生方向增量 
        yspt1 (list (+ (nth 0 ptnear) (nth 0 yspt1)) 
                    (+ (nth 1 ptnear) (nth 1 yspt1)) 
                    (nth 2 ptnear) 
              ) 
        ang2  (angle ptnear yspt1)        ;最近点在曲线上的切线方位角 
        ang1  (- ang1 ang2) 
  ) 
  (if (< ang1 0) 
    (setq ang1 (+ (* 2 pi) ang1))        ;使值恒为正 
  ) 
  ;;(print ang1) 
  ;;(if (PlineCCW_obj ename) 
  ;;(print "\n逆") 
  ;;(print "\n顺") 
  ;;) 
  (if (PlineCCW_obj ename)                ;判断曲线的顺、逆 
    (if        (< ang1 pi) 
      t                                        ;如果曲线为逆时针，且法线与切线角度之差小于180度 
      nil                                ;如果曲线为逆时针，且法线与切线角度之差大于180度 
    ) 
    (if        (< ang1 pi) 
      nil                                ;如果曲线不为逆时针，且法线与切线角度之差小于180度 
      t                                        ;如果曲线不为逆时针，且法线与切线角度之差大于180度 
    ) 
  ) 
) 
 
 
 
;;5 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;By Longxin 明经通道 2005.06 
;;表排序通用函数 
;;例：(order_LIST TJ 表 条件) 
;;返回：排序后的表 
 
;;;主程序 
(defun order (coord_list tj / coord_ord        coord_I        i j k n        tj_ tj_c tj_1 
              tj_2) 
 
  (setq n (length coord_list)) 
  (setq k (length tj)) 
  (setq tj_ "(cond ((") 
 
  (setq tj_1 (nth 0 (nth 0 tj))) 
  (setq tj_2 tj_1) 
  (setq tj_1 (strcat tj_1 " p1")) 
  (setq tj_2 (strcat tj_2 " p2")) 
  (repeat (nth 1 (nth 0 tj)) 
    (setq tj_1 (strcat tj_1 ")")) 
    (setq tj_2 (strcat tj_2 ")")) 
  ) 
  (setq tj_ (strcat tj_ (nth 2 (nth 0 tj)) " " tj_1 tj_2 ") t) ")) 
 
  (setq tj_c "((and ") 
  (setq i 1) 
  (repeat (- k 1) 
    (setq tj_c (strcat tj_c "(= " tj_1 " " tj_2 ")")) 
 
    (setq tj_1 (nth 0 (nth i tj))) 
    (setq tj_2 tj_1) 
    (setq tj_1 (strcat tj_1 " p1")) 
    (setq tj_2 (strcat tj_2 " p2")) 
    (repeat (nth 1 (nth i tj)) 
      (setq tj_1 (strcat tj_1 ")")) 
      (setq tj_2 (strcat tj_2 ")")) 
    ) 
 
    (setq tj_ (strcat tj_ 
                      tj_c 
                      "(" 
                      (nth 2 (nth i tj)) 
                      " " 
                      tj_1 
                      tj_2 
                      ")) t) " 
              ) 
    ) 
 
    (setq i (1+ i)) 
  ) 
  (setq tj_ (strcat tj_ "(t nil))")) 
 
  (setq 
    coord_i 
     (vl-sort-i        coord_list 
                (function (lambda (p1 p2) 
                            (eval (read tj_)) 
                          ) 
                ) 
 
     ) 
  ) 
 
  (setq j 0) 
  (repeat n 
    (setq 
      coord_ord        (append        coord_ord 
                        (list (nth (nth j coord_i) coord_list)) 
                ) 
    ) 
    (setq j (1+ j)) 
  ) 
  (setq coord_ord coord_ord) 
) 
;;;;测试程序 
;;(defun c:test (/ coord tt) 
;;  (setq        coord 
;;         '( 
;;           (1 (1 . 2) 3 ("kkj" 4) (3 0)) 
;;           (1 (1 . 4) 1 ("skj" 45) (2 3)) 
;;           (1 (1 . 2) 3 ("Aej" 45) (7 1)) 
;;           (1 (2 . 3) 2 ("ser" 4) (9 2)) 
;;           (2 (6 . 2) 2 ("Serj" 9) (1 4)) 
;;           (3 (3 . 5) 1 ("kkjsd" 35) (7 6)) 
;;           (2 (4 . 7) 2 ("Akjdd" 3) (5 4)) 
;;           (3 (3 . 3) 3 ("sekj" 446) (3 4)) 
;;           (2 (2 . 2) 2 ("serj" 9) (1 4)) 
;;           (1 (8 . 2) 2 ("wggj" 46) (2 4)) 
;;           (1 (1 . 4) 1 ("kkj" 9) (4 4)) 
;;           (3 (3 . 3) 3 ("sekj" 446) (3 4)) 
;;           (1 (8 . 2) 2 ("wggj" 46) (2 4)) 
;;          ) 
;;  ) 
 
;;每个条件的第一项为要排序的依据，注意后面的括号没有，第二项即为后括号的个数，第三项为按升还是降排序 
;;  (setq        tt '( 
;;           ("(nth 0 (nth 3 " 2 ">")  　　;;第一条件，依据数据("kkj" 4)中的'kkj' 
;;             ("(nth 0" 1 "<")　　　　　　　;;第二条件，依据数据'1' 
;;             ("(car (nth 1 " 2 "<")　　　　;;第三条件，依据数据(1 . 4)中的　1 
;;             ("(nth 1 (nth 4 " 2 ">")　　  ;;第四条件，依据数据(3 0)中的　0 
;;             ("(nth 1 (nth 3" 2 ">")　　　 ;;第五条件，依据数据("kkj" 4)中的　4 
;;            ) 
;;  ) 
;;  (order coord tt) 
;;) 
 
 
 
 
;;6 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;By Longxin 明经通道 2005.06 
;;取得实体外矩形框 
;;例：(getbox 图元名) 
;;返回：((x1 y1 z1)_min (x2 y2 z2)_max) 
(defun getbox (e1 / obj minpoint maxpoint) 
  (setq obj (vlax-ename->vla-object e1)) ;转换图元名 
  (vla-GetBoundingBox obj 'minpoint 'maxpoint) 
                                        ;取得包容图元的最大点和最小点 
  (setq minpoint (vlax-safearray->list minpoint)) ;把变体数据转化为表 
  (setq maxpoint (vlax-safearray->list maxpoint)) ;把变体数据转化为表 
  ;;(command "box" minpoint maxpoint 2) 
  (setq obj (list minpoint maxpoint)) 
) 
 
 
 
;;7 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;取弧的  ( <起點> <中點> <終點>) 
;;Date 2004-05-13 
;;make by ＢＤＹＣＡＤ 
;;例：(arc_3point (CAR(ENTSEL))) 
;;参数：图元名 
;;返回值:( <起點> <中點> <終點>)   
(defun arc_3point (a / cenp radius STP ENPmp arcmidpoint) 
  (setq cenp (cdr (assoc 10 (entget a)))) 
  (setq radius (cdr (assoc 40 (entget a)))) 
  (setq STP (vlax-curve-getPointAtParam A (vlax-curve-getstartparam A))) 
  (setq ENP (vlax-curve-getPointAtParam A (vlax-curve-getEndParam A))) 
  (setqarcmidpoint 
    (polar 
      (polar stp (angle stp enp) (/ (distance STP ENP) 2.0)) 
      (angle cenp 
             (polar stp (angle stp enp) (/ (distance STP ENP) 2.0)) 
      ) 
      (- radius 
         (distance (polar stp (angle stp enp) (/ (distance STP ENP) 2.0)) 
                   cenp 
         ) 
      ) 
    ) 
  ) 
  (list stp enp arcmidpoint) 
) 
 
 
;;8 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;判断点在直线上的位置 
;;语法：(pntonline p1 p2 p3 wc)   
;;参数   
;;p1,p2：直线上的两点，例如直线上的起点和端点，三维点 
;;p3：所要判断的点  ，三维点 
;;wc:阀值，即当三点的夹角小于WC值时认为P3点在线上，以秒为单位 
;;返回值  :实数 
;;等于0时点在线上，大于0时点在线的左侧，小于0时点在线的右侧   
(defun pntonline (p1 p2 p3 wc / p c B C P z) 
  (setq p p3) 
 
  (setq        z (apply '+ 
                 (mapcar '(lambda (b) 
                            (setq c (- (* (car p) (cadr b)) (* (cadr p) (car b))) 
                                  p b 
                            ) 
                            c 
                          ) 
                         (list p1 p2 p3) 
                 ) 
          ) 
  ) 
  (if (< (abs z) (* wc 0.0614658)) 
    (setq z 0) 
    (setq z z) 
  ) 
) 
 
 
;;9 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;由全路径返回盘符 
;;语法   
;;(JustDrive cFileName)   
;;参数   
;;cFileName:str 要检查的文件完整路径   
;;返回值   
;;[STR]   
;;样例   
;;(setq a "C:\\MyFolder\\MyFile.txt") 
;;; (JustDrive a) ; 返回 "C:"   
(defun JustDrive (cFileName / return) 
  (if (> (strlen cFileName) 1)                ; 查看第二个字符是否为“:” 
    (progn 
      (setq return (substr cfileName 1 2)) 
      (if (not (= ":" (substr return 2 1))) 
        (setq return "") 
      ) ;_ end of if 
    ) ;_ end of progn 
    (setq return "") 
  ) ;_ end of if 
  return 
) ;_ end of defun   
 
 
;;10 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;由全路径返回扩展名 
;;语法   
;;(JustExt cFileName)   
;;参数   
;;cFileName:str 要检查的全路径   
;;返回值   
;;[STR]   
;;样例   
;;(setq a "C:\\MyFolder\\MyFile.txt") 
;;(JustExt a) ; 返回 "txt" 
(defun JustExt (cFileName / dotLoc) 
  (setq dotLoc (rat "." cfileName)) 
  (if (> dotLoc 0) 
    (substr cFilename (1+ dotLoc)) 
    "" 
  ) ;_ end of if 
) ;_ end of defun   
 
 
;;11 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;由全路径和文件名返回不带扩展名的文件名 
;;语法   
;;(JustStem cFileName)   
;;参数   
;;cFileName：str 要检查的完整路径   
;;返回值   
;;[STR]   
;;样例   
;;(setq a "C:\\MyFolder\\MyFile.txt") 
;;(JustStem a) ; 返回 "MyFile"   
(defun JustStem        (cFileName / fName DotLoc) 
  (setq fName (justFName cFileName)) 
  (setq DotLoc (rat "." fName)) 
  (if (> DotLoc 0) 
    (substr fName 1 (1- DotLoc)) 
    fName 
  ) ;_ end of if 
) ;_ end of defun   
 
 
;;12 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;由全路径及文件名返回局部的文件名 
;;语法   
;;(JustFName cFileName)   
;;参数   
;;cFileName:str 要全的完整路径   
;;返回值   
;;[STR]   
;;样例   
;;(setq a "C:\\MyFolder\\MyFile.txt") 
;;(JustStem a) ; 返回 "MyFile.txt" 
(defun JustFName (cFileName / bsLoc ColonLoc) 
  ;; Check for BackSlash 
  (setq bsLoc (rat "\" cfileName)) 
  (if (> bsLoc 0) 
    (substr cFilename (1+ bsLoc)) 
    (progn 
      ;; 检查盘号 ":" 
      (setq ColonLoc (rat ":" cfileName)) 
      (if (> ColonLoc 0) 
        (substr cFilename (1+ ColonLoc)) 
        cFileName 
      ) ;_ end of if 
    ) ;_ end of progn 
  ) ;_ end of if 
) ;_ end of defun   
 
 
;;13 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;由全路径和文件名返回局部的路径 
;;语法   
;;(JustPath cFileName)   
;;参数   
;;cFileName:检查的字符串   
;;返回值   
;;[STR]   
;;样例   
;;(setq a "C:\\MyFolder\\MyFile.txt") 
;;(JustPath a) ; 返回 "C:\MyFolder"   
(defun JustPath        (cFileName / bsLoc) 
  (setq bsLoc (rat "\" cfileName)) 
  (if (> bsLoc 0) 
    (substr cFilename 1 (1- bsLoc)) 
    "" 
  ) ;_ end of if 
) ;_ end of defun   
 
 
;;14 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;将一个字符串按BASE的做为基数的进制转换为十进制的整数值 
;;语法   
;;(baseToDecimal base val )   
;;参数   
;;base:一个代表所要转换的进制(BASE2、BASE8等)基数整数。 
;;val:一个进行转换的字符串。   
;;返回值   
;;十进制的整数值   
;;样例   
;;(baseToDecimal 16 "FA")   
(defun baseToDecimal (base val / pos power result tmp) 
  (setqpos (1+ (strlen val)) 
           power 
           -1 
           result 
           0 
           val 
           (strcase val) 
  ) 
  (while (> (setq pos (1- pos)) 0) 
    (setq result 
           (+ 
             result 
             (*        (if (> (setq tmp (ascii (substr val pos 1))) 64) 
                  (- tmp 55) 
                  (- tmp 48) 
                ) 
                (expt base (setq power (1+ power))) 
             ) 
           ) 
    ) 
  ) 
  result 
) 
 
 
;;15 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;将一个整数转换成一个按BASE基数指定的进制的字符串值 
;;语法   
;;(decimalToBase base val )   
;;参数   
;;base:一个代表所要转换的进制(BASE2、BASE8等)基数整数。 
;;val:一个要转换的整数。 
;;返回值   
;;字符串   
;;样例   
;;(decimalToBase 16 250)   
(defun decimalToBase (base val / result tmp) 
  (setq result "") 
  (while (> val 0) 
    (setq result (strcat (if (> (setq tmp (rem val base)) 9) 
                           (chr (+ tmp 55)) 
                           (itoa tmp) 
                         ) 
                         result 
                 ) 
          val         (fix (/ val base)) 
    ) 
  ) 
  result 
) 
 
 
;;16 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;By Longxin 明经通道 2001.08 
;;返回多义线顶点的坐标 
;;语法   
;;(coords ename )   
;;参数   
;;ename:图元名 
;;返回值   
;;坐标列表  ，三维点 
(defun coords (ename / dxf type_line xy_count) 
  (setq        dxf          (entget ename) 
        TYPE_LINE (CDR (ASSOC 0 DXF)) 
  ) 
  (COND        ((= TYPE_LINE "POLYLINE") 
         (SETQ XY_COUNT (POL_coord eNAME)) 
        ) 
        ((= TYPE_LINE "LWPOLYLINE") 
         (SETQ XY_COUNT (LW_coord ename)) 
        ) 
        ((= TYPE_LINE "LINE") 
         (SETQ XY_COUNT (LINE_coord DXF)) 
         ) 
  ) 
) 
;;;;;;; 
(defun line_coord (dxf / pt1 pt2 count_xy) 
  (setq pt1 (cdr (assoc 10 dxf)) 
        pt2 (cdr (assoc 11 dxf)) 
        count_xy (list pt1 pt2) 
  ) 
  ) 
;;;;;;;;;;;;;;;;;;; 
(defun POL_coord        (E1 / dxf XY E2 count_xy pd) 
  (setq        count_xy nil 
        dxf 
         (entget e1) 
        DXF 
         (MEMBER (ASSOC 330 DXF) DXF) 
        E2 
         (ENTNEXT E1) 
        DXF 
         (ENTGET E2) 
  ) 
 
  (setq e1 (cdr (assoc 0 dxf))) 
  (while (= e1 "VERTEX") 
    (setq e1 (cdr (assoc 10 dxf))) 
    (setq pd (cdr (assoc 70 dxf))) 
    (if        (/= pd 16) 
      (setq count_xy (cons e1 count_xy)) 
    ) 
    (setq e1 e2) 
    (SETQ E2  (ENTNEXT E1) 
          DXF (ENTGET E2) 
          e1  (cdr (assoc 0 dxf)) 
    ) 
  ) 
  (setq COUNT_XY (reverse count_xy)) 
) 
;;;;;;;;;;;;;;;;;;;;;;; 
(defun LW_coord (e1 / dxf XY COUNT_XY h) 
  (setq        dxf         (entget e1) 
        xy         (ASSOC 10 DXF) 
        h         (list (cdr (ASSOC 38 DXF))) 
        COUNT_XY nil 
  ) 
  (WHILE XY 
    (SETQ DXF           (MEMBER XY DXF) 
          XY           (CDR (ASSOC 10 DXF)) 
          DXF           (CDR DXF) 
          COUNT_XY (CONS (append XY h) COUNT_XY) 
          XY           (ASSOC 10 DXF) 
    ) 
  ) 
  (setq COUNT_XY (reverse COUNT_XY)) 
) 
 
;;17 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;判断多义线或者坐标例表是否逆时针 
;;语法：(PlineCCW pline) 
;;参数： 
;;pline:多义线图元名 或者坐标例表如((x1 y1 z1) (x2 y2 z2))\((x1 y1) (x2 y2)) 
;;返回值:T OR nil 
;;T:逆时针 
;;NIL:顺时针 
 
(defun PlineCCW        (pline /) 
  (if (= (type pline) 'LIST) 
    (PlineCCW_list pline)                ;如果pline为坐标例表，则调用LIST处理函数 
    (PlineCCW_obj pline)                ;否则调用obj处理函数 
  ) 
) 
 
;;;;; 
(defun GEO_CCW (p0 p1 p2 p3 / ang1 ang2 ang3) 
  (setq ang1 (angle p0 p1)) 
  (setq ang2 (angle p0 p2)) 
  (setq ang1 (- ang2 ang1)) 
  (if (> (abs ang1) pi) 
    (setq ang1 (+ (* -2 pi (/ ang1 (abs ang1))) ang1)) 
  ) 
  (setq ang3 (angle p0 p3)) 
  (setq ang2 (- ang3 ang2)) 
  (if (> (abs ang2) pi) 
    (setq ang2 (+ (* -2 pi (/ ang2 (abs ang2))) ang2)) 
  ) 
  (if (> (* ang1 ang2) 0) 
    (/ ang1 (abs ang1)) 
    (cond 
      ((> (abs ang1) (abs ang2)) 
       (if (= ang2 0) 
         0 
         (/ ang2 (abs ang2)) 
       ) 
      ) 
      ((<= (abs ang1) (abs ang2)) 
       (if (= ang1 0) 
         0 
         (/ ang1 (abs ang1)) 
       ) 
      ) 
    ) 
  ) 
) 
;;;;;图元名的处理函数 
(defun PlineCCW_obj 
                    (pline   /             pline   step    param   nParam 
                     pt             pt1     pt2     ptc     i             mp 
                     CCWLST  new_pline 
                    ) 
 
  (setq step 100) 
  (setq        mp (vla-get-modelspace 
             (vla-get-activedocument (vlax-get-acad-object)) 
           ) 
  ) 
 
  ;;求得PLINE外围矩形的中心坐标 
  (vla-getboundingbox 
    (vlax-ename->vla-object pline) 
    'pt1 
    'pt2 
  ) 
  (setq        pt1 (vlax-safearray->list pt1) 
        pt2 (vlax-safearray->list pt2) 
        ptc (list (/ (+ (car pt1) (car pt2)) 2.0) 
                  (/ (+ (cadr pt1) (cadr pt2)) 2.0) 
            ) 
  ) 
  ;;end求得PLINE外围矩形的中心坐标 
  (setq        param (/ (vlax-curve-getDistAtParam 
                   pline 
                   (vlax-curve-getEndParam pline) 
                 ) 
                 step 
              ) 
  ) 
  (setq i 0) 
  (repeat (1- step) 
    (setq nParam (* i param)) 
    (setq pt (vlax-curve-getPointAtdist pline nParam)) 
    (setq pt1 (vlax-curve-getPointAtdist 
                pline 
                (+ (* (/ 0.5 step) param) nParam) 
              ) 
    ) 
    (setq pt2 (vlax-curve-getPointAtdist 
                pline 
                (+ (* (/ 1.0 step) param) nParam) 
              ) 
    ) 
    (setq CCWLST (append CCWLST (list (GEO_CCW ptc pt pt1 pt2)))) 
    (setq i (1+ i)) 
  ) 
 
  (if (> (length (vl-remove 1.0 CCWLST)) 
         (length (vl-remove -1.0 CCWLST)) 
      ) 
    nil 
    t 
  ) 
)                                        ;end defun PlineCCW_obj 
;;;;;;坐标例表的处理函数 
(defun plineccw_list (plist / temp new) 
  (makepline plist 1 0 nil) 
  (setq        new  (entlast) 
        temp (PlineCCW_obj new) 
  ) 
  (entdel new) 
  temp 
) 
                                        ;end defun PlineCCW_list 
 
;;18 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;//王咣生 
;;从点列表(point list)得到坐标范围(coordinate extents). 
;;例如: (GetExtents '((1 0 0) (2 2 0) (1 2 0))) 
;;;;返回：((x1 y1 z1)_min (x2 y2 z2)_max) 
(defun GetExtents (plist /) 
  (list 
    (apply 'mapcar (cons 'min plist)) 
    (apply 'mapcar (cons 'max plist)) 
  ) 
) 
 
 
;;19 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
;;取得当前绘图区屏幕的左下角和右上角的坐标 
;;返回：((x1 y1 z1)_min (x2 y2 z2)_max) 
(defun coord_screen (/ c03 c08 c04 c05 c07 c06 c09 c01 c02) 
  (setq        c03 (getvar "viewctr") 
        c03 (trans c03 1 2) 
        c08 (getvar "viewsize") 
        c04 (getvar "screensize") 
        c07 (car c04) 
        c06 (cadr c04) 
        c09 (/ (* c08 c07) c06) 
        c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08))) 
        c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08))) 
        c01 (trans c01 2 1) 
        c02 (trans c02 2 1) 
  ) 
  (list c01 c02) 
) 
 
 
;;20 
;| (xl-subi lst ilst nlst)---------作  者: 狂刀 [[url]www.xdcad.net[/url]] 
功  能   : 表中指定位置插入新元素或删除指定位置元素 
参  数   : lst = 表 ; 
           ilst = 索引值或索引值表; 
           nlst = 插入的元素或对应索引值表数量的插入元素表,nil 时为删除; 
返回值   : 成功返回新表，否则返回原表; 
注  意   : 1 插入/删除位置为相对原表的位置，从 0 计数; 
实　例　 : 
(xl-subi '(1 2 3 4 5 6) '(1 4) '(0 0) ) ;;->(1 0 2 3 4 0 5 6) 
(xl-subi '(1 2 3 4 5 6) '(1 4) '(0 nil)) ;;->(1 0 2 3 4 6) 
(xl-subi '(1 2 3 4 5 6) '(1 4) '(0 )) ;;->(1 0 2 3 4 6) 
(xl-subi '(1 2 3 4 5 6) '(1 4) nil);;->(1 3 4 6) 
(xl-subi '(1 2 3 4 5 6)  2 0);;->(1 2 0 3 4 5 6) 
(xl-subi '(1 2 3 4 5 6) 2 nil);;->(1 2 4 5 6) 
|; 
(defun xl-subi (lst ilst nlst / i a) ;; by 狂刀.2005.8 
(if (/= 'LIST (type ilst))(setq ilst (list ilst))) 
(if (/= 'LIST (type nlst))(setq nlst (list nlst))) 
(apply 'append (mapcar '(lambda(x) 
                          (setq i (if i (1+ i) 0)) 
                          (if (= (car ilst) i) 
                            (progn 
                              (setq ilst (cdr ilst) 
                                    a    (car nlst) 
                                    nlst (cdr nlst)) 
                              (if a (list a x)nil) 
                             ) 
                            (list x) 
                           ) 
                          ) 
                       lst) 
 ) 
) 
 
;;21 
;;对表按指定索引重新排序 
;;如：(order-i '(1 3 6 2 3) 1)---->(3 6 2 3 1) 
 
(defun order-i (lst i / n j mi) 
  (setq n (length lst) 
        j i) 
  (repeat (- n i) 
   (setq mi (append mi (list (nth j lst))) 
         j (1+ j)) 
  ) 
  (setq j 0) 
  (repeat  i 
    (setq mi (append mi (list (nth j lst))) 
          j (1+ j)) 
  ) 
  mi 
 )

qjcpj · 发表于 2006-5-2 22:46:23

希望能继续...

fsxm · 发表于 2006-5-7 18:32:20

返回两曲线交点的函数为什么我这里用不了啊？
每次都反回nil

jx2008 · 发表于 2007-6-29 17:13:24

希望搂主继续贴常用的函数！顶了

拉契 · 发表于 2014-4-16 10:35:25

楼主继续增加啊！顶一个

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

[分享]：整理了一些常用的函数，有一些用得比较频繁，陆续增加中

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

相关帖子

浏览过的版块