- 积分
- 15871
- 明经币
- 个
- 注册时间
- 2011-3-22
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
楼主 |
发表于 2012-10-24 20:00:02
|
显示全部楼层
程序已经搞定，见下面，里面小程序较多，加载后使用daduan命令执行
;;更改多段线的顺时针还是逆时针
;; Subject: Re: invert the direction of a polyline
;; From: vnestr@netvision.net.il (Vladimir Nesterovsky)
;; Date: 1997/03/01
;; Newsgroups: comp.cad.autocad
;;
;; Try this:
;; This is (C.) by Vladimir Nesterovsky, 1997
;; e-mail: vnestr@netvision.net.il
;; YOU MAY USE THIS CODE ONLY FOR *NON-COMMERCIAL*
;; PURPOSES AND ONLY IF YOU RETAIN
;; THIS HEADER COMPLETE AND UNALTERED
;; you must contact me if you want to use it commercially
(defun c:invpl ()
(r-ss-foreach
(ssget '((0 . "POLYLINE")))
'inv-pl
)
(princ "\nInverted!")
(princ)
)
;; repeat (foo e-name) for each e-name in SelSet
;; in reversed order
(defun r-ss-foreach (ss qfoo / n)
(if (= 'PICKSET (type ss))
(repeat (setq n (fix (sslength ss)))
;; a little fix
(apply qfoo (list (ssname ss (setq n (1- n)))))
)
)
)
(defun dxf (a b) (cdr (assoc a b)))
;;Invert polyline
(defun inv-pl (e / d0 di d bl pl swl ewl)
(setq d0 (entget e '("*")))
;; keep xdata
(while (/= "SEQEND"
(dxf 0
(setq di
(entget (setq e (entnext e)))
)
)
)
(setq d di
pl (cons (dxf 10 d) pl)
swl (cons (dxf 40 d) swl)
ewl (cons (dxf 41 d) ewl)
bl (cons (- (dxf 42 d)) bl)
)
)
(setq ;; cycle the lists
bl (append (cdr bl) (list (car bl)))
swl (append (cdr swl) (list (car swl)))
ewl (append (cdr ewl) (list (car ewl)))
)
(entmake d0)
(mapcar
'(lambda (p b sw ew)
(entmake
(subst (cons 10 p)
(assoc 10 d)
(subst (cons 42 b)
(assoc 42 d)
(subst (cons 40 sw)
(assoc 40 d)
(subst (cons 41 ew)
(assoc 41 d)
d
)
)
)
)
)
)
pl
bl
ewl
swl
)
(entmake (list '(0 . "SEQEND") (cons 8 (dxf 8 d0))))
(entdel (dxf -1 d0))
(redraw (entlast))
(princ)
)
;; You can alter this code to carry vertex widths also,
;; if you care.
;;
;; ------- Original message: -------
;; On 21 Feb 1997 11:15:00 GMT, - "Decurtins Reto" wrote
;; in comp.cad.autocad:
;;
;; Is this possible and how ?
;;; Changes:
;;; 1997/11/06: slight improvements:
;;; inv-pl to carry width info and keep EED
(defun c:ww (/ ee p1)
(VL-LOAD-COM)
(setq ee (car (entsel "选择对象")))
(setq p1 (getpoint "选择顶点"))
(plchangestart ee p1)
)
;;子程序，修改以捕捉端点方式“闭合”的pline使其闭合，
;;并按指定点作为起点重绘pline，最后返回pline的组码。
(defun plchangestart
(ee p1 / pt dat ptfrst ename aa data datb dat0 dat1 dat9)
(setq pt (list (car p1) (cadr p1)))
(setq dat (entget ee))
(setq ptfrst (cons 10 pt))
(setq ename (vlax-ename->vla-object ee))
(if (vlax-curve-isclosed ename)
(setq dat dat)
(progn (setq dat (subst (cons 70 129) (assoc 70 dat) dat))
(setq data (list (last dat)))
(setq datb (reverse (cdr (cdr (cdr (cdr (cdr (reverse dat))))))))
(setq dat (entmod (append datb data)))
) ;_ 结束progn
) ;_ 结束if
;;以上一段：如果pl最终不是以“c”闭合而是以捕捉端点方式“闭合”，
;;则修改组码使其达到闭合效果。
(setq dat0 (reverse (member (assoc 39 dat) (reverse dat)))
dat1 (cdr (member (assoc 39 dat) dat))
dat9 (list (last dat1))
dat1 (reverse (cdr (reverse dat1)))
data (member ptfrst dat1)
datb (reverse (cdr (member ptfrst (reverse dat1))))
) ;_ 结束setq
(entmod (append dat0 data datb dat9))
;;以上一段：修改组码，使pline从指定点开始。
) ;_ 结束defun
;;判断多义线的顺逆
(defun C:testSS (/ doc utility mspace ss fd
ang offsetObj plineObj pt0 pt1
intpoints
)
(setq doc (vla-get-activeDocument (vlax-get-acad-object)))
(setq utility (vla-get-utility doc))
(setq mspace (vla-get-modelspace doc))
(if (setq ss (ssget ":s" '((0 . "*POLYLINE"))))
(progn
(setq plineObj (vlax-ename->vla-object (ssname ss 0)))
;;Gu_xl自己忘注释了，注释后不现出现除数为0的错误
;;(setq fd (vlax-curve-getFirstDeriv plineObj 0.5))
;;(setq ang (atan (/ (cadr fd) (car fd))))
(setq offsetplineObj
(car (vlax-safearray->list
(vlax-variant-value
(vla-offset plineObj 0.0001)
)
)
)
)
(setq
pt0 (vlax-3d-point (vlax-curve-getPointAtParam plineObj 0.5))
)
(setq pt1 (vla-PolarPoint utility pt0 (- ang (/ pi 2)) 0.00011))
(setq lineObj (vla-addLine mspace pt0 pt1))
(setq intpoints (vla-intersectwith
offsetplineObj
lineObj
acExtendNone
)
)
(if (> (vlax-safearray-get-u-bound
(vlax-variant-value intpoints)
1
)
0
)
(princ "\n该多义线为顺时针。")
(princ "\n该多义线为逆时针。")
)
(vla-delete offsetplineObj)
(vla-delete lineObj)
) ;progn
(princ "\n没有选择图元或非多义线。")
) ;end_if
(princ)
)
;;判断多义线的顺逆
(defun YTM:PLsn (ss / doc utility mspace ss
fd ang offsetObj plineObj pt0
pt1 intpoints flag
)
(setq doc (vla-get-activeDocument (vlax-get-acad-object)))
(setq utility (vla-get-utility doc))
(setq mspace (vla-get-modelspace doc))
(if ;(setq ss (ssget ":s" '((0 . "*POLYLINE"))))
ss
(progn
;;(setq plineObj (vlax-ename->vla-object (ssname ss 0)))
(setq plineObj (vlax-ename->vla-object ss))
(setq fd (vlax-curve-getFirstDeriv plineObj 0.5))
(setq ang (atan (/ (cadr fd) (car fd))))
(setq offsetplineObj
(car (vlax-safearray->list
(vlax-variant-value
(vla-offset plineObj 0.0001)
)
)
)
)
(setq
pt0 (vlax-3d-point (vlax-curve-getPointAtParam plineObj 0.5))
)
(setq pt1 (vla-PolarPoint utility pt0 (- ang (/ pi 2)) 0.00011))
(setq lineObj (vla-addLine mspace pt0 pt1))
(setq intpoints (vla-intersectwith
offsetplineObj
lineObj
acExtendNone
)
)
(if (> (vlax-safearray-get-u-bound
(vlax-variant-value intpoints)
1
)
0
)
;;(princ "\n该多义线为顺时针。")
(setq flag T)
;;(princ "\n该多义线为逆时针。")
(setq flag nil)
)
(vla-delete offsetplineObj)
(vla-delete lineObj)
) ;progn
;;(princ "\n没有选择图元或非多义线。")
) ;end_if
;;(princ)
flag
)
(defun c:lsp_48 ()
(setvar "cmdecho" 0)
(setq ffn (getfiled "选取文件" "" "txt" 1))
(setq ff (open ffn "w"))
(close ff)
(princ "\n选取PLINE多段线...")
(setq ss (ssget))
(setq i 0)
(setvar "pdmode" 33)
(repeat (sslength ss)
(setq ssn (ssname ss i))
(setq endata (entget ssn))
(setq n 0)
(repeat (length endata)
(setq pp (nth n endata))
(setq key (car pp))
(if (= key 10)
(progn
(setq x (cadr pp))
(setq y (caddr pp))
(command "point" (list x y))
(setq ff (open ffn "a"))
(princ x ff)
(princ " " ff)
(princ y ff)
(princ "\n" ff)
(close ff)
)
)
(setq n (1+ n))
)
(setq ff (open ffn "a"))
(princ "End\n" ff)
(close ff)
(setq i (1+ i))
)
(princ (strcat "\n文件写至=> " ffn))
(prin1)
)
;;下面开始改造，用于将坐标显示在点的附近
(defun c:test1 ()
(setvar "cmdecho" 0)
(princ "\n选取PLINE多段线...")
(setq ss (ssget))
(setq i 0)
(setvar "pdmode" 33)
(COMMAND "-style" "mystyle09" "Times New Roman"
5 1 0 "N"
"N"
)
(setq lst '()
kk 0
ptlst (YTM:Bulge ss)
pt0 (getpoint "\n请输入基准点:")
)
(repeat (sslength ss)
(setq ssn (ssname ss i))
(setq endata (entget ssn))
(setq enSN (YTM:PLsn ssn))
(setq n 0)
(repeat (length endata)
(setq pp (nth n endata))
;;(setq startpt(assoc
(setq key (car pp))
(if (= key 10)
(progn
(setq pt (list (cadr pp) (caddr pp)))
(if enSN
(setq str
(strcat "顺时针###"
(itoa kk)
" ### "
(rtos (- (cadr pp) (car pt0)) 2)
" ### "
(rtos (- (caddr pp) (cadr pt0)) 2)
(vl-princ-to-string (nth kk (reverse ptlst)))
)
)
(setq str
(strcat "逆时针###"
(itoa kk)
" ### "
(rtos (- (cadr pp) (car pt0)) 2)
" ### "
(rtos (- (caddr pp) (cadr pt0)) 2)
(vl-princ-to-string (nth kk ptlst))
)
)
)
(entmake (list '(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
'(7 . "mystyle09")
'(71 . 1)
'(40 . 0.35)
;;字高由此组码控制
(cons 1 str)
(cons 10 pt)
)
)
(setq lst (cons (list i kk pt) lst))
(setq kk (1+ kk))
)
)
(setq n (1+ n))
)
(setq i (1+ i))
(setq kk 0)
)
(princ ptlst)
(princ)
(prin1)
)
;;;******************************************************
;;;一个求多义线各段参数(如果是弧段则有半径弧长)的lisp程序
;;;编号 1:凸度，2:弦长或直段长，3:半径，4:弧长，5:圆心--
;;;加载程序，运行bulge，则显示上述参数-------------------
(defun midp (p1 p2)
;;BY 高飞鸟
(polar p1 (angle p1 p2) (* (distance p1 p2) 0.5))
)
(defun C:Bulge (/ sel ent lst obj vex ifclose
i par 1stPt EndPt judge tu pt1
pt2 dis radius h h1 half-angle
arc-length pa cen
)
(if (setq sel (ssget '((0 . "LWPOLYLINE"))))
(progn
(setq ent (ssname sel 0))
(setq lst (entget ent))
(setq obj (vlax-ename->vla-object ent))
(setq vex (cdr (assoc 90 lst)))
(setq ifclose (cdr (assoc 70 lst)))
(setq i 0
par nil
)
(setq 1stPt (vlax-Curve-GetPointAtParam ent 0))
(setq EndPt (vlax-Curve-GetPointAtParam ent (1- vex)))
(if (or (equal 1stPt EndPt 1e-8) (= ifclose 0))
(setq vex (1- vex))
)
(repeat vex
(setq tu (vla-GetBulge obj i))
(setq pt1 (vlax-Curve-GetPointAtParam ent i))
(if (and (= i (1- vex)) judge)
(setq pt2 (vlax-Curve-GetPointAtParam ent 0))
(setq pt2 (vlax-Curve-GetPointAtParam ent (1+ i)))
)
(setq dis (distance pt1 pt2))
(if (/= tu 0)
(progn
(setq radius (/ (* (1+ (* tu tu)) dis 0.25) (abs tu)))
(setq h (* dis (abs tu) 0.5)
h1 (- radius h)
)
(setq half-angle (atan (/ dis 2) h1))
(setq arc-length (* 2 half-angle radius))
(setq cen (midp pt1 pt2))
(setq cen (polar cen
(+ (angle pt1 pt2)
(if (or nil
(and (> h1 0) (> tu 0))
(and (< h1 0) (< tu 0))
)
(* pi 0.5)
(* pi -0.5)
)
)
(abs h1)
)
)
(setq pa (list tu dis radius arc-length cen))
(setq par (cons pa par))
)
(progn
(setq pa (list tu dis))
(setq par (cons pa par))
)
)
(setq i (1+ i))
)
(setq par (reverse par))
(princ "\n下面为此曲线的各段列表,3,4,5编号为弧段才有:")
(princ "\n1:凸度 2:弦长(或直线长) 3:半径 4:弧长 5:圆心")
(foreach n par
(princ "\n")
(princ n)
)
(princ)
)
(alert "你没有选中物体或者选择的不是多义线!")
)
(princ)
)
(defun YTM:Bulge (sel / ent lst obj vex
ifclose i par 1stPt EndPt judge
tu pt1 pt2 dis radius h
h1 half-angle arc-length pa
cen
)
;;(if (setq sel (ssget '((0 . "LWPOLYLINE"))))
(if sel
(progn
;;(setq ent (ssname sel 0))
(setq ent sel)
(setq lst (entget ent))
(setq obj (vlax-ename->vla-object ent))
(setq vex (cdr (assoc 90 lst)))
(setq ifclose (cdr (assoc 70 lst)))
(setq i 0
par nil
)
(setq 1stPt (vlax-Curve-GetPointAtParam ent 0))
(setq EndPt (vlax-Curve-GetPointAtParam ent (1- vex)))
(if (or (equal 1stPt EndPt 1e-8) (= ifclose 0))
(setq vex (1- vex))
)
(repeat vex
(setq tu (vla-GetBulge obj i))
(setq pt1 (vlax-Curve-GetPointAtParam ent i))
(if (and (= i (1- vex)) judge)
(setq pt2 (vlax-Curve-GetPointAtParam ent 0))
(setq pt2 (vlax-Curve-GetPointAtParam ent (1+ i)))
)
(setq dis (distance pt1 pt2))
(if (/= tu 0)
(progn
(setq radius (/ (* (1+ (* tu tu)) dis 0.25) (abs tu)))
(setq h (* dis (abs tu) 0.5)
h1 (- radius h)
)
(setq half-angle (atan (/ dis 2) h1))
(setq arc-length (* 2 half-angle radius))
(setq cen (midp pt1 pt2))
(setq cen (polar cen
(+ (angle pt1 pt2)
(if (or nil
(and (> h1 0) (> tu 0))
(and (< h1 0) (< tu 0))
)
(* pi 0.5)
(* pi -0.5)
)
)
(abs h1)
)
)
(setq pa (list tu dis radius arc-length cen))
(setq par (cons pa par))
)
(progn
(setq pa (list tu dis))
(setq par (cons pa par))
)
)
(setq i (1+ i))
)
(setq par (reverse par))
;;(princ "\n下面为此曲线的各段列表,3,4,5编号为弧段才有:")
;;(princ "\n1:凸度 2:弦长(或直线长) 3:半径 4:弧长 5:圆心")
;;(foreach n par
;; (princ "\n")
;; (princ n)
;;)
;;(princ)
)
;;(alert "你没有选中物体或者选择的不是多义线!")
)
;;(princ)
par
)
;;;******************************************************
;;定义多段线的起点，
(defun c:test2 ()
(setq ee (car (entsel)))
(setq p1 (getpoint))
(setq pt (list (car p1) (cadr p1)))
(setq dat (entget ee) ; LwPolyLine ee
ptfrst (cons 10 pt) ; pt ==> 新起点 say '(100 200)
dat0 (reverse (member '(39 . 0.0) (reverse dat)))
dat1 (cdr (member '(39 . 0.0) dat))
dat9 (List (Last dat1))
dat1 (reverse (cdr (reverse dat1)))
data (member ptfrst dat1)
datb (reverse (cdr (member ptfrst (reverse dat1))))
)
(print pt)
(print dat)
(entmod (append dat0 data datb dat9))
)
(defun c:test3 ()
(setq en (car (entsel)))
(setq endata (entget en))
(setq pp (nth n endata))
;;(setq startpt(assoc
(setq key (car pp)
lst '()
)
(if (= key 10)
(setq lst (cons pp lst))
)
)
;;[函数]取得多义线顶点表的最短代码 mkhsj928
;;http://bbs.mjtd.com/forum.php?mod=viewthread&tid=52136
(defun get-pl-ptlst (plent / ptlst)
(vl-load-com)
(setq ptlst (vl-remove-if
'(lambda (x)
(/= 10 (car x))
)
(entget plent)
)
)
(mapcar 'cdr ptlst)
)
;;;gxl-NumJD Num 数字 Jd 数字保留小数点位数，四舍五入
(defun gxl-NumJD (Num JD / Num1 d)
(if (> Num 0)
(setq d 0.5)
(setq d -0.5)
)
(setq Num1 (* 1.0 (expt 10 JD)))
(/ (fix (+ (* Num Num1) d)) Num1)
)
(defun c:test5 ()
(prompt "\n请选择一个多段线:")
(setq ss (car (entsel "\n请选择一个多段线:"))
ptlist (get-pl-ptlst ss)
bulgelist (YTM:Bulge ss)
pt (getpoint "\n请选择一个基准点:")
)
(if (and (equal (car (nth 0 ptlist)) (car pt) 1e-6)
(equal (cadr (nth 0 ptlist)) (cadr pt) 1e-6)
)
(setq ptlist (mapcar
'(lambda (x)
(list (gxl-NumJD (- (car x) (car pt)) 4)
(gxl-NumJD (- (cadr x) (cadr pt)) 4)
)
)
ptlist
)
bulgelist (append bulgelist (list (list 0 0)))
endlist (mapcar '(lambda (x y)
(list x y)
)
ptlist
bulgelist
)
)
(setq ptlist (mapcar
'(lambda (x)
(list (gxl-NumJD (- (car x) (car pt)) 4)
(gxl-NumJD (- (cadr x) (cadr pt)) 4)
)
)
ptlist
)
bulgelist (append (list (list 0 0)) bulgelist)
endlist (mapcar '(lambda (x y)
(list x y)
)
(reverse ptlist)
(reverse bulgelist)
)
)
)
(foreach n endlist
(progn
(entmake (list '(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
'(7 . "mystyle09")
'(71 . 1)
'(40 . 0.035)
;;字高由此组码控制
(cons 1 (vl-princ-to-string n))
(cons 10
(list (+ (car (car n)) (car pt))
(+ (cadr (car n)) (cadr pt))
)
)
)
)
)
)
;;(princ "\n下面为此曲线的各段列表,3,4,5编号为弧段才有:")
;;(princ "\n1:凸度 2:弦长(或直线长) 3:半径 4:弧长 5:圆心")
;;(nth 0 endlist)
;;((0.0 0.0) (0.205279 13.2998 16.8797 13.6703 (71.816 31.4007 0.0)))
(setq nn 0
zxcb ""
sn ""
RR ""
xzb ""
zzb ""
)
(setq ffn (getfiled "选取文件" "" "TXT" 1))
(setq f (open ffn "w"))
(princ (strcat "%" "\nG50X250.Z100"
"\nG0T0303" "\nG0X0.Z.5"
"\nG99G1Z0.F.06"
)
f
)
(repeat (1- (length endlist))
(setq aa (nth nn endlist))
(cond
((> (car (cadr aa)) 0)
(setq sn "G2"
;;我厂是G2来表示顺时针的圆弧插补，在程序中此值为正值
RR (strcat "R" (rtos (nth 2 (cadr aa)) 2 3))
)
)
((= (car (cadr aa)) 0)
(setq sn ""
RR ""
)
)
((< (car (cadr aa)) 0)
(setq sn "G3"
;;我厂是G3来表示逆时针的圆弧插补，在程序中此值为负值
RR (strcat "R" (rtos (nth 2 (cadr aa)) 2 3))
)
)
)
;;圆弧插补转直线插补时前面要加G1，
(if (and (> nn 1)
(/= (car (cadr (nth (1- nn) endlist))) 0)
(= (car (cadr (nth nn endlist))) 0)
)
(setq zxcb "G1")
(setq zxcb "")
)
(princ (strcat "\n"
zxcb
sn
"X"
(rtos (* 2 (cadr (car (nth (1+ nn) endlist)))) 2 3)
"Z"
(rtos (car (car (nth (1+ nn) endlist))) 2 3)
RR
)
f
)
(setq nn (1+ nn))
)
(princ (strcat "\nG0X250." "\nZ100." "\n M05"
"\nT0300" "\nM30" "\n%"
)
f
)
(close f)
(princ)
)
;;http://fsxm.bokee.com/viewdiary.15815943.html
;;加载幻灯片调用格式：(fsxm-loadsld 1.控件的KEY 2.sld的文件路径)
(defun fsxm-loadsld (key sld / x y)
(setq x (dimx_tile key)
y (dimy_tile key)
)
(start_image key)
(fill_image 0 0 x y -2)
(slide_image 0 0 x y sld)
(end_image)
;;; (princ x)
;;; (princ y)
)
;;;设置屏幕大小 (SetScreenSize 400 300)
;;Gu_xl http://bbs.mjtd.com/thread-90429-1-1.html
(defun SetScreenSize (Width height / doc oldsize doc w1 h1 dw dh)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq oldsize (getvar "SCREENSIZE"))
(setq W1 (vla-get-width doc))
(setq H1 (vla-get-Height doc))
(setq dw (- w1 (car oldsize)))
(setq dh (- h1 (cadr oldsize)))
(vla-put-width doc (+ dw width))
(vla-put-height doc (+ dh height))
)
(defun c:3c ()
(setvar "cmdecho" 0)
(setq word_list '("A型机夹尖刀" "B型机夹左偏刀"
"C型机夹右偏刀" "D型球刀"
"E型普通尖刀" "F型普通左偏刀"
"G型普通右偏刀"
)
)
(setq pophh_list '("R0.05" "R0.1" "R0.15" "R0.2" "R0.3" "R0.5"))
(setq DB "G42")
(setq dcl_id (load_dialog "dia7c"))
(new_dialog "dia7c" dcl_id)
(show_list "klist" word_list) ;调用显示词库“列表框”信息
(show_list "pophh" pophh_list) ;调用显示刀尖半径“下拉菜单”信息
(set_tile "klist" "3")
(sub_klist1 "3")
(sub_kimage "3")
(set_tile "txthh" "R0.05") ;预设刀尖半径编辑框=10
(action_tile
"klist"
"(sub_klist1 $value)(sub_kimage $value)"
)
(action_tile "pophh" "(sub_pophh $value)") ;调用子程序
(action_tile "BJYDB" "(setq DB \"G42\")") ;调用子程序
(action_tile "BJZDB" "(setq DB \"G41\")") ;调用子程序
(action_tile "accept" "(ok_dia7c)(done_dialog 1)")
(setq dd (start_dialog))
(if (= dd 1)
(progn
;;; (setq inspt (getpoint "文字写入点:"))
;;; (entmake
;;; (list '(0 . "MTEXT")
;;; '(100 . "AcDbEntity")
;;; '(100 . "AcDbMText")
;;; '(7 . "mystyle")
;;; (cons 1 wordstr)
;;; (cons 10 inspt)
;;; )
;;; )
(3ctest5 db 0.06)
)
;;end progn
)
(princ)
)
(defun show_list (key newlist)
(start_list key)
(mapcar 'add_list newlist)
(end_list)
)
(defun sub_klist1 (vvs)
(set_tile "wordstr" (nth (atoi vvs) word_list))
)
(defun sub_kimage (vvs)
(fsxm-loadsld
"kimage"
(strcat (nth (atoi vvs) word_list) ".sld")
)
)
(defun sub_pophh (vvs)
(set_tile "txthh" (nth (atoi vvs) pophh_list)) ;设置字号编辑框
)
(defun ok_dia7c ()
(setq wordstr (strcase (get_tile "wordstr"))) ;取得词库编辑框信息
(setq txthh (get_tile "txthh")) ;取得字高编辑框信息
)
(defun c:3 ()
(SetScreenSize 234 151)
(command "zoom" "e")
)
(defun 3ctest5 (str1 num1 /)
(prompt "\n请选择一个多段线:")
(setq ss (car (entsel "\n请选择一个多段线:"))
ptlist (get-pl-ptlst ss)
bulgelist (YTM:Bulge ss)
pt (getpoint "\n请选择一个基准点:")
)
(if (and (equal (car (nth 0 ptlist)) (car pt) 1e-6)
(equal (cadr (nth 0 ptlist)) (cadr pt) 1e-6)
)
(setq ptlist (mapcar
'(lambda (x)
(list (gxl-NumJD (- (car x) (car pt)) 4)
(gxl-NumJD (- (cadr x) (cadr pt)) 4)
)
)
ptlist
)
bulgelist (append bulgelist (list (list 0 0)))
endlist (mapcar '(lambda (x y)
(list x y)
)
ptlist
bulgelist
)
)
(setq ptlist (mapcar
'(lambda (x)
(list (gxl-NumJD (- (car x) (car pt)) 4)
(gxl-NumJD (- (cadr x) (cadr pt)) 4)
)
)
ptlist
)
bulgelist (append (list (list 0 0)) bulgelist)
endlist (mapcar '(lambda (x y)
(list x y)
)
(reverse ptlist)
(reverse bulgelist)
)
)
)
(foreach n endlist
(progn
(entmake (list '(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
'(7 . "mystyle09")
'(71 . 1)
'(40 . 0.035)
;;字高由此组码控制
(cons 1 (vl-princ-to-string n))
(cons 10
(list (+ (car (car n)) (car pt))
(+ (cadr (car n)) (cadr pt))
)
)
)
)
)
)
;;(princ "\n下面为此曲线的各段列表,3,4,5编号为弧段才有:")
;;(princ "\n1:凸度 2:弦长(或直线长) 3:半径 4:弧长 5:圆心")
;;(nth 0 endlist)
;;((0.0 0.0) (0.205279 13.2998 16.8797 13.6703 (71.816 31.4007 0.0)))
(setq nn 0
zxcb ""
sn ""
RR ""
xzb ""
zzb ""
)
(setq ffn (getfiled "选取文件" "" "TXT" 1))
(setq f (open ffn "w"))
(princ (strcat "%"
"\nG50X250.Z100"
"\nG0T0303"
(strcat "\nG0" DB "D03X0.Z.5")
"\nG99G1Z0.F.06"
)
f
)
(repeat (1- (length endlist))
(setq aa (nth nn endlist))
(cond
((> (car (cadr aa)) 0)
(setq sn "G2"
;;我厂是G2来表示顺时针的圆弧插补，在程序中此值为正值
RR (strcat "R" (rtos (nth 2 (cadr aa)) 2 3))
)
)
((= (car (cadr aa)) 0)
(setq sn ""
RR ""
)
)
((< (car (cadr aa)) 0)
(setq sn "G3"
;;我厂是G3来表示逆时针的圆弧插补，在程序中此值为负值
RR (strcat "R" (rtos (nth 2 (cadr aa)) 2 3))
)
)
)
;;圆弧插补转直线插补时前面要加G1，
(if (and (> nn 1)
(/= (car (cadr (nth (1- nn) endlist))) 0)
(= (car (cadr (nth nn endlist))) 0)
)
(setq zxcb "G1")
(setq zxcb "")
)
(princ (strcat "\n"
zxcb
sn
"X"
(rtos (* 2 (cadr (car (nth (1+ nn) endlist)))) 2 3)
"Z"
(rtos (car (car (nth (1+ nn) endlist))) 2 3)
RR
)
f
)
(setq nn (1+ nn))
)
(princ (strcat "\nG0X250." "\nZ100." "\n M05"
"\nT0300" "\nM30" "\n%"
)
f
)
(close f)
(princ)
)
(defun c:25 ()
(prompt "\n请选择要处理的对象:")
(setq ss (ssget '((0 . "LWPOLYLINE,DIMENSION")))
ss1 (ytm-get ss "LWPOLYLINE")
ss2 (ytm-get ss "DIMENSION")
i 0
k 0
en-pt-list '()
)
(setq ptlist1
(mapcar '(lambda (x)
(list (cdr (assoc 10 (entget x)))
(cdr (assoc 11 (entget x)))
)
)
ss2
)
)
(repeat (length ss2)
(setq en (nth i ss2)
endata (entget en)
pt1 (nth 0 (get-pl-ptlst en))
pt2 (nth 0 (reverse (get-pl-ptlst en)))
)
(repeat (length ptlist1)
(setq pt (nth k ptlist1))
(if (or (equal pt1 (car pt) 1e-6)
(equal pt1 (cadr pt) 1e-6)
)
(setq en-pt-list (cons (list en pt) en-pt-list))
)
(setq k (1+ k))
)
(setq i (1+ i))
)
(defun c:scc ()
(setq en (car (entsel)))
(setq pt (cdr (assoc 10 (entget en))))
(setq r (cdr (assoc 40 (entget en))))
(setq circle_list (list))
(setq i 0)
(repeat 360
(setq circle_list
(append (list (polar pt (* (1+ i) (/ 1 360.0) pi) r))
circle_list
)
)
(setq i (1+ i))
)
(setq ss (ssget "WP" circle_list))
(command "erase" ss "")
)
)
;;用于将多段线按标注位置进行打断
(defun C:BRF (/ e1 pt)
(setq e1 (entsel "\nSelect object: ")
pt (getpoint "\nPick a point: ")
)
(command "break" e1 "f" pt pt)
)
;;;(setq en(car(entsel)))
;;;(setq pt(getpoint))
;;;(command "break" en "" "F" pause pt pause pt)
(defun c:daduan ()
;;(setvar "osmode" 0)
(prompt "\n请选择要处理的对象:")
(setq ss (ssget '((0 . "LWPOLYLINE,DIMENSION")))
ss1 (nth 0 (ytm-get ss "LWPOLYLINE"))
ss2 (ytm-get ss "DIMENSION")
i 0
k 0
en-pt-list '()
lwptlist (vl-sort
(get-pl-ptlst ss1)
'(lambda (x y)
(> (cadr x) (cadr y))
)
)
maxy (cadr (nth 0 lwptlist))
miny (cadr (nth 0 (reverse lwptlist)))
)
(defun get-selpt (ptlist minx maxx / selpt i)
;;; (if (and (> (car (nth 0 ptlist)) minx)
;;; (=< (car (nth 0 ptlist)) maxx)
;;; )
;;; (setq selpt (nth 0 ptlist))
;;; (get-selpt (cdr ptlist) minx maxx)
;;; )
;;; selpt
(setq i 0)
(repeat (length ptlist)
(setq pt (nth i ptlist))
(if (and (> (car pt) minx)
(<= (car pt) maxx)
)
(setq selpt pt)
)
(setq i (1+ i))
selpt
)
)
(defun find-pt (ptlist pt / i lst)
(setq i 0
lst '()
)
(repeat (length ptlist)
(setq lst (cons (list (distance pt (nth i ptlist)) i) lst))
(setq i (1+ i))
)
(setq lst (vl-sort lst
'(lambda (x y)
(< (car x) (car y))
)
)
)
(nth (cadr (nth 0 lst)) ptlist)
)
(repeat (length ss2)
(setq pt13 (cdr (assoc 13 (entget (nth i ss2))))
pt14 (cdr (assoc 14 (entget (nth i ss2))))
pt1314 (vl-sort (list pt13 pt14)
'(lambda (x y)
(> (car x) (car y))
)
)
pt14 (list (+ (car (nth 0 (reverse pt1314))) (* 0.1 (- maxy miny)))
maxy
)
;;左上角点
pt13 (list (- (car (nth 0 pt1314)) (* 0.1 (- maxy miny))) miny)
;;右下角点
selpt (get-selpt lwptlist
(car (nth 0 (reverse pt1314)))
(car (nth 0 pt1314))
)
daduan1 (find-pt lwptlist (cdr (assoc 13 (entget (nth i ss2)))))
daduan2 (find-pt lwptlist (cdr (assoc 14 (entget (nth i ss2)))))
endata (entget (nth i ss2))
BZmc(cdr (assoc 1 (entget (nth i ss2))))
)
;;(command "rectang" pt13 pt14)
(setq en (ssname (ssget "c" pt14 pt13 '((0 . "LWPOLYLINE"))) 0))
(if (or (equal (cdr (assoc 13 (entget (nth i ss2))))
(nth 0 (get-pl-ptlst en))
1e-6
)
(equal (cdr (assoc 13 (entget (nth i ss2))))
(nth 0 (reverse (get-pl-ptlst en)))
1e-6
)
)
(princ "\n端点，不再打断")
(command "break"
(list en selpt)
"F"
(cdr (assoc 13 (entget (nth i ss2))))
(cdr (assoc 13 (entget (nth i ss2))))
)
)
(setq en (ssname (ssget "c" pt14 pt13 '((0 . "LWPOLYLINE"))) 0))
;;(command "line" '(0 0) selpt (cdr (assoc 14 (entget (nth i ss2)))) "")
(if (or (equal (cdr (assoc 14 (entget (nth i ss2))))
(nth 0 (get-pl-ptlst en))
1e-6
)
(equal (cdr (assoc 14 (entget (nth i ss2))))
(nth 0 (reverse (get-pl-ptlst en)))
1e-6
)
)
(princ "\n端点，不再打断")
(command "break"
(list en selpt)
"F"
(cdr (assoc 14 (entget (nth i ss2))))
(cdr (assoc 14 (entget (nth i ss2))))
)
)
(command "erase" (nth i ss2) "")
(entmake endata)
(amend_xDATA en BZmc)
(setq i (1+ i))
)
;;(setvar "osmode" 16383)
)
;;修改扩展数据
;;ENT---图形对象，xDATA---扩展数据值
(defun amend_xDATA (ENT xDATA / E C C1 B OBJ)
(setq E (entget ENT (list "*")))
(setq C1 (car (cadadr (setq C (assoc -3 E)))))
(setq B (cons (car C) (list (list (caadr C) (cons C1 xDATA)))))
(setq OBJ (subst B C E))
(entmod OBJ)
)
;;;(defun c:aaa ()
;;; (setq xDATA "OK")
;;; (setq ent (car (entsel "\n选取对象:")))
;;; (amend_xDATA ENT xDATA)
;;;)
;;;不能通过查找替换来实现
;;;根据你给的群码，要修改("FLOOR" (1070 . 2)),可根据以下程序实现：
;;;(defun c:XG ()
;;; (setq s (car (entsel "\n选择实体: ")))
;;; (setq N (getint "输入整数："))
;;; (XG_XDATA s N)
;;;)
;;修改扩展数据
(defun XG_xDATA (ENT xDATA / E C C1 B OBJ)
(setq E (entget ENT (list "FLOOR")))
(setq C1 (car (cadadr (setq C (assoc -3 E)))))
(setq B (cons (car C) (list (list (caadr C) (cons C1 xDATA)))))
(setq OBJ (subst B C E))
(entmod OBJ)
) |
|
[复制链接]
发表于 2012-10-20 14:47:25
置顶卡
变色卡
显身卡
