局部放大

lll7511 发表于 2006-1-23 15:48:00

那位高手能把小鱼儿的局部放大完善一下.

lll7511 发表于 2006-1-23 16:50:00

(vl-load-com) ;;;(alert "<A href="file://n/" target="_blank" >\\n</A>局部放大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 "唉,我无法清理<A href="file://%22d//" target="_blank" >\\"d\\</A>"??,"         "<A href="file://n/" target="_blank" >\\n</A>如果你知道!请通知我。"         "<A href="file://nE_mail:cag25@sohu.com/" target="_blank" >\\nE_mail:cag25@sohu.com</A>"         "<A href="file://nQQ:297240086/" target="_blank" >\\nQQ:297240086</A>"        )        )       )       (T        (alert (strcat msg         "<A href="file://n//n" target="_blank" >\\n\\n</A>对不起,有什么问题,请通知我。"         "<A href="file://nE_mail:cag25@sohu.com/" target="_blank" >\\nE_mail:cag25@sohu.com</A>"         "<A href="file://nQQ:297240086/" target="_blank" >\\nQQ:297240086</A>"        )        )       )     )   )
  (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 "<A href="file://n/" target="_blank" >\\n</A>指定放大中心点"))   (command "circle" p1)   (princ     (strcat "<A href="file://n/" target="_blank" >\\n</A>指定放大半径 <" (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 "<A href="file://n/" target="_blank" >\\n</A>指定字符号放置位置 <左键或回车修改字符号>:")   (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         "<A href="file://n/" target="_blank" >\\n</A>?入新字符号 <"         fh         ">:"       )   )        )        (if (= fh "")   (setq fh fh1)        )        (vla-put-textstring text fh)        (vla-update text)        (setq txtlen (tzz text))        (princ "<A href="file://n/" target="_blank" >\\n</A>指定字符号放置位置 <左键或回车修改字符字>:")       )     )   )   (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 "<A href="file://n/" target="_blank" >\\n</A>指定放大图位置:")   (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 "<A href="file://n/" target="_blank" >\\n</A>输入放大的倍数<2>:"))nil)     (setq scalebb 2)) (command ".scale" (ssget "cp" trimp)"" (getvar "lastpoint") scalebb)   (princ)   )

BDYCAD 发表于 2006-1-23 20:35:00

快过春节了, 看到什么高兴!

00放飞梦想00 发表于 2022-2-27 14:23:52

我来顶一下

页: [1]

明经CAD社区's Archiver

局部放大