[转帖]一个局部放大程序

2443725 · 发表于 2004-4-25 23:49

;;;希望能起抛砖引玉的作用，能有人把放大(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) )

 這個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) )

swaywood · 发表于 2004-4-27 03:49

在明经上见到这个程序，还有一些小小问题，本来想等它完善之后，再转贴的，没想到老大的速度这么快，呵呵！

Michael_66 · 发表于 2004-6-14 19:38

使用编译过的程序，有些设置方面的问题，正在找源程序，真是及时雨，谢谢提供。