【有源码】根据图框自动调整框内标注全局比例大小
如题：在网上找了一个LSP，可设定矩形框，框内的标注全局比例，随矩形框大小而改变。但是该程序目前无效果，如何修改？源码在此：
(defun c:ds (/ entdata entgrp entname n ptlist scale)
(prompt "根据图框自动调整比例")
(if (setq entname (entsel "\n请选择图框"))
(if (= "INSERT" (getentdxf (car entname) 0))
(progn
(command "zoom" "o" (car entname) "")
(setq ptlist (ax:getboundingbox (car entname)))
(setq entgrp (ssget "W" (car ptlist) (cadr ptlist) '((0 . "DIMENSION,*TEXT,*LINE,HATCH"))))
(setq scale (vla-get-XScaleFactor (*en2obj* (car entname))))
(repeat (setq n (sslength entgrp))
(setq entname (ssname entgrp (setq n (1- n))))
(cond
((= "HATCH" (getentdxf entname 0))
(vla-put-PatternScale (*en2obj* entname) scale)
)
((= "DIMENSION" (getentdxf entname 0))
(vla-put-ScaleFactor (*en2obj* entname) scale)
)
((wcmatch (getentdxf entname 0) "*TEXT")
(vla-put-Height (*en2obj* entname) (* (getvar "textsize") scale))
)
((wcmatch (getentdxf entname 0) "*LINE")
(vla-put-LinetypeScale (*en2obj* entname) scale)
)
)
)
)
)
)
(princ)
) 本帖最后由 qianyi0710 于 2019-9-16 22:07 编辑
出错
图框为块， 或属性块
命令:DS 根据图框自动调整比例
请选择图框; 错误: no function definition: GETENTDXF 你确定你的图框是块吗？这个是改标注的全局比例
发源码请 指名作者或出处！此源码的作者就是本论坛的一名会员！有问题可直接问作者！ lucas_3333 发表于 2014-11-19 20:47 static/image/common/back.gif
你确定你的图框是块吗？这个是改标注的全局比例
发源码请 指名作者或出处！此源码的作者就是本论坛的一名 ...
感谢顶帖！此贴并未称‘原创’，请看第一句：‘网上找的’。 http://bbs.mjtd.com/thread-100053-30-1.html
发源码请 指名作者或出处！
这是对作者最基本的尊重。 试下我这个了，看是不是合你的习惯
;;;;;;;;;;;;;;;;;***********************
;;;;;;;;;;;;;;;;;;***********************
;;amtonny 2011/5/15
;;自动调整打印文字高度
(defun c:ZZ(/ di ds en po1 po2 obj endxf fx a1 a2 ys)
(vl-load-com)
(prompt "\n自动调整打印文字高度.......")
(setq os(getvar 'osmode) cmd(getvar 'cmdecho))
(setq oer *error* *error* my)
;;;;;;;;;;;;;;;
(setvar "cmdecho" 0)
(SETQ VIEWCTR (GETVAR "VIEWCTR"))
(SETQ VIEWSIZE (GETVAR "VIEWSIZE"))
(SETQ CORNER1 (LIST (+ (/ VIEWSIZE 1.2) (CAR VIEWCTR) )(+ (/ VIEWSIZE 2) (CADR VIEWCTR)) ))
(SETQ CORNER2 (LIST (- (CAR VIEWCTR) (/ VIEWSIZE 1.2)) (- (CADR VIEWCTR) (/ VIEWSIZE 2) )))
;;;;;;;;;;;;;;;
(setq SS (ssget "C" CORNER1 CORNER2 '((0 . "LWPOLYLINE"))))
(IF (= ss nil)
(progn (ALERT "错误提示\n當前窗口沒有你要打印的圖框, 請把需打印的圖框边画上多段线......\n本訊息由系統自動提示.") (exit)
))
(setvar "nomutt" 0)
(setq sslen(sslength ss) i 0)
(vl-cmdf "UNDO" "G")
(repeat sslen
(setq en(ssname ss i))
(setq obj (vlax-ename->vla-object EN))
(setq endxf(dxf 0 en))
(cond ((or (= endxf "CIRCLE") (= endxf "ELLIPSE") (= endxf "LINE") (= endxf "ARC") (= endxf "SPLINE"))
;((/ endxf "LWPOLYLINE")
)
((= endxf "LWPOLYLINE")
(setq plist '())
(mapcar '(lambda (x) (if (= (car x) 10) (setq plist(cons (cdr x) plist))))(entget en))
(setq DSAS(nth 0 plist) p2(nth 1 plist) DSASS(nth 2 plist) p4(nth 3 plist))
(setq a1(+ (angle p2 DSAS) 3) a2(+ (angle p2 DSASS) 3))
(setq po1(polarp2 a1 3) po2(polar p2 a2 3))
(grdraw DSAS DSASS 1 5)
(grdraw p2 p4 1 5)
(grdraw DSAS p2 1 5)
(grdraw p2 DSASS 1 5)
(grdraw DSASS p4 1 5)
(grdraw DSAS p4 1 5)
;;;;;;;;;;;;;;;;;;;;;;
(SSTT)
))
(setq i(1+ i))
)
(prompt "\n调整打印文字高度已完成.......")
(vl-cmdf "UNDO" "E")
(setvar 'osmode os)
(setvar 'cmdecho cmd)
(princ)
)
(defun EAA(x) ;求面积
(setq ena(vlax-curve-getArea x))
)
;;;
(defun dxf(n en)
(cdr(assoc n (entget en)))
)
;;;
(defun my(s)
(if (/= s "Function canccelled")
(princ"取消"))
(setvar 'osmode os)(setvar 'cmdecho cmd)(setvar "nomutt" 0)
(setq *error* oer)
)
(defun SSTT(/ ssdim)
(setvar "cmdecho" 0)
(setq dimsc(getvar "dimscale"))
(setvar "osmode" 33)
(setvar "DIMZIN" 8)
;(setq DSAS (getpoint "\n --->>>请框选图框对角点:"))
;(setq DSASS (getcorner DSAS))
(setvar "osmode" 0)
(setq DALA (distance DSAS DSASS))
(setq ZASD (rtos (/ DALA 300) 2 2))
(setq ssdim (ssget "C" DSAS DSASS'((0 . "DIMENSION"))))
(if (not ssdim) (exit))
(ZATEXT)
(command "_dimoverride" "dimscale" zasd "" ssdim "")
(command "_dimoverride" "dimtxt" 3 "" ssdim "")
(setvar "dimscale" dimsc)
;;(prompt (STRCAT "\n已将本页标注全局比例调整为: "zasd """文字高度调整为: " (rtos hig 2 2)))
(setvar "DIMZIN" 2)
(setvar "osmode" 183)
(princ)
)
(DEFUN ZATEXT()
(setq ZAMTEXT (ssget "C" DSAS DSASS'((-4 . "<or") (0 . "mtext") (0 . "text") (-4 . "or>"))))
(setq hig (* 2.5 (atof ZASD)))
(setq h40 (cons 40 hig))
(setq n (sslength ZAMTEXT))
(setq k 0 )
(while (< k n)
(setq name (ssname ZAMTEXT k))
(setq a (entget name))
(setq b (assoc '0 a))
(setq b (cdr b))
(setq h (assoc '40 a))
(setq a (subst h40 h a))
(entmod a)
(setq k (+ k 1))
)
)
要求图框为多段线，其它图形不可以多段线，且框内需有文字，标注 AMTONNY 发表于 2014-11-28 21:49 static/image/common/back.gif
要求图框为多段线，其它图形不可以多段线，且框内需有文字，标注
谢谢！
不要是改变打印字高。而是已标注的图形，在图形画一个矩形，能根据矩形范围大小，调整矩形内标注的全局比例。
这个我也需要，但找不到，一般我是输入一个命令改变标注样，如图框放大1.5倍，标注样式整体放大1.5倍，如图框缩小0.5倍，标注样式也跟着缩小0.5倍（这包括文本，箭头等）
页:
[1]
2