放大样LISP程序

zhouwanweihf · 发表于 2011-5-3 18:35

请高手帮忙编写放大样LISP程序
要求如下：
1.可用圆及带矩形框选择裁剪，放大，放大倍数可为1
2.要可对块进行裁剪，以及填充线的裁剪
3.放大后的标注比例仍为1:1

以上为基本的3点要求，高手还可补充，谢谢！急盼高手出手相助，不胜感激！

香田里浪人 · 发表于 2015-9-20 12:41

skg123 发表于 2013-4-22 22:12

请教一下，如果要将选择范围改为矩形或多边形如何修改？

wangsr · 发表于 2023-10-29 09:56

305341043 发表于 2017-9-8 14:42
献给所有制图人......

可以放长方形吗

zhouwanweihf · 发表于 2017-11-8 09:13

305341043 发表于 2017-9-8 14:42
献给所有制图人......

放大不了图块啊

liminnet · 发表于 2011-5-3 19:35

提示: 作者被禁止或删除内容自动屏蔽

raimo · 发表于 2011-5-5 21:04

本帖最后由 raimo 于 2011-5-5 21:06 编辑

大样什么的还是自己来吧..这个就别偷懒啦,不实用的..除非你每个图都出得跟大样一样详细,随便截哪里都可以直接用

zhouwanweihf · 发表于 2011-5-5 23:26

因为我们先要画剖视图，所以剖视图中画得较祥细，放大样也跟剖视图一样，所以，有请高手帮忙编写LISP可截取大样，TKS!

longer1000 · 发表于 2012-2-8 15:10

帮顶中！！！！！！！！！！！！

skg123 · 发表于 2013-4-22 22:12

