局部放大

FT272296734 · 发表于 2015-1-30 15:03:11

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 yularna 于 2015-2-1 17:59 编辑

局部放大那里错了
[pcode=lisp,true]
(defun C:fd ( / line P1 EN EL PTS SS1) ;局部放大
(setq AcadObject (vlax-get-acad-object)
   AcadDocument (vla-get-ActiveDocument Acadobject)
   mSpace (vla-get-ModelSpace Acaddocument)
)
(setvar "CLAYER" "0")
(setq P1 (getpoint "\n指定放大中心点: "))
(if P1 (progn
      (command "circle" p1)
      (princ
      (strcat "\n指定放大半径 <" (rtos (getvar "CIRCLERAD")) ">:")
      )
   (command pause)
   (setq EN0 (entlast)
         EL (entget EN0)
         RD (if (= (cdr (assoc 0 EL)) "CIRCLE")
               (cdr (assoc 40 (entget EN0)))
               nil)
   )
   (if RD (progn
      ;(entdel EN0)
      (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
;)
;(defun c2 ()
(while (setq TMP (assoc 10 EL))
      (setq EL (cdr (member TMP EL))
            PTS (cons (cdr TMP) PTS)
      )
)
(entdel EN)
  (setq cir (vlax-ename->vla-object en0))
  (vla-put-color cir (getvar "dimclrd"))
  (vla-update cir)
  ;(entdel EN0)
  ;(ssadd (entlast) ss1)
  (setq cen (vlax-safearray->list
         (vlax-variant-value (vla-get-center cir))
         )
  )
  (setq pt (car cen))
  (princ "\n指定视图符号放置位置 <右键或回车修改视图符号>:")
  (setq i T)
  (while i
   (Setq NEXT_PT (GrRead T 4 0)
         READTYP (car NEXT_PT)
         READVAL (cadr NEXT_PT))
   (cond
   ((= READTYP 5)
   (setq NEXT_PT (cadr NEXT_PT))
   (setq next_pt (trans next_pt 1 0))
   (setq basept (vlax-curve-getclosestpointto cir NEXT_PT))
   (if (not line)
         (progn
            (if (not fh)(setq fh "A"))
(princ "1")
            (setq text (vla-addtext
                  mspace
                  fh
                  (vlax-3d-point next_pt)
                  (* xm_sca (getvar "dimtxt"))
            ))
            ;(vla-put-color text (getvar "dimclrt"))
            (vla-put-stylename text (getvar "dimtxsty"))
            (vla-update text)
            ;(ssadd (entlast) ss1)
            (setq line (vla-addline
                  mspace
                  (vlax-3d-point basept)
                  (vlax-3d-point next_pt)
            ))
            (vla-put-color line (getvar "dimclrd"))
            ;(ssadd (entlast) ss1)
            (setq txtlen (tzz text))
            (setq l2end (list (+ (car next_pt) txtlen) (cadr next_pt) 0))
            (setq l2 (vla-addline
                  mspace
                  (vlax-3d-point next_pt)
                  (vlax-3d-point l2end)
            ))
            (vla-put-color l2 (getvar "dimclrd"))
            ;(ssadd (entlast) ss1)
         )
         (progn
            (vla-put-startpoint line (vlax-3d-point basept))
            (vla-put-endpoint line (vlax-3d-point next_pt))
            (vla-update line)
            (setq ptt (car next_pt))
            (if (> ptt pt)
                  (progn
                  (setq text_x (+ (car next_pt) (getvar "dimgap")))
                  (setq l2_x (+ (car next_pt) txtlen (getvar "dimgap")))
                  )
                  (progn
                  (setq text_x (- (car next_pt) (getvar "dimgap") txtlen))
                  (setq l2_x text_x)
                  )
            )
            (vla-put-insertionpoint
                  text
                  (vlax-3d-point
                  (list text_x (+ (cadr next_pt) (getvar "dimgap")) 0)
                  )
            )
         (vla-update text)
         (vla-put-startpoint l2 (vlax-3d-point next_pt))
         (setq l2end (list l2_x (cadr next_pt) 0))
         (vla-put-endpoint l2 (vlax-3d-point l2end))
         (vla-update l2)
         )
      )
   )
   ((= READTYP 3) ;左键击
;;;    (MakeUnNameBlock ss1 cen)
      (setq i nil)
   )
   ((or (= 11 readtyp) (= 13 READVAL)) ;回车或右键
   (setq fh1 fh)
   (setq fh (getstring (strcat
      "\n输入新视图符号 <"
      fh
      ">:"
   )
  )
   )
   (if (= fh "")
  (setq fh fh1)
   )
   (vla-put-textstring text fh)
   (vla-update text)
   (setq txtlen (tzz text))
   (princ "\n指定视图符号放置位置 <右键或回车修改视图符号>:")
   )
)
  )
   (setq SCL (getreal "\n输入放大的倍数<2>:"))
   (if (null SCL) (setq SCL 2.0))
(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)
   )
   (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.
;)
(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
)
(DETAIL_3C)
(entdel EN0)
(xme)
)
(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)
      )
   )
   )
)
)
(defun DETAIL_3B ()
(if (= (sslength SS1) 0)
   (if (> TTT 0) (progn
            (setq SS1 (ssadd EN)
                  ENT EN)
            (while (setq ENT (entnext ENT))
            (ssadd ENT SS1)
            )
            (setq TTT 0)
   ))
)
)
(defun Tzz (Text / textent ang sinrot cosrot t1 t2 p0 p1 p2 p3 p4)
   (setq textent (entget (vlax-vla-object->ename Text)))
   (setq p0  (cdr (assoc 10 textent))
         ang  (cdr (assoc 50 textent))
         sinrot (sin ang)
         cosrot (cos ang)
         t1  (car (textbox textent))
         t2  (cadr (textbox textent))
         p1  (list (+ (car p0)
                        (- (* (car t1) cosrot) (* (cadr t1) sinrot))
                     )
                     (+ (cadr p0)
                        (+ (* (car t1) sinrot) (* (cadr t1) cosrot))
                     )
               )
         p2  (list (+ (car p0)
                        (- (* (car t2) cosrot) (* (cadr t1) sinrot))
                     )
                     (+ (cadr p0)
                        (+ (* (car t2) sinrot) (* (cadr t1) cosrot))
                     )
               )
      )
      (distance p1 p2)
)
(defun DETAIL_3C(/ loop ceo teo1 teo2)
(setq loop t)
(setvar "CLAYER" "0")
(command "line" (polar p2 0 (* 4.5 xm_sca)) (polar p2 pi (* 4.5 xm_sca)) "")
(setq ceo (vlax-ename->vla-object (entlast)))
(setvar "CLAYER" "0")
(vl-cmdf "text" "j" "m" p2 (* 5 xm_sca) 0 fh)
(setq teo1 (vlax-ename->vla-object (entlast)))
(vl-cmdf "text" "j" "m" p2 (* 5 xm_sca) 0 (strcat "1：" (rtos (/ xm_sca scl))))
(setq teo2 (vlax-ename->vla-object (entlast)))
(while loop
   (setq p (grread T))
   (setq k (car p))
   (setq p (cadr p))
   (if (= k 3)(setq loop nil))
   (vla-put-textalignmentpoint teo1 (vlax-3d-point (polar p (* 0.5 pi) (* 4.5 xm_sca))))
   (vla-put-textalignmentpoint teo2 (vlax-3d-point (polar p (* 1.5 pi) (* 4.5 xm_sca))))
   (vla-put-StartPoint ceo(vlax-3d-point (polar p 0 (* 8 xm_sca))))
   (vla-put-EndPoint ceo(vlax-3d-point (polar p pi (* 8 xm_sca))))
  )
)
[/pcode]

守仁格竹GM · 发表于 2015-2-1 10:31:08

{:soso_e100:}

FT272296734 · 发表于 2015-2-3 20:53:38

高手呢，回家过年了吗？帮个小忙啊

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

[求助] 局部放大

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。