[LISP]如何获得当前图形的比例尺

shmily1023

请问各位大侠 如何获得当前图形的比例尺？？

0451doctor

说得明白一点，在什么条件求比例！

shmily1023

在模型空间要求绘图比例！

晓雨

这应该是无法获得的,我们绘图时是零件图画好后就缩小放到标准图框里,然后在图框中填入缩小的比例,标注时在标注样式中放大相应的比例就行了.

0451doctor

能看明白这个程序，你就是图纸空间中的视口与模型空间是什么关系了，你的比例就求出来了！ (prompt "\nDETAIL - CADENCE 1999")
;; CADENCE January 1999 - Bill Kramer
;; Detail enlargement macro set.
;;-----------------------------------------------
;; Listing 1: The Main Program
;;-----------------------------------------------
(defun C:DETAIL ( / P1 EN EL PTS SS1)
(cond
;;Set up AutoCAD system variables
((DETAIL_0)
(prompt "\nError in DETAIL_0"))
;;
;;Operator input of detail center
;;and radius.
((DETAIL_1) ;;set up EL, P1, RD
(prompt "\nError in DETAIL_1"))
;;
;;Operator input of detail graphic location
;;and scale for detail display.
;;Copy detail area, remove non-detail objects
;;like dimensions and text, and scale as
;;input by the operator.
((DETAIL_2) ;;set up P2, SS1, EN, ENT, SCL
(prompt "\nError in DETAIL_2"))
;;
;;Do the trimming of the detail display.
((DETAIL_3)
(prompt "\nError in DETAIL_3"))
;;
;;Create the text tag and draw connecting
;;line between original area and detail
;;area.
((DETAIL_4) ;;Output text tag
(prompt "\nError in DETAIL_4"))
('T (prompt "\nDetail finished okay."))
)
;;
;;Reset system variables
(mapcar '(lambda (X)
(setvar (car X) (cadr X))) SYSVAR_LIST)
(prompt "\nUse TRIM to complete if needed.")
(princ)
)
;;-----------------------------------------------
;; Listing 2: Set up system variables
;;-----------------------------------------------
(defun DETAIL_0 ()
(setq SYSVAR_LIST (mapcar '(lambda (X)
(list X (getvar X)))
'("CMDECHO"
"OSMODE"
"ORTHOMODE"
"HIGHLIGHT"
)))
(setvar "CMDECHO" 0)
(setvar "OSMODE" 0)
(setvar "ORTHOMODE" 0)
(setvar "HIGHLIGHT" 0)
(if (zerop (getvar "WORLDUCS"))
(command "_UCS" "_W"))
nil
)
;;-----------------------------------------------
;; Listing 3: Establish area to detail
;;-----------------------------------------------
(defun DETAIL_1 ()
(setq P1 (getpoint "\nDetail center: "))
(if P1 (progn
(prompt "\nShow detail area: ")
(command "_CIRCLE" P1 pause)
(setq EN (entlast)
EL (entget EN)
RD (if (= (cdr (assoc 0 EL)) "CIRCLE")
(cdr (assoc 40 (entget EN)))
nil)
)
(if RD (progn
(entdel EN)
(command "_POLYGON" 15 P1 "I" RD)
(setq EN (entlast)
EL (entget EN)
)
nil ;return nil
)
1 ;return error level 1.
) ;;level 1 is RD not set
)
2 ;;return error level 2.
) ;level 2 is P1 not set
)
;;-----------------------------------------------
;; Listing 4: Copy objects to new location
;;-----------------------------------------------
(defun DETAIL_2 ()
(while (setq TMP (assoc 10 EL))
(setq EL (cdr (member TMP EL))
PTS (cons (cdr TMP) PTS)
)
)
(entdel EN)
(setq SS1 (ssget "CP" PTS)
P2 (getpoint P1 "\nPut detail at: ")
CNT (if SS1 (sslength SS1) 0)
)
(if P2 (progn
(repeat CNT
(if (member
(cdr (assoc 0
(entget
(ssname
SS1
(setq CNT (1- CNT))))))
'("TEXT" "DIMENSION"
"MTEXT" "INSERT"
)
)
(ssdel (ssname SS1 CNT) SS1)
)
)
(command "_CIRCLE" P1 RD
"_CIRCLE" P2 RD)
(setq EN (entlast)
ENT EN)
(command "_COPY" SS1 "" P1 P2)
(setq SS1 (ssadd EN))
(while (setq ENT (entnext ENT))
(ssadd ENT SS1)
)
(setq SCL (getreal "\nScale factor (2): "))
(if (null SCL) (setq SCL 2.0))
(if (/= SCL 1.0)
(command "_SCALE" SS1 "" P2 SCL)
)
nil ;;return nil result, all okay.
)
1 ;;return error code 1
) ;;error code, P2 not input.
)
;;-----------------------------------------------
;; Listing 5: Trim the objects copied
;;-----------------------------------------------
(defun DETAIL_3 ()
(setq TTT 0) ;;change counter
(while (setq ENT (ssname SS1 0))
(ssdel ENT SS1)
(if (not (equal ENT EN)) (progn
(setq EL (entget ENT)
PT (DETAIL_3A EL)
)
(if (and PT
(> (distance P2 PT)
(+ 0.2 (* RD SCL))))
(progn
(setq TTT (1+ TTT))
(command "_TRIM" EN ""
(list ENT PT) "")
))
))
(DETAIL_3B) ;;loop again check
)
nil
)
;;-----------------------------------------------
;; Listing 6: Find point on object for trim
;;-----------------------------------------------
(defun DETAIL_3A (EL / TY)
(setq TY (cdr (assoc 0 EL)))
(cond
((= TY "LINE")
(if (> (distance (cdr (assoc 10 EL)) P2)
(distance (cdr (assoc 11 EL)) P2))
(cdr (assoc 10 EL))
(cdr (assoc 11 EL))
)
)
((= TY "ARC")
(setq PC (cdr (assoc 10 EL))
PR (cdr (assoc 40 EL))
PA (cdr (assoc 50 EL))
PB (cdr (assoc 51 EL))
)
(if (> (distance (polar PC PA PR) P2)
(distance (polar PC PB PR) P2))
(polar PC PA PR)
(polar PC PB PR)
)
)
((= TY "CIRCLE")
(setq PC (cdr (assoc 10 EL))
PR (cdr (assoc 40 EL))
)
(cond
((> (distance P2
(polar PC 0.0 PR))
(* RD SCL))
(polar PC 0.0 PR))
((> (distance P2
(polar PC PI PR))
(* RD SCL))
(polar PC PI PR))
((> (distance P2
(polar PC (* 0.5 PI) PR))
(* RD SCL))
(polar PC (* 0.5 PI) PR))
(t (polar PC (* 1.5 PI) PR))
)
)
((= TY "LWPOLYLINE")
(setq PR nil)
(while (and (null PR)
(setq PA (assoc 10 EL)))
(setq EL (cdr (member PA EL))
PA (cdr PA)
)
(if (> (distance P2 PA) (* RD SCL))
(setq PR PA)))
)
((= TY "SPLINE")
(setq PR nil)
(while (and (null PR)
(setq PA (assoc 11 EL))
EL (cdr (member PA EL))
PA (cdr PA))
(if (> (distance P2 PA) (* RD SCL))
(setq PR PA)))
)
((= TY "POLYLINE")
(setq EL (entget
(entnext
(cdr (assoc -1 EL))))
PR nil)
(while (and (null PR)
(= (cdr (assoc 0 EL))
"VERTEX"))
(setq PA (cdr (assoc 10 EL))
EL (entget
(entnext
(cdr (assoc -1 EL))))
)
(if (> (distance P2 PA)
(* RD SCL))
(setq PR PA)
)
)
)
;;add more objects here
) ;;end COND for PT assignment
)
;;-----------------------------------------------
;; Listing 7: Loop control options for user
;;-----------------------------------------------
(defun DETAIL_3B ()
(if (= (sslength SS1) 0)
(if (> TTT 0) (progn
(initget 0 "Yes No")
(setq TTT (getkword (strcat
"\nChanged "
(itoa TTT)
" objects, Loop again? <Yes>")))
(if (or (null TTT) (= TTT "Yes"))
(progn
(setq SS1 (ssadd EN)
ENT EN)
(while (setq ENT (entnext ENT))
(ssadd ENT SS1)
)
(setq TTT 0)
))
))
)
)
;;-----------------------------------------------
;; Listing 8: Finishing touches
;;-----------------------------------------------
(defun DETAIL_4 ()
(command "_TEXT"
"_Justify" "_Center"
(polar P2
(* PI 1.5)
(+ (* SCL RD)
(* 2.5
(getvar "TEXTSIZE"))))
)
(if (zerop (cdr (assoc 40
(tblsearch
"STYLE"
(getvar "TEXTSTYLE")))))
(command "") ;;text height output option
)
(command 0 ;;finish the TEXT command sequence.
(strcat "Enlarged "
(rtos SCL 2
(Best_Prec SCL 0 4))
"x")
)
;;
;; Construct line between detail circles.
;;
(command "_LINE" (polar P1 (angle P1 P2) RD)
(polar P2 (angle P2 P1) (* RD SCL))
"")
nil
)
;;-----------------------------------------------
;; Listing 9: Utility Routine from toolbox
;;-----------------------------------------------
;; Best_Prec - Given a number (NUM) and the
;; minimum and maximum precision, this function
;; returns the precision in the range that will
;; best fit the number.
;;
(defun Best_Prec (Num Mn Mx)
(while (and (<= Mn Mx)
(/= Num (atof (rtos Num 2 Mn))))
(setq Mn (1+ Mn))
)
Mn
)
;; How can I get the coordinate relationship
;; between paper space and model space in a
;; specific viewport (while tilemode = 0)?
;; 这是一个非常有用的例子,看出它们的关系了吗??
;; 我以前也为找出它们的关系花了不少时间
(defun C:TEST (/ A W WDXF EA EN XP W10 W40 W41 W69 VCTRX VCTRY LPT RPT)
(setvar "tilemode" 0)
(command "_.PSPACE")
(while (not A)
(setq A (ssget ":s" '((0 . "VIEWPORT"))))
)
(setq W (ssname A 0))
(setq WDXF (entget W))
(setq EA (assoc -3 (entget W '("ACAD")))
EN (reverse (cdr (reverse (cdr (cddadr EA)))))
)
(setq XP (/ (cdr (assoc 41 WDXF)) (cdr (nth 4 EN))))
(setq W10 (cdr (assoc 10 WDXF)))
(setq W40 (/ (cdr (assoc 40 WDXF)) XP))
(setq W41 (/ (cdr (assoc 41 WDXF)) XP))
(setq W69 (cdr (assoc 69 WDXF)))
(command "_.MSPACE")
(command "_.cvport" W69)
(command "_.ucs" "v")
(setq VCTRX (car (getvar "viewctr")))
(setq VCTRY (cadr (getvar "viewctr")))
(setq LPT (list (- VCTRX (/ W40 2.0)) (- VCTRY (/ W41 2.0))))
(setq RPT (list (+ VCTRX (/ W40 2.0)) (+ VCTRY (/ W41 2.0))))
(command "_.rectang" LPT RPT)
(princ)
)

chenliguo

如果我没有记错，看看dimtxt这个系统变量，好象就是当前图形的比例。

xazhji

dimtxt 是文字高度。dimscale 是比例。

shmily1023

谢谢各位


太感谢拉