【局部放大】源码公布
应大家强烈要求，在此公布全部【局部放大】程序的全部源码！因每个人所处行业不一样，对放大图的要求也不太一样！所以大家可以根据自己实际工作需要，改编合适自己的程序！
根据互联网的共享精神，希望各位可以把改编的成果发上来和大家共享！
主程序源码:
(defun c:ZoomMap (/ KD DELFLAG CPR GR D
P1 ENT FLAG SCALEPL SS ENDENT
UNBLKNEWENT OLDPT ENLINEPTS *error* os cmdecho)
(defun *error* (s)
(command "_ucs" "_p")
(setvar 'cmdecho cmdecho)
(gxl-RESTORESLAYERS)
(if os (setvar 'osmode os))
(if unblk (vla-delete unblk))
(if NewEnt (vla-delete NewEnt))
(if enline (entdel enline))
(if delflag (entdel ent))
(princ s)
(princ)
)
(setq cmdecho (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_ucs" "_w")
(gxl-storeslayers)
(gxl-Layer-UnLockAll)
(setvar "clayer" "0")
(initget 7 "Select Rect Draw Circle")
(setq kd (getkword "\n**选择放大范围方式[选择多边形Select/四边形R/绘制多边形Draw/圆形放大Circle]<Circle>:"))
(if (= "" kd) (setq kd "Circle"))
(while (not ent)
(cond((= kd "Circle")
(setq delflag t)
(while (not (setq cp (getpoint "\n 选择放大区域中心点："))))
(setq R 0 flag nil)
(while(not flag)
(setq gr (grread t 2))
(setq d (* 0.0015 (getvar "viewsize")))
(gxl-Ge-GRDrawCross cp 5 0 1 nil)
(cond ((= 5 (car gr))
(setq p1 (cadr gr))
(if (> (abs (- (distance cp p1) R)) d)
(progn
(setq R (distance cp p1))
(if ent
(gxl-ch_ent ent 40 r)
(progn
(gxl-AX:ADDCIRCLE *MODEL-SPACE* cp r)
(setq ent (entlast))
)
)
;(gxl-CH_ENT ent 62 1)
)
)
)
((= 3 (car gr))
(setq flag t)
(setq p1 (cadr gr))
(setq R (distance cp p1))
(if ent
(gxl-ch_ent ent 40 r)
(progn
(gxl-AX:ADDCIRCLE *MODEL-SPACE* cp r)
(setq ent (entlast))
)
)
)
)
)
)
((= kd "Rect")
(setq delflag t)
(if (setq ent (gxl-COMMAND "_.rectang"))
(progn
(setq ent (entlast))
(gxl-ch_ent ent 70 1)
(setq cp (apply 'gxl-MIDPOINT (gxl-GETBOX ent)))
(setq d (* 0.0015 (getvar "viewsize")))
(gxl-Ge-GRDrawCross cp 5 0 1 nil)
)
)
)
((= kd "Draw")
(setq delflag t)
(if (setq ent (gxl-COMMAND "_.Pline"))
(progn
(setq ent (entlast))
(gxl-ch_ent ent 70 1)
(setq cp (apply 'gxl-MIDPOINT (gxl-GETBOX ent)))
(setq d (* 0.0015 (getvar "viewsize")))
(gxl-Ge-GRDrawCross cp 5 0 1 nil)
)
)
)
((= kd "Select")
(while (not (setq ent (car (gxl-SEL-ENTSEL "\n选择封闭多段线:" '((0 . "*LWPOLYLINE,circle")))))))
(setq cp (apply 'gxl-MIDPOINT (gxl-GETBOX ent)))
(setq d (* 0.0015 (getvar "viewsize")))
(gxl-Ge-GRDrawCross cp 5 0 1 nil)
)
)
(if (not ent)
(cond
((= kd "Select")
(princ "\n***没有选择放大边界，请重新选择边界***")
)
(t
(princ "\n***没有绘制放大边界，请重新绘制边界***")
)
)
)
)
(setq os (getvar 'osmode))
(setvar 'osmode 0)
(setq p1 (vlax-3d-point cp))
(setq scale (getreal "\n 放大倍数<2.0>："))
(if (null scale) (setq scale 2.0))
(redraw ent 2)
(setq pl (gxl-get_poly_ptList3 ent 0.017))
(setq ss (ssget "cp" pl))
(if ss
(progn
(setq endent (entlast))
(command "_copy" ss "" "0,0" "0,0")
(setq ss (gxl-SEL-ENTNEXTALL endent))
(setq unblk (gxl-BLK-UnMBlockBase ss cp))
(command "_xclip" (entlast) "" "n" "p")
(foreach a pl (command a))
(command "")
(redraw ent 1)
(setq NewEnt (vla-copy (vlax-ename->vla-object ent)))
(vla-ScaleEntity NewEnt (setq oldpt (vlax-3d-point cp)) scale)
(princ "\n 摆放位置：")
(setq flag t)
(while flag
(setq gr (grread t 2))
(gxl-Ge-GRDrawCross cp 5 0 1 nil)
(if (= 5 (car gr))
(progn
(vla-move NewEnt p1 (setq p1 (vlax-3d-point (cadr gr))))
(if enline
(gxl-CH_ENT enline 11 (apply 'gxl-MIDPOINT (gxl-GETBOX NewEnt)))
(progn
(gxl-AX:ADDLINE *MODEL-SPACE* cp (cadr gr))
(setq enline (entlast))
)
)
)
(setq flag nil)
)
)
(vla-move unblk (vlax-3d-point cp) p1)
(vla-ScaleEntity unblk p1 scale)
(gxl-setOverride (vlax-vla-object->ename unblk) scale)
(setq pts (gxl-inters enline NewEnt acExtendNone))
(gxl-CH_ENT enline 11 (car pts))
(setq pts (gxl-inters enline Ent acExtendNone))
(gxl-CH_ENT enline 10 (car pts))
(gxl-ch_ent ent 62 3)
(gxl-ch_ent enline 62 3)
(vla-put-color NewEnt 3)
)
(alert "所选范围没有任何实体！")
)
(command "_ucs" "_p")
(setvar 'osmode os)
(setvar 'cmdecho cmdecho)
(gxl-RESTORESLAYERS)
(princ)
)
全部源码下载:
G版的东西就是好用啊 谢谢G版老老师！ 太好了 G版厉害，就是3个币老贵了！！！ 请问放大后，怎么对图进行编辑修改呢，貌似生成的放大图是多重块 本帖最后由 自贡黄明儒 于 2013-7-26 15:31 编辑
终于盼来了G版的源码，是各位给图员的福气
响应G版号召，贴出我改编的源码
;;*************************************************************************放大主程序
;;全局JBFD_GetScalStri放大倍数（字符），JBFD_BaseNumber标识（数字）,JBFD_ZoomStri视口
(defun C:FD (/ BASESYMBOL BLI1 CLA1 CMD1 CP
DCLID DIM1 ENT ENTCICL ENTTEXTFN FNAME
GETZOOMLAY LIN NEWBLOCK NEWP NEWSS OSM1
P1 P2 PL RETURN# SCALREAL SS TEXTHEIGH
X
)
;;1 错误处理
(defun *error* (s)
(while (not (equal (getvar "cmdnames") "")) (command nil))
(if entText
(command "_.erase" entText "")
)
(if lay
(setvar "clayer" lay)
)
(setvar "blipmode" bli1)
(setvar "cmdecho" cmd1)
(setvar "DIMASSOC" DIM1)
(setvar "osmode" osm1)
(princ s)
(princ "出错啦!")
(princ)
)
;;2 对象是否在锁定层上
(defun onlocked (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)
;;3构成新的选择集,EntCicl不加入
(defun ss=>NewSS (SS EntCicl / E N NEWSS)
(setq NewSS (ssadd))
(repeat (setq n (sslength ss))
(setq e (ssname ss (setq n (1- n))))
(if (or (equal e EntCicl) (onlocked e))
nil
(progn
(command "_.copy" e "" (list 0 0 0) (list 0 0 0))
(setq NewSS (ssadd (entlast) NewSS))
)
)
)
NewSS
)
;;4 0层上生成块
(defun NONAME_BLK (SS PCircl / A lay)
(setq lay (getvar "clayer"))
(setvar "clayer" "0")
(setq A (rtos (* (getvar "CDATE") 1E8)))
(if (and SS PCircl)
(progn
(command "_.BLOCK" A PCircl SS "")
(command "_.INSERT" A "@" "" "" "")
)
)
(setvar "clayer" lay)
(entlast)
)
;;5 画引线
(defun HdrawLeader (EntCicl BaseSymbol Textheigh CP /
A AA B BB C CC D
DD EE ENTTEXT FF I TEXTLIS
)
(command "_.text" CP Textheigh "" BaseSymbol)
(setq entText (entlast))
(setq TextLis (entget entText))
(setq i T)
(while i
(setq a (grread T 4 0)
b (car a)
c (cadr a)
)
;;b=5移动，b=3左键,c=0右键,;;c=13回车,c=32空格
(cond ((= b 5)
(redraw)
(setq a (trans (cadr a) 1 0))
(setq d (vlax-curve-getclosestpointto EntCicl a))
(setq aa (car a)
bb (cadr a)
cc (caddr a)
)
(setq dd (car d)
ee (cadr d)
ff (caddr d)
)
(if (<= aa dd)
(progn (setq TextLis (subst (cons 72 2) (assoc 72 TextLis) TextLis))
(setq TextLis (subst (cons 11 a) (assoc 11 TextLis) TextLis))
)
(progn (setq TextLis (subst (cons 72 0) (assoc 72 TextLis) TextLis))
(setq TextLis (subst (cons 10 a) (assoc 10 TextLis) TextLis))
)
)
(entmod TextLis)
(grdraw a d 1)
)
((= b 3) (setq i nil))
)
)
(redraw)
(entdel entText)
(if (VL-CATCH-ALL-ERROR-P
(VL-CATCH-ALL-APPLY 'setvar (list "DIMLDRBLK" "DotSmall"))
)
(VL-CATCH-ALL-APPLY 'setvar (list "DIMLDRBLK" "小点"))
)
(vl-cmdf "_.layer" "make" "DIM" "Color" 3 "" "")
(command "_.leader" d (cadr a) "" BaseSymbol "")
)
;;6 返回多义线顶点点列表,有圆弧则用一定角度分割圆弧，闭合多义线点表不含闭合点坐标
;;(setq pl (gxl-pL ent 0.017))
(defun gxl-pL (en fgx / BJ BUGLED D0 D1 D2
ENT K N OBJ OBJNAME PARAMPLIST PT
SECDEV VERTEXSNUM
)
;;gxl-get_poly_ptList 返回多义线顶点点列表不含圆弧段内容，闭合多义线点表不含闭合点坐标
;;(gxl-get_poly_ptList (car (entsel)))
(defun gxl-get_poly_ptList (e / _pl n k)
(if (= 'ename (type e))
(setq e (vlax-ename->vla-object e))
)
(cond ((= "AcDbCircle" (vla-get-ObjectName e))
(list (vlax-curve-getPointAtParam e 0)
(vlax-curve-getPointAtParam e (* pi 0.5))
(vlax-curve-getPointAtParam e pi)
(vlax-curve-getPointAtParam e (* 1.5 pi))
)
)
((= "AcDbArc" (vla-get-ObjectName e))
(list (vlax-curve-getStartPoint e)
(vlax-curve-getendPoint e)
)
)
(t
(setq n (1+ (fix (vlax-curve-getEndParam e)))
k -1
)
(if (vlax-curve-isClosed e)
(setq n (1- n))
)
(repeat n
(setq k (1+ k))
(if (vlax-curve-getSecondDeriv e k)
(setq
_pl (append _pl (list (vlax-curve-getPointAtParam e k)))
)
)
)
)
)
_pl
)
(if (= 'ENAME (type en))
(setq obj (vlax-ename->vla-object en)
ent en
)
(setq obj en
ent (vlax-vla-object->ename en)
)
)
(setq vertexsNum
(fix (vlax-curve-getEndParam ent))
n 0
)
(setq objName (vla-get-ObjectName obj))
(cond ((= "AcDbCircle" objName)
(if (equal fgx 0 1e-6)
(setq fgx (* pi 0.5))
)
(setq vertexsNum
(fix (/ (* pi 2) fgx))
n 0
)
(repeat vertexsNum
(setq pt (vlax-curve-getPointAtParam obj (* n fgx)))
(setq plist (cons pt plist)
n (1+ n)
)
)
(reverse plist)
)
(t
(if (= "AcDb2dPolyline" objName)
(progn
(repeat vertexsNum
(setq pt (vlax-curve-getPointAtParam ent n))
(setq plist (cons pt plist))
(setq pt (vlax-curve-getPointAtParam ent (+ 0.25 n)))
(setq plist (cons pt plist))
(setq pt (vlax-curve-getPointAtParam ent (+ 0.5 n)))
(setq plist (cons pt plist))
(setq pt (vlax-curve-getPointAtParam ent (+ 0.75 n)))
(setq plist (cons pt plist))
(setq n (1+ n))
)
(if (not (vlax-curve-isClosed ent))
(setq plist (cons (vlax-curve-getEndPoint ent) plist))
)
(reverse plist)
)
(if (equal fgx 0 1e-6)
(setq plist (GXL-GET_POLY_PTLIST en))
(progn
(repeat vertexsNum
(if (setq secdev (vlax-curve-getSecondDeriv ent n))
(progn
(setq pt (vlax-curve-getPointAtParam ent n)
bugle (vla-GetBulge obj n)
)
(setq plist (cons pt plist))
(if (/= bugle 0.0)
(progn
(setq bj (* (atan (abs bugle)) 4))
(setq d1 (vlax-curve-getdistAtParam ent n)
d2 (vlax-curve-getdistAtParam ent (1+ n))
d (- d2 d1)
k (fix (/ bj fgx))
d0 (/ 1.0 (1+ k))
param n
)
(if (equal d0 1.0 0.001)
(setq plist (cons (vlax-curve-getPointAtParam
ent
(+ 0.5 param)
)
plist
)
)
(repeat k
(setq
plist (cons (vlax-curve-getPointAtParam
ent
(setq param (+ param d0))
)
plist
)
)
)
)
)
)
)
)
(setq n (1+ n))
)
(if (not (vlax-curve-isClosed ent))
(setq plist (cons (vlax-curve-getEndPoint ent) plist))
)
(reverse plist)
)
)
)
)
)
plist
)
;;7 对话框上用户选择
(defun getdata ()
(setq BaseSymbol (get_tile "Fuhao"))
(setq JBFD_GetScalStri (get_tile "Scal"))
(setq JBFD_ZoomStri (get_tile "Zoom1"))
)
;;8 对话框
(defun FDdcl ()
(setq fname (vl-filename-mktemp nil nil ".dcl"))
(setq fn (open fname "w"))
(write-line "Fddcl : dialog{" fn)
(write-line "label=\"*黄明儒*局部放大 命令:FD\";" fn)
(write-line ":column{ " fn)
(write-line
" :edit_box{label=\"放大标识(F)\";key=\"Fuhao\";value=\"B\";mnemonic=\"F\";}"
fn
)
(write-line
" :edit_box{label=\"放大倍数(S)\";key=\"Scal\";value=\"2.0\";mnemonic=\"S\";} "
fn
)
(write-line
" :edit_box{label=\"视口选择(Z)\";key=\"Zoom1\";value=\"0\";mnemonic=\"Z\";} "
fn
)
(write-line
" :text{key=\"Scaltext\";value=\"圆0,已知封闭曲线1,椭圆2,其余多边形\";}"
fn
)
(write-line " }" fn)
(write-line " ok_only;" fn)
(write-line "}" fn)
(close fn)
(setq fn (open fname "r"))
(setq dclid (load_dialog fname))
(while
(or (eq (substr (setq lin (vl-string-right-trim
"\" fn)"
(vl-string-left-trim "(write-line \"" (read-line fn))
)
)
1
2
)
"//"
)
(eq (substr lin 1 (vl-string-search " " lin)) "")
(not (eq (substr lin (+ (vl-string-search " " lin) 1) 9)
" : dialog"
)
)
)
)
(new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
(set_tile "Fuhao" BaseSymbol)
(set_tile "Scal" JBFD_GetScalStri)
(set_tile "Zoom1" JBFD_ZoomStri)
(mode_tile "Scal" 2)
(Action_Tile "Fuhao" "(Setq BaseSymbol $Value)")
(Action_Tile "Scal" "(Setq JBFD_GetScalStri $Value)")
(Action_Tile "Zoom1" "(Setq JBFD_ZoomStri $Value)")
(action_tile "accept" "(getdata)(done_dialog)")
(setq return# (start_dialog))
(unload_dialog dclid)
(close fn)
(vl-file-delete fname)
)
;;9 本程序主程序
(VL-LOAD-COM)
(setq bli1 (getvar "blipmode"))
(setq cmd1 (getvar "cmdecho"))
(setq DIM1 (getvar "DIMASSOC"))
(setq CLA1 (getvar "CLAYER"))
(setq osm1 (getvar "osmode"))
(setvar "blipmode" 0)
(setvar "cmdecho" 0)
(setvar "DIMASSOC" 1)
(setvar "osmode" 0)
(vl-cmdf "layer" "make" "DIM" "Color" 3 "" "")
(if (= JBFD_BaseNumber nil)
(setq JBFD_BaseNumber 65)
(setq JBFD_BaseNumber (1+ JBFD_BaseNumber))
)
(SETQ BaseSymbol (chr JBFD_BaseNumber))
(if (= JBFD_GetScalStri nil)
(setq JBFD_GetScalStri "2.5")
)
(if (= JBFD_ZoomStri nil)
(setq JBFD_ZoomStri "0")
)
(FDdcl)
(setq JBFD_BaseNumber (ascii BaseSymbol))
(SETQ Scalreal (atof JBFD_GetScalStri))
(SETQ getZoom (abs (atoi JBFD_ZoomStri)))
(if (/= 1 getZoom)
(SETQ CP (GETPOINT "\n 局部放大中心点: "))
)
(cond ((= 0 getZoom) (command "_.CIRCLE" CP pause))
((= 1 getZoom)
(while
(not
(and
(setq ent (car (entsel "\n 拾取封闭曲线:")))
(setq p1 (cdr (assoc 0 (entget ent))))
(member p1
'("SPLINE" "LWPOLYLINE" "POLYLINE" "CIRCLE" "ELLIPSE")
)
(if (member p1 '("SPLINE" "LWPOLYLINE" "POLYLINE"))
(= (vlax-get-property (vlax-ename->vla-object ent) 'Closed)
:vlax-true
)
T
)
)
)
)
)
((= 2 getZoom) (command "_.ellipse" CP pause pause))
(T (command "_.polygon" getZoom CP "_I" pause))
)
(SETQ EntCicl (entlast))
;;(ayEntSSHighLight EntCicl)
(if (= 1 getZoom)
(SETQ EntCicl ent)
)
(vla-getboundingbox
(vlax-ename->vla-object EntCicl)
'p1
'p2
)
(setq p1 (vlax-safearray->list p1))
(setq p2 (vlax-safearray->list p2))
(setq CP (mapcar '(lambda (X) (/ x 2.0)) (mapcar '+ p1 p2))) ;中心点
(setq pl (gxl-pL EntCicl 0.017)) ;取点
(setq ss (ssget "cp" pl)) ;选择对象
(setq newSS (ss=>NewSS SS EntCicl)) ;原地拷贝
(setq Newblock (NONAME_BLK newSS CP)) ;制作成块
;;遮盖
(command "_.xclip" Newblock "" "n" "p")
(foreach a pl (command a))
(command "")
(while (not (equal (getvar "cmdnames") "")) (command nil))
(command "_.copy" EntCicl "" (list 0 0 0) (list 0 0 0))
(setq EntCicl (entlast))
(SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE"))) ;字度Textheigh
(HdrawLeader EntCicl BaseSymbol Textheigh CP) ;画引线
(setq NewP (mapcar '+
(list 0 (+ (* Scalreal (- (cadr p2) (cadr CP))) Textheigh))
CP
)
)
(command "_.text"
"J"
"C"
NewP
Textheigh
""
(strcat BaseSymbol " 放大 " JBFD_GetScalStri "X")
)
(command "_.scale" Newblock EntCicl "" CP Scalreal)
(command "_.move" Newblock (entlast) EntCicl "" CP pause)
(setvar "blipmode" bli1)
(setvar "cmdecho" cmd1)
(setvar "DIMASSOC" DIM1)
(setvar "osmode" osm1)
(gc)
(princ)
)
;;*************************************************************************放大主程序
赞啊 而且对天正对像适用 flytoday 发表于 2013-7-26 13:45 static/image/common/back.gif
相应的标注。。。与字没有放大~~~~~~~~~~~~~~~~
注释掉如下代码即可放大文字和标注线型等：
(gxl-setOverride (vlax-vla-object->ename unblk) scale) 哇，好东西，谢谢分享，你的出品，必是精品 本帖最后由 Gu_xl 于 2013-7-26 13:15 编辑
vvcd 发表于 2013-7-26 12:55 static/image/common/back.gif
请问放大后，怎么对图进行编辑修改呢，貌似生成的放大图是多重块
放大图的内容是不可以编辑！
若要能编辑的，放大图不要用无名块制块，可使用时间作为块名来建立图块！然后使用在位编辑即可！！ 下载学习。 相应的标注。。。与字没有放大~~~~~~~~~~~~~~~~ G版大作，这个花的值。撒花。 支持下，本行业基本不用放大图 一个字
很好