[推荐][求助]视图缩放时,始终保持标注尺寸不变-有LSP

yutianweidi

       

这个命令在AutoCAD2004里面有用，但是在AUTO2008里面会出现参数错误！请大家帮助我看看是否有与之相关的些东西没有搞好！

在绘图的时候，有某些很小的局部，需要详细的描述，我们把那个局部复制出来，通常用SC命令将其连同标注尺寸一起放大几倍，但是那样有个弱点，就是标注尺寸也会随之放大的倍数变化；我想能不能通过以下命令，实现视图缩放时,始终保持标注尺寸不变！

以下是我的LISP!欢迎帮助我，喷精也要感谢！

defun RS ( )               ;Real Scale,用于画剖视图缩放图元时,保持标注尺寸不变
  (SETQ INPT1 (LIST (- (CAR P ) R) (- (CADR P ) R))
        INPT2 (LIST (+ (CAR P) R) (+ (CADR P) R))
  )
  (setq scale (ssget "W" INPT1 INPT2))
  (SETQ ENTGRP scale)
  (SETQ COUNT 0)                                        
  (REPEAT (SSLENGTH ENTGRP)
    (SETQ ENTNAME (SSNAME ENTGRP COUNT))
    (SETQ ENT (ENTGET ENTNAME))
    (IF (AND (= (CDR (ASSOC 0 ENT)) "DIMENSION")       
             (/= (cdr (ASSOC 1 ENT)) ""))    
       (PROGN (PRINC "\n对象中不能有修改过的尺寸!") (EXIT)))
       (IF (and(= (CDR (ASSOC 0 ENT)) "DIMENSION")                ;AlignedDimension
            (= (cdr (nth 19 ent)) "AcDbAlignedDimension"))      
          (PROGN
              (setq P1 (assoc 13 ENT))
              (setq P2 (assoc 14 ENT))
              (setq P1x (nth 1 P1)) 
              (setq P1y (nth 2 P1))                  
              (setq P2x (nth 1 P2))
              (setq P2y (nth 2 P2))
              (setq DX (ABS(- P1x P2x)))          
              (setq DY (ABS(- P1y P2y)))           
              (setq SS (assoc 10 ENT))
              (setq TT (assoc 11 ENT))
              (setq SSx (nth 1 SS)) 
              (setq TTx (nth 1 TT))
              (setq SSy (nth 2 SS)) 
              (setq TTy (nth 2 TT))   
              (IF (= SSx TTx)                   
                 (setq V Dy))
              (IF (and(/= SSx TTx)(= SSy TTy))
                 (setq V Dx))                                      ;取得数值V1
              (IF (and(/= SSx TTx)(/= SSy TTy))
                 (setq V (distance (cdr p1) (cdr p2))))             
              (SETQ W (rtos V 2 2))
              (SETQ ENT (SUBST (CONS 1 W) (ASSOC 1 ENT) ENT))       ;MODIFY
              (ENTMOD ENT)                                          ;UPDATE
          )
      )
    (IF (and(= (CDR (ASSOC 0 ENT)) "DIMENSION")                    ;RadialDimension
            (= (cdr (nth 19 ent)) "AcDbRadialDimension"))
          (PROGN
              (setq P1 (assoc 10 ENT))
              (setq P2 (assoc 15 ENT))
              (setq V (distance (cdr p1) (cdr p2)))                ;取得数值V1           
              (SETQ W (strcat "R" (rtos V 2 2)))
              (SETQ ENT (SUBST (CONS 1 W) (ASSOC 1 ENT) ENT))       ;MODIFY
              (ENTMOD ENT)                                          ;UPDATE
          )
      )
  (SETQ COUNT (1+ COUNT))
  )
  (setq base P)(princ "Done")
  (SETQ factor (getint "\n /Scale factor:"))
  (command "_scale" scale "" base factor)
  (SETQ OLDLAYER (GETVAR "CLAYER"))
  (COMMAND "-LAYER" "S" "MARK" "") 
  (setq txtSTRING1 (strcat "DETAIL " NNN))   
  (setq txtSTRING2 (strcat "SCALE " (RTOS factor 2 0) ":1"))
  (setq base1 (list (car base) (+ (* 4 (GETVAR "DIMSCALE")) (cadr base))))     
  (COMMAND "_.TEXT" "S" "STANDARD" "J" "C" base1 (* 2.5 (GETVAR "DIMSCALE")) "" (strcase txtSTRING1 ))      
  (COMMAND "_.TEXT" "S" "STANDARD" "J" "C" base (* 2.5 (GETVAR "DIMSCALE")) "" (strcase txtSTRING2 ))
  (COMMAND "-LAYER" "S" OLDLAYER "")
  (PRINC "\n OK! ")
  (PRINC)
)

