[讨论][LISP]一個局部放大程序

ljs026

请问各位大大，这个程序，放大出来后，放大圆底下的Enlarged 2x 註解文字怎不会跟著图纸比例变另？文字好小哦，请教教小弟如何更改，另外可以拿掉Changed 2 objects, Loop again? 这个选项吗？小弟觉得有些麻烦说，如果小弟有个PHA的图层，那么放大出来的这个圆可以直接变成PHA层吗？(圆里面的物件层不变哦！只是放大的这个圆) (prompt "\nDETAIL - (c)1998 AUTO-CODE MECHANICAL - *FREEWARE*")
;;
;; FREEWARE Program - you are free to make copies of this and supply it
;; to others as is. Author and company make no
;; warrenty on the fitness of this program for anything
;; other than using as an example when learning
;; AutoLISP.
;;
;; Adapted from the CADENCE January 1999 article by Bill Kramer
;;
;; Detail enlargement macro set.
;;-----------------------------------------------
;; 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 "TILEMODE")) ;;make sure we are mspace
(if (= (getvar "CVPORT") 1) (progn ;;we are in paper space!
(alert "You must be in Model Space for this routine to function!")
(exit) ;;hard abort!
))
)
(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
)

TOOONG

;;-----------------------------------------------
;; Listing 8: Finishing touches

站内搜索更多有关 [[讨论][LISP]一個局部放大程序] 的信息

zhouwanweihf

请问是还可做到用矩形放大呢，而不是圆，别外我想把输入文字这项取消掉，该怎么做，谢谢，急！

自贡黄明儒

放大圆底下的Enlarged 2x 註解文字怎不会跟著图纸比例变？见(defun DETAIL_4 ()
(command "_TEXT" 这一句并没有加入放大倍数"dimscale"

这个程序还是啃不动块呀，可惜！！！

yxl88168

我看到过有的可以把放大后的图变成块，楼主能不能加上啊

waterchen

好程序,学习了.谢谢!

LIULISHENG

我来顶上去

luxcn

终于找到好的资源，分享分享

l982414603

我来顶上去