|
(vl-load-com)
;;;(alert "\\n局部放大jbfd.2004.2.18")
(defun c:jbfd (/ *error* mSpace cir i NEXT_PT
READTYP READVAL basept line text tzz
txtlen l2 l2end cen pt text_x
ptt l2_x fh fh1 ss1
MakeUnNameBlock
)
(defun *error* (msg / ent count)
(cond
((or (= msg "函数被取消") (= msg "function cancelled"))
(command "_.ERASE" ss1 "")
)
((= msg "ActiveX 服务器返回到: 未知名?: Center") ;清理输入d
(alert (strcat "唉,我无法清理\\"d\\"??,"
"\\n如果你知道!请通知我。"
"\\nE_mail:cag25@sohu.com"
"\\nQQ:297240086"
)
)
)
(T
(alert (strcat msg
"\\n\\n对不起,有什么问题,请通知我。"
"\\nE_mail:cag25@sohu.com"
"\\nQQ:297240086"
)
)
)
)
)
(setq mSpace (vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
)
)
(setq ss1 (ssadd))
(defun MakeUnNameBlock (ss pt / count entlist ent blk)
(entmake (list '(0 . "BLOCK")
'(2 . "*U")
'(70 . 1)
(cons 10 pt)
)
)
(setq count 0)
(repeat (sslength ss)
(setq entlist (entget (setq ent (ssname ss count))))
(setq count (1+ count))
(entmake entlist)
)
(setq count 0)
(repeat (sslength ss)
(setq ent (ssname ss count))
(setq count (1+ count))
(entdel ent)
)
(setq blk (entmake '((0 . "ENDBLK"))))
(if T
(entmake (list (cons 0 "INSERT")
(cons 2 blk)
(cons 10 pt)
)
)
)
)
(defun Tzz (Text / textent ang sinrot cosrot t1 t2 p0 p1 p2 p3 p4)
(setq textent (entget (vlax-vla-object->ename Text)))
(setq p0 (cdr (assoc 10 textent))
ang (cdr (assoc 50 textent))
sinrot (sin ang)
cosrot (cos ang)
t1 (car (textbox textent))
t2 (cadr (textbox textent))
p1 (list
(+ (car p0)
(- (* (car t1) cosrot) (* (cadr t1) sinrot))
)
(+ (cadr p0)
(+ (* (car t1) sinrot) (* (cadr t1) cosrot))
)
)
p2 (list
(+ (car p0)
(- (* (car t2) cosrot) (* (cadr t1) sinrot))
)
(+ (cadr p0)
(+ (* (car t2) sinrot) (* (cadr t1) cosrot))
)
)
)
(distance p1 p2)
)
(setvar "cmdecho" 0)
(initget 1)
(setq p1 (getpoint "\\n指定放大中心点"))
(command "circle" p1)
(princ
(strcat "\\n指定放大半径 <" (rtos (getvar "CIRCLERAD")) ">:")
)
(command pause)
(setq newcircle (entlast))
(setq cir (vlax-ename->vla-object (entlast)))
(vla-put-color cir (getvar "dimclrd"))
(vla-update cir)
(ssadd (entlast) ss1)
(setq cen (vlax-safearray->list
(vlax-variant-value (vla-get-center cir))
)
)
(setq pt (car cen))
(princ "\\n指定字符号放置位置 <左键或回车修改字符号>:")
(setq i T)
(while i
(Setq NEXT_PT (GrRead T 4 0)
READTYP (car NEXT_PT)
READVAL (cadr NEXT_PT)
)
(cond
((= READTYP 5) ;移动
(setq NEXT_PT (cadr NEXT_PT))
(setq next_pt (trans next_pt 1 0))
(setq basept (vlax-curve-getclosestpointto cir NEXT_PT))
(if (not line)
(progn
(if (not fh)
(setq fh "A")
)
(setq text (vla-addtext
mspace
fh
(vlax-3d-point next_pt)
(getvar "dimtxt")
)
)
(vla-put-color text (getvar "dimclrt"))
(vla-put-stylename text (getvar "dimtxsty"))
(vla-update text)
(ssadd (entlast) ss1)
(setq line (vla-addline
mspace
(vlax-3d-point basept)
(vlax-3d-point next_pt)
)
)
(vla-put-color line (getvar "dimclrd"))
(ssadd (entlast) ss1)
(setq txtlen (tzz text))
(setq l2end (list (+ (car next_pt) txtlen) (cadr next_pt) 0))
(setq l2 (vla-addline
mspace
(vlax-3d-point next_pt)
(vlax-3d-point l2end)
)
)
(vla-put-color l2 (getvar "dimclrd"))
(ssadd (entlast) ss1)
)
(progn
(vla-put-startpoint line (vlax-3d-point basept))
(vla-put-endpoint line (vlax-3d-point next_pt))
(vla-update line)
(setq ptt (car next_pt))
(if (> ptt pt)
(progn
(setq text_x (+ (car next_pt) (getvar "dimgap")))
(setq l2_x (+ (car next_pt) txtlen (getvar "dimgap")))
)
(progn
(setq text_x (- (car next_pt) (getvar "dimgap") txtlen))
(setq l2_x text_x)
)
)
(vla-put-insertionpoint
text
(vlax-3d-point
(list text_x (+ (cadr next_pt) (getvar "dimgap")) 0)
)
)
(vla-update text)
(vla-put-startpoint l2 (vlax-3d-point next_pt))
(setq l2end (list l2_x (cadr next_pt) 0))
(vla-put-endpoint l2 (vlax-3d-point l2end))
(vla-update l2)
)
)
)
((= READTYP 3) ;左键
;;; (MakeUnNameBlock ss1 cen)
(setq i nil)
)
((or (= 25 readtyp) (= 13 READVAL)) ;回车或右键
(setq fh1 fh)
(setq fh (getstring (strcat
"\\n?入新字符号 <"
fh
">:"
)
)
)
(if (= fh "")
(setq fh fh1)
)
(vla-put-textstring text fh)
(vla-update text)
(setq txtlen (tzz text))
(princ "\\n指定字符号放置位置 <左键或回车修改字符字>:")
)
)
)
(fd)
(bdycad)
(princ)
)
(defun fd (/ minpt maxpt ss2)
(vla-getboundingbox cir 'minpt 'maxpt)
(setq minpt (vlax-safearray->list minpt)
maxpt (vlax-safearray->list maxpt)
)
(setq ss2 (ssget "C" maxpt minpt))
(command "copy" ss2 "" cen)
(princ "\\n指定放大图位置:")
(command pause)
;;; (if (not (command pause))
;;;;;; (MakeUnNameBlock ss1 cen)
;;; )
)
(defun bdycad()
(defun GetPoints2004-04-22 (lst1 / pt lst1 )
(while (setq lst1 (member (assoc 10 lst1) lst1))
(setq pt (append pt (list (cdr (car lst1)))))
(setq lst1 (cdr lst1)))
pt
)
(setq ssb (ssget "x" (list (cons 10(getvar "lastpoint")) (assoc 40 (entget newcircle)))))
(command ".POLYGON" 40 (getvar "lastpoint") "c" (+(cdr (assoc 40 (entget newcircle)))0.1))
(setq polsel (entlast))
(setq trimp (GetPoints2004-04-22 (entget polsel)))
(progn ; 强行修剪
(command ".trim" ssb "" );"f" trimp)
(setq it 0)
(repeat (- (length trimp) 1)
(setq trp1 (nth it trimp)
trp2 (nth (1+ it) trimp))
(command "f" trp1 trp2 "")
(setq it (1+ it)))
(command ""))
(progn ; 强行删除
(setq it 0)
(repeat (- (length trimp) 1)
(setq trp1 (nth it trimp)
trp2 (nth (1+ it) trimp))
(if (setq erase (ssget "f" (list trp1 trp2 )))
(command ".erase" erase ""))
(setq it (1+ it)))
)
(if (=(setq scalebb (getreal "\\n输入放大的倍数<2>:"))nil)
(setq scalebb 2))
(command ".scale" (ssget "cp" trimp)"" (getvar "lastpoint") scalebb)
(princ)
)
| 
发表于 2006-1-23 15:48:00
置顶卡
变色卡
显身卡
楼主
发表于 2006-1-23 20:35:00