flytoday 发表于 2013-7-26 13:45 static/image/common/back.gif
相应的标注。。。与字没有放大~~~~~~~~~~~~~~~~
注释掉如下代码即可放大文字和标注线型等：
(gxl-setOverride (vlax-vla-object->ename unblk) scale)
哈哈，终于出来了哈，哈哈
本帖最后由 自贡黄明儒 于 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)
)
;;*************************************************************************放大主程序
自贡黄明儒 发表于 2013-7-26 15:06 static/image/common/back.gif
终于盼来了G版的源码，是各位给图员的福气
响应G版号召，贴出我改编的源码
最好贴出效果图来或动画演示来！
谢谢二位大师分享实用源码。
两位高手来个优化版的~~~~~~~~~~~~~~~~~~~·
支持G版的好程序
麻烦请问默认放大倍数为1改哪几个地方啊，实在是不懂LSP啊
论坛上有个小笨的局部放大，有对话框，如果有对话框窗体会跟好，
对于标注箭头是块的话，放大后也跟着放大，最好放大后再还原回到原来那样，另外，放大后的块最好是有名块。