[原创]一个局部放大程序

cag

;;;希望能起抛砖引玉的作用，能有人把放大(fd)的那一块给写下去。 (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)
) (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指定放大图位置:")
(if (not (command pause))
(MakeUnNameBlock ss1 cen)
)
)

(setvar "cmdecho" 0)
(initget 1)
(setq p1 (getpoint "\n指定放大中心点:"))
(command "circle" p1)
(princ
(strcat "\n指定放大半径 <" (rtos (getvar "CIRCLERAD")) ">:")
)
(command pause)
(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)
(princ)
)

BDYCAD

這個OK 還有些地方有待改進. 將就用用先. (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)
)

2443725

很感谢，但不知道如何用！！

spring

蛮好的，不过局部放大我很少用