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

yutianweidi 发表于 2010-1-4 14:29:00

本帖最后由作者于 2010-1-4 14:51:29 编辑         这个命令在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 发表于 2022-2-18 10:26:06

一直都不建议这么画图。

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

00放飞梦想00 发表于 2022-2-17 10:10:10

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 发表于 2010-1-4 14:53:00

跪求解决方法呀！我的qq:  <a href="mailto:yutianweidi@yeah.net">yutianweidi@yeah.net</a>

英雄无敌 发表于 2010-1-4 15:33:00

像你这样的程序，在哪都运行不了，不要说在2004中可以运行了，你缩放后，将尺寸的dimlfac这个系统变量设有以前的dimlfac这个系统变量的值除以你的比例就行了。即dimlfac=dimlfac/newscl

yutianweidi 发表于 2010-1-4 15:50:00

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

yutianweidi 发表于 2010-1-4 15:55:00

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

英雄无敌 发表于 2010-1-4 19:41:00

改你的程序确实比较困难，因为不明白程序作者的意图。还是贴上我自己的程序吧。(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 发表于 2010-1-13 19:16:00

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

英雄无敌 发表于 2010-1-14 08:12:00

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

zctao1966 发表于 2011-9-2 13:02:11

想法不错！

yutianweidi 发表于 2013-8-16 03:36:30

(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...")
 ((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))
 i1
 nnil
) ;_ 结束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~~~~~~~~~~~~

页: [1] 2

明经CAD社区's Archiver

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