【有源码】根据图框自动调整框内标注全局比例大小

lengxiaxi

如题：在网上找了一个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

出错
图框  为块， 或属性块
命令:  DS 根据图框自动调整比例
请选择图框; 错误: no function definition: GETENTDXF   

lucas_3333

你确定你的图框是块吗？这个是改标注的全局比例
发源码请 指名作者或出处！此源码的作者就是本论坛的一名会员！有问题可直接问作者！

lengxiaxi

lucas_3333 发表于 2014-11-19 20:47
你确定你的图框是块吗？这个是改标注的全局比例
发源码请 指名作者或出处！此源码的作者就是本论坛的一名 ...

感谢顶帖！此贴并未称‘原创’，请看第一句：‘网上找的’。

xjakshw

http://bbs.mjtd.com/thread-100053-30-1.html

429014673

发源码请 指名作者或出处！
这是对作者最基本的尊重。

用户3766035971

AMTONNY

试下我这个了，看是不是合你的习惯
;;;;;;;;;;;;;;;;;***********************
;;;;;;;;;;;;;;;;;;***********************
;;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(polar  p2 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

要求图框为多段线，其它图形不可以多段线，且框内需有文字，标注

lengxiaxi

AMTONNY 发表于 2014-11-28 21:49
要求图框为多段线，其它图形不可以多段线，且框内需有文字，标注

谢谢！
不要是改变打印字高。而是已标注的图形，在图形画一个矩形，能根据矩形范围大小，调整矩形内标注的全局比例。

simpleye

这个我也需要，但找不到，一般我是输入一个命令改变标注样，如图框放大1.5倍，标注样式整体放大1.5倍，如图框缩小0.5倍，标注样式也跟着缩小0.5倍（这包括文本，箭头等）