动态比例程序目前只能单选,求改成多选.......（原作者莫怪）
本帖最后由 18507396120 于 2018-1-3 17:55 编辑原贴地址:[源码] 不知道标注全局比例？就动态修改。附: 标注断开及连续标注，标注合并
******************************************************************************
;;========================================
;;动态比例
;; 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)
******************************************************************************
支持。希望高人过来搞搞 http://bbs.mjtd.com/thread-169462-1-1.html 669423907 发表于 2018-1-4 16:18
http://bbs.mjtd.com/thread-169462-1-1.html
这个貌似没有显示比例的...... 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 ":L" '((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)
)
我也不懂啊 需要遍历对象的，我做过的，成功了 可以分享吗
页:
[1]