;; http://www.mjtd.com/BBS/dispbbs.asp?boardID=3&ID=25094&page=1
;; 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 "\n指定中心: "))
(if P1 (progn
(prompt "\n指定范围: ")
(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 "\n 选择局部图插入点: ")
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 "\n请输入放大倍数 (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
"\nChange"
(itoa TTT)
" 修剪范围外的对象吗? Yes/No<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
)

;; http://www.mjtd.com/BBS/dispbbs.asp?boardID=3&ID=25094&page=1 
;; 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 "\n指定中心: ")) 
   (if P1 (progn 
      (prompt "\n指定范围: ") 
      (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 "\n 选择局部图插入点: ") 
         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 "\n请输入放大倍数 (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 
              "\nChange" 
              (itoa TTT) 
              " 修剪范围外的对象吗? Yes/No<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 
)

mokson · 发表于 2013-4-23 13:46

太复杂了。

zhouwanweihf · 发表于 2013-4-23 18:29

skg123 发表于 2013-4-22 22:12

无法对图块操作

skg123 · 发表于 2015-9-20 13:15

转载
黄明儒

;;*************************************************************************放大主程序
;;全局JBFD_GetScalStri放大倍数（字符），JBFD_BaseNumber标识（数字）,JBFD_ZoomStri视口
(defun C:FD (/ BASESYMBOL BLI1 CLA1 CMD1 CP
 DCLID DIM1 ENT ENTCICL ENTTEXT FN FNAME
 GETZOOM LAY LIN NEWBLOCK NEWP NEWSS OSM1
 P1 P2 PL RETURN# SCALREAL SS TEXTHEIGH
 X
 )
 ;;1 错误处理
 (defun *error* (s)
(while (not (equal (getvar "cmdnames") "")) (command nil))
(if entText
 (command "_.erase" entText "")
)
(if lay
 (setvar "clayer" lay)
)
(setvar "blipmode" bli1)
(setvar "cmdecho" cmd1)
(setvar "DIMASSOC" DIM1)
(setvar "osmode" osm1)
(princ s)
(princ "出错啦!")
(princ)
 )
 ;;2 对象是否在锁定层上
 (defun onlocked (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
 )
 ;;3 构成新的选择集,EntCicl不加入
 (defun ss=>NewSS (SS EntCicl / E N NEWSS)
(setq NewSS (ssadd))
(repeat (setq n (sslength ss))
 (setq e (ssname ss (setq n (1- n))))
 (if (or (equal e EntCicl) (onlocked e))
 nil
 (progn
 (command "_.copy" e "" (list 0 0 0) (list 0 0 0))
 (setq NewSS (ssadd (entlast) NewSS))
 )
 )
)
NewSS
 )
 ;;4 0层上生成块
 (defun NONAME_BLK (SS PCircl / A lay)
(setq lay (getvar "clayer"))
(setvar "clayer" "0")
(setq A (rtos (* (getvar "CDATE") 1E8)))
(if (and SS PCircl)
 (progn
 (command "_.BLOCK" A PCircl SS "")
 (command "_.INSERT" A "@" "" "" "")
 )
)
(setvar "clayer" lay)
(entlast)
 )
 ;;5 画引线
 (defun HdrawLeader (EntCicl BaseSymbol Textheigh CP /
 A AA B BB C CC D
 DD EE ENTTEXT FF I TEXTLIS
 )
(command "_.text" CP Textheigh "" BaseSymbol)
(setq entText (entlast))

(setq TextLis (entget entText))
(setq i T)
(while i
 (setq a (grread T 4 0)
 b (car a)
 c (cadr a)
 )
 ;;b=5移动，b=3左键,c=0右键,;;c=13回车,c=32空格
 (cond ((= b 5)
 (redraw)
 (setq a (trans (cadr a) 1 0))
 (setq d (vlax-curve-getclosestpointto EntCicl a))
 (setq aa (car a)
 bb (cadr a)
 cc (caddr a)
 )
 (setq dd (car d)
 ee (cadr d)
 ff (caddr d)
 )
 (if (<= aa dd)
 (progn (setq TextLis (subst (cons 72 2) (assoc 72 TextLis) TextLis))
 (setq TextLis (subst (cons 11 a) (assoc 11 TextLis) TextLis))
 )
 (progn (setq TextLis (subst (cons 72 0) (assoc 72 TextLis) TextLis))
 (setq TextLis (subst (cons 10 a) (assoc 10 TextLis) TextLis))
 )
 )
 (entmod TextLis)
 (grdraw a d 1)
 )
 ((= b 3) (setq i nil))
 )
)

(redraw)
(entdel entText)
(if (VL-CATCH-ALL-ERROR-P
 (VL-CATCH-ALL-APPLY 'setvar (list "DIMLDRBLK" "DotSmall"))
 )
 (VL-CATCH-ALL-APPLY 'setvar (list "DIMLDRBLK" "小点"))
)
(vl-cmdf "_.layer" "make" "DIM" "Color" 3 "" "")
(command "_.leader" d (cadr a) "" BaseSymbol "")
 )

 ;;6 返回多义线顶点点列表,有圆弧则用一定角度分割圆弧，闭合多义线点表不含闭合点坐标
 ;;(setq pl (gxl-pL ent 0.017))
 (defun gxl-pL (en fgx / BJ BUGLE D D0 D1 D2
 ENT K N OBJ OBJNAME PARAM PLIST PT
 SECDEV VERTEXSNUM
 )
;;gxl-get_poly_ptList 返回多义线顶点点列表不含圆弧段内容，闭合多义线点表不含闭合点坐标
;;(gxl-get_poly_ptList (car (entsel)))
(defun gxl-get_poly_ptList (e / _pl n k)
 (if (= 'ename (type e))
 (setq e (vlax-ename->vla-object e))
 )
 (cond ((= "AcDbCircle" (vla-get-ObjectName e))
 (list (vlax-curve-getPointAtParam e 0)
 (vlax-curve-getPointAtParam e (* pi 0.5))
 (vlax-curve-getPointAtParam e pi)
 (vlax-curve-getPointAtParam e (* 1.5 pi))
 )
 )
 ((= "AcDbArc" (vla-get-ObjectName e))
 (list (vlax-curve-getStartPoint e)
 (vlax-curve-getendPoint e)
 )
 )
 (t
 (setq n (1+ (fix (vlax-curve-getEndParam e)))
 k -1
 )
 (if (vlax-curve-isClosed e)
 (setq n (1- n))
 )
 (repeat n
 (setq k (1+ k))
 (if (vlax-curve-getSecondDeriv e k)
 (setq
 _pl (append _pl (list (vlax-curve-getPointAtParam e k)))
 )
 )
 )
 )
 )
 _pl
)

(if (= 'ENAME (type en))
 (setq obj (vlax-ename->vla-object en)
 ent en
 )
 (setq obj en
 ent (vlax-vla-object->ename en)
 )
)
(setq vertexsNum
 (fix (vlax-curve-getEndParam ent))
 n 0
)
(setq objName (vla-get-ObjectName obj))
(cond ((= "AcDbCircle" objName)
 (if (equal fgx 0 1e-6)
 (setq fgx (* pi 0.5))
 )
 (setq vertexsNum
 (fix (/ (* pi 2) fgx))
 n 0
 )
 (repeat vertexsNum
 (setq pt (vlax-curve-getPointAtParam obj (* n fgx)))
 (setq plist (cons pt plist)
 n (1+ n)
 )
 )
 (reverse plist)
 )
 (t
 (if (= "AcDb2dPolyline" objName)
 (progn
 (repeat vertexsNum
 (setq pt (vlax-curve-getPointAtParam ent n))
 (setq plist (cons pt plist))
 (setq pt (vlax-curve-getPointAtParam ent (+ 0.25 n)))
 (setq plist (cons pt plist))
 (setq pt (vlax-curve-getPointAtParam ent (+ 0.5 n)))
 (setq plist (cons pt plist))
 (setq pt (vlax-curve-getPointAtParam ent (+ 0.75 n)))
 (setq plist (cons pt plist))
 (setq n (1+ n))
 )
 (if (not (vlax-curve-isClosed ent))
 (setq plist (cons (vlax-curve-getEndPoint ent) plist))
 )
 (reverse plist)
 )
 (if (equal fgx 0 1e-6)
 (setq plist (GXL-GET_POLY_PTLIST en))
 (progn
 (repeat vertexsNum
 (if (setq secdev (vlax-curve-getSecondDeriv ent n))
 (progn
 (setq pt (vlax-curve-getPointAtParam ent n)
 bugle (vla-GetBulge obj n)
 )
 (setq plist (cons pt plist))
 (if (/= bugle 0.0)
 (progn
 (setq bj (* (atan (abs bugle)) 4))
 (setq d1 (vlax-curve-getdistAtParam ent n)
 d2 (vlax-curve-getdistAtParam ent (1+ n))
 d (- d2 d1)
 k (fix (/ bj fgx))
 d0 (/ 1.0 (1+ k))
 param n
 )
 (if (equal d0 1.0 0.001)
 (setq plist (cons (vlax-curve-getPointAtParam
 ent
 (+ 0.5 param)
 )
 plist
 )
 )
 (repeat k
 (setq
 plist (cons (vlax-curve-getPointAtParam
 ent
 (setq param (+ param d0))
 )
 plist
 )
 )
 )
 )
 )
 )
 )
 )
 (setq n (1+ n))
 )
 (if (not (vlax-curve-isClosed ent))
 (setq plist (cons (vlax-curve-getEndPoint ent) plist))
 )
 (reverse plist)
 )
 )
 )
 )
)
plist
 )
 ;;7 对话框上用户选择
 (defun getdata ()
(setq BaseSymbol (get_tile "Fuhao"))
(setq JBFD_GetScalStri (get_tile "Scal"))
(setq JBFD_ZoomStri (get_tile "Zoom1"))
 )
 ;;8 对话框
 (defun FDdcl ()
(setq fname (vl-filename-mktemp nil nil ".dcl"))
(setq fn (open fname "w"))
(write-line "Fddcl : dialog{" fn)
(write-line "label=\"*黄明儒*局部放大命令:FD\";" fn)
(write-line ":column{ " fn)
(write-line
 " :edit_box{label=\"放大标识(F)\";key=\"Fuhao\";value=\"B\";mnemonic=\"F\";}"
 fn
)
(write-line
 " :edit_box{label=\"放大倍数(S)\";key=\"Scal\";value=\"2.0\";mnemonic=\"S\";} "
 fn
)
(write-line
 " :edit_box{label=\"视口选择(Z)\";key=\"Zoom1\";value=\"0\";mnemonic=\"Z\";} "
 fn
)
(write-line
 " :text{key=\"Scaltext\";value=\"圆0,已知封闭曲线1,椭圆2,其余多边形\";}"
 fn
)
(write-line " }" fn)
(write-line " ok_only;" fn)
(write-line "}" fn)

(close fn)
(setq fn (open fname "r"))
(setq dclid (load_dialog fname))
(while
 (or (eq (substr (setq lin (vl-string-right-trim
 "\" fn)"
 (vl-string-left-trim "(write-line \"" (read-line fn))
 )
 )
 1
 2
 )
 "//"
 )
 (eq (substr lin 1 (vl-string-search " " lin)) "")
 (not (eq (substr lin (+ (vl-string-search " " lin) 1) 9)
 " : dialog"
 )
 )
 )
)
(new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
(set_tile "Fuhao" BaseSymbol)
(set_tile "Scal" JBFD_GetScalStri)
(set_tile "Zoom1" JBFD_ZoomStri)
(mode_tile "Scal" 2)
(Action_Tile "Fuhao" "(Setq BaseSymbol $Value)")
(Action_Tile "Scal" "(Setq JBFD_GetScalStri $Value)")
(Action_Tile "Zoom1" "(Setq JBFD_ZoomStri $Value)")
(action_tile "accept" "(getdata)(done_dialog)")
(setq return# (start_dialog))
(unload_dialog dclid)
(close fn)
(vl-file-delete fname)
 )

 ;;9 本程序主程序
 (VL-LOAD-COM)
 (setq bli1 (getvar "blipmode"))
 (setq cmd1 (getvar "cmdecho"))
 (setq DIM1 (getvar "DIMASSOC"))
 (setq CLA1 (getvar "CLAYER"))
 (setq osm1 (getvar "osmode"))
 (setvar "blipmode" 0)
 (setvar "cmdecho" 0)
 (setvar "DIMASSOC" 1)
 (setvar "osmode" 0)
 (vl-cmdf "layer" "make" "DIM" "Color" 3 "" "")
 (if (= JBFD_BaseNumber nil)
(setq JBFD_BaseNumber 65)
(setq JBFD_BaseNumber (1+ JBFD_BaseNumber))
 )
 (SETQ BaseSymbol (chr JBFD_BaseNumber))
 (if (= JBFD_GetScalStri nil)
(setq JBFD_GetScalStri "2.5")
 )
 (if (= JBFD_ZoomStri nil)
(setq JBFD_ZoomStri "0")
 )
 (FDdcl)
 (setq JBFD_BaseNumber (ascii BaseSymbol))
 (SETQ Scalreal (atof JBFD_GetScalStri))
 (SETQ getZoom (abs (atoi JBFD_ZoomStri)))

 (if (/= 1 getZoom)
(SETQ CP (GETPOINT "\n 局部放大中心点: "))
 )
 (cond ((= 0 getZoom) (command "_.CIRCLE" CP pause))
 ((= 1 getZoom)
 (while
 (not
 (and
 (setq ent (car (entsel "\n 拾取封闭曲线:")))
 (setq p1 (cdr (assoc 0 (entget ent))))
 (member p1
 '("SPLINE" "LWPOLYLINE" "POLYLINE" "CIRCLE" "ELLIPSE")
 )
 (if (member p1 '("SPLINE" "LWPOLYLINE" "POLYLINE"))
 (= (vlax-get-property (vlax-ename->vla-object ent) 'Closed)
 :vlax-true
 )
 T
 )
 )
 )
 )
 )
 ((= 2 getZoom) (command "_.ellipse" CP pause pause))
 (T (command "_.polygon" getZoom CP "_I" pause))
 )
 (SETQ EntCicl (entlast))
 ;;(ayEntSSHighLight EntCicl)
 (if (= 1 getZoom)
(SETQ EntCicl ent)
 )

 (vla-getboundingbox
(vlax-ename->vla-object EntCicl)
'p1
'p2
 )
 (setq p1 (vlax-safearray->list p1))
 (setq p2 (vlax-safearray->list p2))
 (setq CP (mapcar '(lambda (X) (/ x 2.0)) (mapcar '+ p1 p2))) ;中心点
 (setq pl (gxl-pL EntCicl 0.017)) ;取点
 (setq ss (ssget "cp" pl)) ;选择对象
 (setq newSS (ss=>NewSS SS EntCicl)) ;原地拷贝
 (setq Newblock (NONAME_BLK newSS CP)) ;制作成块
 ;;遮盖
 (command "_.xclip" Newblock "" "n" "p")
 (foreach a pl (command a))
 (command "")
 (while (not (equal (getvar "cmdnames") "")) (command nil))

 (command "_.copy" EntCicl "" (list 0 0 0) (list 0 0 0))
 (setq EntCicl (entlast))

 (SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE"))) ;字度Textheigh
 (HdrawLeader EntCicl BaseSymbol Textheigh CP) ;画引线
 (setq NewP (mapcar '+
 (list 0 (+ (* Scalreal (- (cadr p2) (cadr CP))) Textheigh))
 CP
 )
 )
 (command "_.text"
 "J"
 "C"
 NewP
 Textheigh
 ""
 (strcat BaseSymbol " 放大 " JBFD_GetScalStri "X")
 )

 (command "_.scale" Newblock EntCicl "" CP Scalreal)
 (command "_.move" Newblock (entlast) EntCicl "" CP pause)

 (setvar "blipmode" bli1)
 (setvar "cmdecho" cmd1)
 (setvar "DIMASSOC" DIM1)
 (setvar "osmode" osm1)
 (gc)
 (princ)
)
;;*************************************************************************放大主程序

账号		自动登录	找回密码
密码			注册

liminnet liminnet 当前离线积分 9737 明经币个注册时间 2007-8-22 在线时间小时威望金钱个贡献激情	发表于 2011-5-3 19:35 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽

	回复支持反对使用道具举报显身卡