动态比例程序目前只能单选,求改成多选.......（原作者莫怪）

XO-20170910

原贴地址  :  [源码] 不知道标注全局比例？就动态修改。附: 标注断开及连续标注，标注合并

******************************************************************************
;;========================================
;;  动态比例
;; by  明经通道  QQ: 9034598 2013年6月30日
;;========================================
(defun c:dc( / xent obj pt sc1 pt pt2 pt3 sc2 LLe LLt h txt sname dxf)
(setvar "cmdecho" 0)

;;(setq xent (ssget '((0 . "DIMENSION"))))
(setq xent (entsel "\n请选择标注对象:"))


(if (and xent (= (cdr (assoc 0 (entget (car xent)))) "DIMENSION"))(progn
(setq obj (vlax-ename->vla-object (car xent))pt (cadr xent))

(setq sc1 (vla-get-ScaleFactor obj)
      sname (vla-get-StyleName obj))
(creL pt pt)
(setq LLe (entget (entlast)))
(creT)
(setq LLt (entget (entlast)))
(while (or (= (car (setq mouse (grread t 5 0))) 5)(= (car mouse) 2))
   (setq pt2 (cadr mouse)
           h (* 0.02 (getvar "VIEWSIZE"))
         sc2 (* sc1 (/ (distance pt pt2) h) 0.1)
         txt (strcat "变化比例==" (rtos sc2 2))
         pt3 (polar pt2 (* -0.45 pi) (* 1.5 h)))
  (foreach x (list (cons 1 txt)(cons 10 pt3)(cons 40 h))
           (setq LLt (subst x (assoc (car x) LLt) LLt)))
  (entmod LLt)
  (entmod (subst (cons 11 pt2)(assoc 11 LLe) LLe))
  (if (null (equal sc2 0 1e-6)) (vla-put-ScaleFactor obj sc2))
)
(setq dxf (entget (tblobjname "dimstyle" sname)))
(entmod (subst (cons 40 sc2)(assoc 40 dxf) dxf))
(command "-DIMSTYLE" "R" sname)
(entdel (cdr (assoc -1 LLE)))
(entdel (cdr (assoc -1 LLT)))
))
(setvar "cmdecho" 1)
(princ)
)

(defun creT()(entmake (list '(0 . "TEXT") (cons 1 "1") (list 10 0 0 0) (cons 40 1))))
(defun creL(p1 p2)(entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2))))

(princ)

******************************************************************************

w245272914

支持。希望高人过来搞搞

669423907

http://bbs.mjtd.com/thread-169462-1-1.html

XO-20170910

669423907 发表于 2018-1-4 16:18
http://bbs.mjtd.com/thread-169462-1-1.html

这个貌似没有显示比例的......

XO-20170910

669423907 发表于 2018-1-4 16:18
http://bbs.mjtd.com/thread-169462-1-1.html

这个可以改加屏幕上显示比例吗？



;;;***************************dimsc***************************************;;;
;;;Dimension overall scale                                                ;;;
;;;by waterchen at 2015-09-01                                             ;;;
;;;rev 1.0                                                                ;;;
;;;***********************************************************************;;;
;;;-----------------------------------------------------------------------;;;
(defun c:ddc ( / olderr oldlu sc ss str gr p1 pos)

  (defun *error* (err)
    (princ (strcat "\nError: " err))
    (if (= 8 (logand 8 (getvar 'UNDOCTL)))
      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
      )
    (redraw)
    (setvar "NOMUTT" 0)
    (setvar "LUPREC" oldlu)
    (setq *error* olderr)
    (princ)
    )

  ;;;dim_overall_scale change to dimension overall scale value
  ;;;sc:scale value
  (defun dim_overall_scale (sc)
  (if (not (equal s 0 1e-6))
    (mapcar '(lambda (dim) (vlax-put (car dim) 'ScaleFactor sc)) ss)
    )
  )


  ;;;**************************main program**************************;;;
  (setq
    olderr *error*
    oldlu  (getvar "LUPREC")
    )
  (setvar "LUPREC" 2)
  (princ "\nPlease select Dimension:")
  (setvar "NOMUTT" 1)
  (setq ss (ssget "" '((0 . "DIMENSION"))))
  (setvar "NOMUTT" 0)
  (if ss
    (progn
      (setq
        ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
        ss (mapcar
             '(lambda (dim)
                (cons (vlax-ename->vla-object dim) (list (cdr (assoc 11 (entget dim )))))
                )
             ss
             )
        str ""
        )
      (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
      (while
        (progn
          (setq gr (grread 't 15 0) code (car gr) gr (cadr gr))
          (redraw)
          (cond
            ((and (= 5 code) (listp gr))
             (setq
               ss (vl-sort ss
                           (function
                             (lambda (e1 e2)
                               (< (distance (trans gr 1 0) (cadr e1))
                                  (distance (trans gr 1 0) (cadr e2)))))))
             (setq
               p1  (cadar ss)
               sc  (rtos (* 1.0 (/ (distance (trans gr 1 0) p1) (* 0.02 (getvar "VIEWSIZE"))) 0.3) 2 2)
               )
             (princ (strcat "\rDim overall scale <" sc ">:"))
             (grdraw gr (trans p1 0 1) 3 1)
             (dim_overall_scale (atof sc))
             
             )

            ((= 3 code) nil)

            ((= 2 code)
             (cond
               ((or (= 46 gr) (< 47 gr 58))
                (if (vl-string-position 32 str)
                  (setq
                    str (vl-string-right-trim (chr 32) str)
                    Str (strcat Str (chr gr))
                    )
                  (setq Str (strcat Str (chr gr)))
                  )
                (princ Str)
                )

               ((= gr 8)
                (if (< 0 (strlen Str))
                  (if (vl-every '(lambda (x) (= x 32)) (vl-string->list str))
                    (setq str "")
                    (if (setq pos (vl-string-position 32 str))
                      (setq Str   (vl-string-subst (chr 32) (substr Str pos 1) Str (1- pos)))
                      (setq Str   (strcat (substr Str 1 (1- (strlen Str))) (chr 32)))
                      )
                    )
                  )
                (princ Str)
                )

               ((vl-position gr '(13 32))
                (if (and
                      (not (zerop (strlen (setq str (vl-string-right-trim (chr 32) str)))))
                      (setq str (atof str))
                      )
                  (car (dim_overall_scale str))
                  )
                )
               
               (t)
               )
             )
            (t)
            )
          )
        )
      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
      )
    (princ "Nothing select.")
    )
  (setvar "LUPREC" oldlu)
  (setq *error* olderr)
  (princ)
  )

669423907

我也不懂啊

非洲人

需要遍历对象的，我做过的，成功了

XO-20170910

可以分享吗