e2002

一直都不建议这么画图。

绘制详图，有好几种直接使用“真实尺度”的办法，
而不是用 “Scale对象，再去修改 Dimension 的标注倍数值” 这种看似简单，实际带来一堆麻烦的办法。

00放飞梦想00

yutianweidi 发表于 2013-8-16 03:36
(defun c:ccs (/ sym ssy sc snum systr scstr txtpnt numstr n cnt i txtlst oldtxt oldlay ent scpnt dim ...

提示部能不能帮改成中文呀，看不懂哦

yutianweidi

跪求解决方法呀！我的qq:  yutianweidi@yeah.net

英雄无敌

像你这样的程序，在哪都运行不了，不要说在2004中可以运行了，

你缩放后，将尺寸的dimlfac这个系统变量设有以前的dimlfac这个系统变量的值除以你的比例就行了。

即dimlfac=dimlfac/newscl

yutianweidi

能不能帮助我改改上传给我芽！

yutianweidi

我是新手 我是新手！帮帮我呀！

英雄无敌

改你的程序确实比较困难，因为不明白程序作者的意图。

还是贴上我自己的程序吧。

(defun c:scd (/ sc ss oldds oldfac poi n en myerr olderr osm ort)
;;;****************************************************
  ;;程序功能：变比例尺寸不变
  ;;作者：英雄无敌
  ;;QQ:280212043
  ;;Email:280212043
  (defun myerr (msg)
    ;;************************************************
    ;;在这里写入错误处理函数
    (setq *error* olderr)
    (princ msg)
;;;    (if osm
;;;      (setvar "osmode" osm)
;;;    )
;;;    (if ort
;;;      (setvar "orthomode" ort)
;;;    )
    (command "undo" "E")
    ;;**********************

    (princ)
  )
  (setq olderr *error*)
  (setq *error* myerr)
  ;;初始化

;;;  (setq osm (getvar "osmode"))
;;;  (setq ort (getvar "orthomode"))
;;;  (setvar "osmode" 0)
;;;  (setvar "orthomode" 0)
;;;****************************************************
  ;;在这里写入正常工作的函数

  (IF (SETQ ss (ssget))
    (PROGN
      (command "undo" "BE")
      (command "scale" ss "")
      (while (= nil (setq poi (getpoint "\n请输入基点:"))))
      (command poi (SETQ sc (getreal "\n请输入缩放比例 :")))
      (setq ss (ssget "p" '((0 . "dimension"))))
      (if ss
 (progn
   (setq oldds (getvar "dimstyle"))
   (setq n -1)
   (repeat (sslength ss)

     (command "_dimstyle"
       "restore"
       ""
       (setq en (ssname ss (setq n (1+ n))))
     )
     (setq oldfac (getvar "dimlfac"))
     (SETVAR "DIMLFAC" (/ oldfac sc))
     (COMMAND "DIMSTYLE" "_APPLY" en "")
   )
   (command "-dimstyle" "r" oldds)
 )
      )

    )
  )
;;;****************************************************
  ;;结束
;;;  (setvar "osmode" osm)
;;;  (setvar "orthomode" ort)
  (command "undo" "E")
  (setq *error* olderr)
  (princ)
)

yutianweidi

上面的程式可以改一下吗？让放大的时候那个局部下面会蹦出“I局部放大”然后下面一条直线，然后自动出来“1：3”的文字，而且文字始终是2.5的高度，那个“I”是提示用户手动输入的，那个“3”是提示放大几倍的时候自动关联的！

英雄无敌

这个是比较简单的，楼主何不试试自己加呢？

zctao1966

想法不错！

yutianweidi

(defun c:ccs (/ sym ssy sc snum systr scstr txtpnt numstr n cnt i txtlst oldtxt oldlay ent scpnt diment dimn measur
              newtxt prec dimtyp
             )
   (setvar "cmdecho" 0)
   ;(grtext -1 "该程序是用以将剖视图(或放大图)的尺寸自动从默认值变成实测值,再放大它并插入标示.")
   (setq ssy (getstring "\nThe section symbol is:"))
   (setq systr nil
         scstr nil
         numstr nil
   ) ;_ 结束setq
   ;;If no section symbol,then just make the measurement of the dimension.
   (IF (/= ssy "")
      (progn
         ;;(initget 128 "Detail Section")
         (setq sym (getstring "\n是剖视图还是放大图?Detail/<Section>:"))
         (if (or (= sym "") (= sym "s"))                    ;presume it as section view
            (setq systr (strcat "SECTION " ssy "-" ssy)
                  systr (strcase systr) ;|insure the input cha. is uppercase.|;
            ) ;_ 结束setq
            (setq systr (strcat "DETAIL " ssy)
                  systr (strcase systr)
            ) ;_ 结束setq
         ) ;_ 结束if
         (setq sc (getstring "\nThe section scale?(needed to be integers)"))
         ;| access the number of places to be scaled.|;
         (setq snum (getstring "\nHow many places?(needed to be integers)"))
         (if (> (atoi snum) 1)
            (setq numstr (strcat snum "PLS")
                  numstr (strcase numstr)
            ) ;_ 结束setq
         ) ;_if just 1 place,not display it.
      ) ;_ 结束progn
   ) ;_ 结束IF
   (grtext -1 "Please select the dimension object...")
   (setq ent (ssget))
   (setq diment (ssget "p" '((0 . "dimension")))
         n      (sslength diment)
   ) ;_ 结束setq
   (princ (strcat "\n*** Total " (itoa n) " dimensions to be selected. ***"))
   (setq cnt 0
         i 0
   ) ;_reset countor and list NO.
   (while (PROGN (grtext -1 "OK.Modifying the dimension...")
                 (< i n)
          )                                                 ;逐一搜索标注实体.
      (setq dimn (entget (ssname diment i)))                ;取得实体.
;;;->(setq dimn (entget (car (entsel))))                   ;取得实体数据表.
      (setq oldtxt (cdr (assoc 1 dimn))
            dimtyp (cdr (assoc 100 (reverse dimn)))
      ) ;_ 结束setq
      (if (and (or (wcmatch oldtxt "*<>*") (= oldtxt ""))
               (wcmatch dimtyp "~*Angular*")
          ) ;_ 结束and
          ;|只有是非角度尺寸,才用实测值代替默认值. |;
         (progn
            (setq measur (C42 dimn) ;|***调用函数c42(ent).|;
                  prec   (getvar "dimdec")
                  measur (rtos measur 2 prec) ;|将测量值从实数变成字串|;
            ) ;_ 结束setq
            (cond ((wcmatch dimtyp "*Diametric*") (setq measur (strcat "%%c" measur)))
                                                            ; _若是直径,则在数字前加直径符号"%%c"
                  ((wcmatch dimtyp "*Radial*") (setq measur (strcat "R" measur))) ;_若是半径,则在数字前加半径符号R.
            ) ;_ 结束cond
            (if (wcmatch oldtxt "*<>*")
               (setq newtxt (subst_str measur "<>" oldtxt)) ;|只替代默认值部分.***调用函数subst_str(newstr oldstr str)|;
               (setq newtxt measur)
            ) ;_ 结束if
            (setq dimn (subst (cons 1 newtxt) (cons 1 oldtxt) dimn))
            (entmod dimn)
            (setq cnt (1+ cnt))
         ) ;_ 结束progn
      ) ;_ 结束if
      (setq i (1+ i))                                       ;search the next dimension.
   ) ;_ 结束while
   (princ (strcat "\n*** Just " (itoa cnt) " dimensions modified! ***"))
   ;;if the scale is 1:1,not to scale it.
   (if (/= sc "")
      (if (> (atoi sc) 1)
         (progn (setq scpnt (getpoint "\nInput the scale center point:"))
                (command "._scale" ent "" scpnt (atof sc))
                (setq scstr (strcat "SCALE " sc ":1") ;_ if it's 1:1(no input),not to display it
                      scstr (strcase scstr)
                ) ;_ 结束setq
         ) ;_ 结束progn
      ) ;_ 结束if
   ) ;_ 结束IF
   (if (or systr scstr numstr)
      (progn
         (setq txtpnt (getpoint "\nWhere to place the note?"))
         (setq oldlay (getvar "clayer"))
         (if (tblsearch "layer" "mark")
            (setvar "clayer" "mark")
         ) ;_ 结束IF
         (command "._text" "s" "standard" "j" "mc" txtpnt (* 2.5 (getvar "dimscale")) "0" systr "")
         (if scstr
            (command "._text" "" scstr)
         ) ;_ 结束if
         (if numstr
            (command "._text" "" numstr)
         ) ;_ 结束if
                                                            ;(command)
         (setvar "clayer" oldlay)
      ) ;_ 结束PROGN
   ) ;_ 结束IF
   (setvar "cmdecho" 1)
   (grtext)
   (princ)
) ;_ 结束defun

;;;---------SUBPROGRAMM---------------

;;;This pro. is to make the linear dimension's measurement.
(defun c42 (ent / p1x p1y p2x p2y dy v ang dimtyp dx p1 p2 dimtyp)
   (setq dimtyp (cdr (assoc 70 ent))
         dimtyp (logand dimtyp 7)
   ) ;_ 结束setq
   (cond
      ;;aligned&rotateddimension
      ((= dimtyp 0)
       (progn
          (setq p1  (assoc 13 ent)
                p2  (assoc 14 ent)
                p1x (nth 1 p1)
                p1y (nth 2 p1)
                p2x (nth 1 p2)
                p2y (nth 2 p2)
                dx  (abs (- p1x p2x))
                dy  (abs (- p1y p2y))
                ang (cdr (assoc 50 ent))
          ) ;_ 结束setq
          (if (= ang 0)
             (setq v dx)
             (setq v dy)
          ) ;_ 结束if
       ) ;_ 结束progn
      ) ;_case 1
      ;;aligneddimension
      ((= dimtyp 1)
       (setq p1 (assoc 13 ent)
             p2 (assoc 14 ent)
             v  (distance (cdr p1) (cdr p2))
       ) ;_ 结束setq
      ) ;_case 2
      ;;radialdimension & diametricdimension
      ((or (= dimtyp 4) (= dimtyp 3))
       (setq p1 (assoc 10 ent)
             p2 (assoc 15 ent)
             v  (distance (cdr p1) (cdr p2))                ;取得数值v作为函数值.            
       ) ;_ 结束setq
      ) ;_case 3
   ) ;_ 结束cond
) ;_ 结束defun


;;;;-SUBROTINE 2------

;;;This pro. is to substitute a new string for the old string in the source string.
(defun subst_str (newstr oldstr str / i k k1 k2 n tmpstr stre strf)
   (setq k1 (strlen str)
         k2 (strlen oldstr)
         k  (1+ (- k1 k2))
         i  1
         n  nil
   ) ;_ 结束setq
   (while (<= i k)
      (setq tmpstr (substr str i k2))
      (if (= tmpstr oldstr)
         (progn
            (setq n i
                  i (1+ k)
            )                                               ;set the loop-off condition to end the loop
         ) ;_ 结束progn
         (setq i (1+ i))
      ) ;_ 结束if
   ) ;_ 结束while
   (setq k1   (1- n)
         k2   (+ k2 n)
         strf (substr str 1 k1)
         stre (substr str k2)
   ) ;_ 结束setq
   (setq str (strcat strf newstr stre))
) ;_ 结束defun

;;;~~~~~~~~~~end of CCS~~~~~~~~~~~~