[编程交流] 查看方向（帮助）

;hp# 06/08/14
;edit attrib string
(defun eat$ (en l) ; where en is entity name, l = string list 
 (if (and (setq ve (vlax-ename->vla-object en))
   (vlax-get-property ve 'hasAttributes))
   (mapcar ''((a b) (vla-put-textstring a b))
    (vlax-safearray->list (vlax-variant-value (vla-GetAttributes ve)))
   l ;(list symbol scale)
    ) ;_ end of mapcar
   ) ;_ end of if
 (princ)
 ) ; _ end of defun

;;;v1.2: 31/08/2014
;;;     (hp:pointer pt c nil)
;;;         (dov:arc ....)
;;;         (LM:Arc->Bulge ..)
;;;      (sk_mk_arc01 ..)
;;;          dov:dcl localized
;;v1.1: 11/08/2014
;;;         inside qleader, setvar sz removed 
;;;         (setvar var...)
;;;         "dimtxsty" "textstyle"
;;;         fixed textsize bug
;;;         define (dov:MTEXT ...)
;;;         arrow Alan J Thomas
;;;         (Trans p .. )
;;;         Format Mtext Ref: CAB's Strip_Text.lsp CopyRight© 2005-2007
;;;         *DEF* *SYM* *VSC* *VDR* *TSZ* *dov:run-once*
;;;         define (dov:dcl)
;;;         setvar
;;;         cancel exit
;;;         redefine (qleader p1 p2 str sz sty ass ) ; associative T/nil, T = normal / nil = by arrow
;;;         (hp:pt pt os) fixed osnap bug
;;;         Prompt [option] to active dialog
;;;Reference / courtesy of
;;;Arrow*                   Alan J. Thomas                                                        
;;;Format Mtext*          CAB's Strip_Text.lsp CopyRight© 2005-2007                        
;;;Dialog style*          http://web2.airmail.net/terrycad/Tutorials/MyDialogs.htm        
;;;Dialog to temp*         Inspired by Tharwat & LM                                        
;;;Undocumented vlax-get Thanx Tharwat & LM                                                
;;;Quoted lambda*          Inspired by Lee Mac defun-q LM:doc
;;;sub: LM:Arc->Bulge          Lee Mac         
;;;sub: sk_mk_arc01         mjtd's coder (shared by AIberto)
;;;sub: dov:arc                 ditto
(if (and txh (tblsearch "style" "COMPLEX"))
     (progn (mapcar ''((x) (setvar x "COMPLEX")) '("dimtxsty" "textstyle"))
            (setq txs (entget (tblobjname "style" "COMPLEX")))
            (entmod (subst (cons 40 txh) (assoc 40 txs) txs))
            ) ;_ end of progn
     ) ;_ end of if
(setq *DEF*             '(*SYM* *VSC* *VDR* *TSZ*)
     *dov:run-once* t
     ) ;_ end of setq
(if (vl-some ''((x) (not (eval x))) *DEF*)
 (mapcar 'set *DEF* '("A" "1:1" "Rotation" "1.0"))
 ) ;_ end of if
;http://www.cadtutor.net/forum/showthread.php?88027-The-direction-of-view-(help)
(defun c:DOV (/        p dd *error* dcl dcl_id        key pop        i txh var oldvar pt bp A-Z blk Symbol ViewScale        ViewDir        Textsize txs
        dov:dcl ;<--
      );*dcl_gt*
(defun hp:pt (msg fun os / o p)
 (setq o (getvar "osmode"))
 (setvar "osmode" os)
 (setq p T)
 (while (or (not (listp p)) (= p nil))
   (initget "Options")
   (setq p (getpoint msg))
   (if        (= p "Options")
     (progn (eval fun) (setq p nil))
     ) ;_ end of if
   ) ;_ end of while
 (setvar "osmode" o)
 p
 ) ;_ end of defun
(defun dov:MTEXT (str pt sz)
 (entmakex (mapcar 'cons
           '(0 100 100 1 10 40 50 7 71 72)
           (list "MTEXT"
                 "AcDbEntity"
                 "AcDbMText"
                 (strcat "{\\fComplex|b0|i0|c0|p34;" str "}") ;<-- Ref: CAB's Strip_Text.lsp CopyRight© 2005-2007
                 pt
                 sz
                 0.0
                 (getvar "textstyle")
                 5
                 5
                 ) ; _ end of
           ) ;_ end of mapcar
   ) ;_ end of entmake
 ) ;_ end of defun
 
 (defun qleader (p1 p2 str sz sty ass / p1 p2) ; R1.0 : string ,textsize, textstyle, associative 
   (if        (and p1 p2)
     (if ass
(vl-cmdf "LEADER" p1 p2 "" str "")
(progn
  (vl-cmdf "_.leader" "_non" p1 "_non" p2 "" "" "_N") ;  <----- Arrow : Alan J. Thompson
       (dov:MTEXT str (trans (polar P2 (angle P1 P2) (* txh 1.5)) 1 0) txh)
  ) ;_ end of progn
) ;_ end of if
     ) ;_ end of if
   (redraw)
   ) ;_ end of defun
 
 (setq        dcl    (strcat (getvar "tempprefix") "tmp.dcl")
key    '("Symbol" "ViewScale" "ViewDir" "Textsize")
pop    '((key lst) (start_list key) (mapcar 'add_list lst) (end_list))
i      90
txh    (getvar "textsize") ;<--- default
var    '("cmdecho" "osmode" "dimtxt" "dimasz" "textsize")
oldvar (mapcar 'getvar var)
) ;_ end of setq
 
 (defun *error* (msg)
   (if        (not (wcmatch (strcase msg) "*CANCEL*,*EXIT*"))
     (princ (strcat "\nError: " msg))
     ) ;_ end of if
   (mapcar 'setvar var oldvar)
   (princ)
   ) ;_ end of defun
 
 ('((lst / f)
    (setq f (open dcl "w"))
    (mapcar ''(($) (write-line $ f)) lst)
    (close f)
    (setq f nil)
    )
   (apply 'append
   (list '("DOV:dialog{key ="Title";" "label ="Direction of View";" "spacer;")
         (mapcar ''((a b)
                    (strcat                   ":row{fixed_width = true;"                       ":column{width = 20.;"
                     "fixed_width = true;" "spacer;"                 ":text{label = ""    a
                     "";}}"                   ":popup_list{key = "         b                       ";"
                     "width = 15.0;}}"           ""
                     )
                    )
                 '("Symbol number" "ViewScale" "Direction of View" "Text Height")
                 key
                 ) ;_ end of mapcar
         '("spacer;"                         "        : paragraph{"               "        : text_part{"
           "\tlabel ="hanhphuc 2014 ";"                               "\talignment = right;"
           "}}"
           )
         '("spacer;ok_cancel;}")
         ) ;_ end of list
   ) ;_ end of apply
   )
 (repeat 26
   (setq A-Z (cons (vl-list->string (list i)) A-Z)
  i   (1- i)
  ) ;_ end of setq
   ) ;_ end of repeat
 (mapcar ''((a b) (set (eval '(read a)) b))
  key
  (list        A-Z
        '("1 : 1" "1 : 1.5" "1 : 2" "1 : 2.5" "1 : 3" "1 : 4" "1 : 5" "1 : 10" "2 : 1" "2.5 : 1" "4 : 1" "5 : 1"
          "10 : 1") ;<----- you can add more scale here
        '("Rotation" "Left rotation" "Right rotation")
        (list (rtos (getvar "textsize") 2 1) "0.1" "0.2" "0.5" "1.0" "1.5" "2.5" "5.0")  ;<---- you can add more text size here
        ) ;_ end of list
  ) ;_ end of mapcar
 
(setq dov:dcl '(nil
        (setq dcl_id (load_dialog dcl))
        (new_dialog "DOV" dcl_id)
        (if
         *dcl_gt*
         (mapcar 'set_tile key *dcl_gt*)
         (mapcar 'set_tile key '("0" "0" "0" "0"))
         ) ;_ end of if
        (mapcar
         ''(($) (pop $ (eval (read $))) (action_tile $ (strcat "(get_tile "" $ "")")))
         key
         ) ;_ end of mapcar
        (action_tile "accept" "(setq *dcl_gt* (mapcar 'get_tile key))(done_dialog 1)")
        (if
         (zerop (setq dd (start_dialog)))
         (exit)
         ) ;_ end of if
        (mapcar
         ''((a b c) (set (eval 'a) (nth (atoi ((eval b) *dcl_gt*)) (eval (read c)))))
         *DEF*
         '(car cadr caddr cadddr)
         key
         ) ;_ end of mapcar
        (setq txh (atof *TSZ*)) ;_ end of setq
        )
     ) ;_ end of setq
 
 (if *dov:run-once*
   (dov:dcl)
   ) ;_ end of if
 (while (or (= p nil) (= p "Options"))
   (initget "Options")
   (setq p (getpoint (strcat "\nPick Point or [Options] < Symbol= "
                      *SYM*
                      " | Scale="
                      *VSC*
                      " | "
                      *VDR*
                      " | Height: "
                      (rtos txh)
                      " > ? : "
                      ) ;_ end of strcat
              ) ;_ end of getpoint
  ) ;_ end of setq
   (if        (= p "Options")
     (progn (dov:dcl) (setq p nil))
     ) ;_ end of if
   ) ;_ end of while
 (if (/= dd 0)
   (progn (if (and txh (tblsearch "style" "COMPLEX"))
     (progn (mapcar ''((x) (setvar x "COMPLEX")) '("dimtxsty" "textstyle"))
            (setq txs (entget (tblobjname "style" "COMPLEX")))
            (entmod (subst (cons 40 txh) (assoc 40 txs) txs))
            ) ;_ end of progn
     ) ;_ end of if
   (mapcar 'setvar var (list 0 47 txh txh txh))
     (if (not (tblsearch "Layer" "dov"))
(vl-cmdf "-Layer" "make" "dov" "c" 3 "" "")
) ;_ end of if
   (setq mtx (dov:MTEXT *SYM* 
          '(0. 0. 0.)
          (* 15. (/ (getvar "viewsize") (cadr (getvar "screensize"))))
          ))
     
   (cond ((= (caddr *dcl_gt*) "1")
          (setq        ld  (qleader p  (hp:pointer p 2 mtx) *SYM* txh "COMPLEX" nil)
                blk "ACW" arc t ; R1.2
                ) ;_ end of setq
          )
         ((= (caddr *dcl_gt*) "2")
          (setq        ld  (qleader p (hp:pointer p 2 mtx) *SYM* txh "COMPLEX" nil) 
                blk "CW"  arc nil ;R1.2
                ) ;_ end of setq
          )
         ((= (caddr *dcl_gt*) "0")
          (progn
            (qleader p (hp:pointer p 2 mtx) *SYM* txh "COMPLEX" nil)
                   (setq arc "" pt (getpoint "\nInsert label.."))
                 ) ;_ end of progn
          )
         (t nil);R1.2
         ) ;_ end of cond
     (if mtx (vla-delete (vlax-ename->vla-object mtx)))
     
   (if
     (and blk (setq pt (getpoint "\nInsert label.."))
            (setq bp (findfile (strcat blk ".dwg"))))
     
     (vl-cmdf "_INSERT"
              bp
              pt ; R1.1
              txh
              txh
              0
              *SYM*
              (strcat "%%O" *VSC*)
              ) ;_ end of vl-cmdf
     
(progn (setq pt (trans pt 1 0))
 
      (dov:MTEXT
 (if (= arc "")
 (strcat *SYM* " Rotation\\P\\O" *VSC*)(strcat *SYM* "\\P\\O" *VSC*))
 
          (polar pt (atan (apply '/ (cdr (reverse (getvar "ucsxdir"))))) (* txh 4.))
          txh
          ) ;_ end of dov:MTEXT
 
      (dov:arc pt txh arc)
      ) ;_ end of progn
     ) ;_ end of if
   ) ;_ end of progn
   (if        (= dd 1)
     (unload_dialog dcl_id)
     ) ;_ end of if
   ) ;_ end of if
 
 (setq *dov:run-once* nil)
 (princ)
 ) ;_ end of defun
;; Arc to Bulge  -  Lee Mac
;; c     - center
;; a1,a2 - start, end angle
;; r     - radius
;; Returns: (<vertex> <bulge> <vertex>)
(defun LM:Arc->Bulge ( c a1 a2 r )
   (list
       (polar c a1 r)
       (   (lambda ( a ) (/ (sin a) (cos a)))
           (/ (rem (+ pi pi (- a2 a1)) (+ pi pi)) 4.0)
       )
       (polar c a2 r)
   )
)
; by mjtd's lisper
(defun sk_mk_arc01 (pt r ang1 ang2 l_lay l_col l_lt l_lts l_lw )
 (if(and pt r ang1 ang2)
   (entmakex (list '(0 . "ARC")
                   (cons 8 (if l_lay l_lay (getvar 'clayer)))
                   (if l_col (cons 62 l_col)(cons 62 256))
                   (if l_lt (cons 6 l_lt)(cons 6 "bylayer"))
                   (cons 48 (if l_lts l_lts (getvar 'celtscale)))
                   (if l_lw (cons 370 l_lw)(cons 370 0))
                   (cons 10 pt)
                   (cons 40 r)
                   (cons 50 ang1)
                   (cons 51 ang2)
                   )
                 )
   )
 )
; sub-function refer to #15 credit to mjtd's lisper
(defun dov:arc ( pt r ccw? /  l obj ap bp p1 p2 p3 ang1 ang2 bulge )
(if (and pt (not (= ccw? "")))
   (progn (setq l (* 0.5 r))
   (setq obj (vlax-ename->vla-object (sk_mk_arc01 pt r 0 pi nil nil nil nil nil)))
(setq ap    '("StartPoint" "EndPoint")
     bp    (mapcar ''((a b) (set (eval 'a) (vlax-get obj b)))
            '(p1 p3)
            (if        ccw?
              ap
              (reverse ap)
              ) ;_ end of if
            ) ;_ end of mapcar
     
     p2    (vlax-curve-getPointAtDist
      obj
      (if ccw?
        (- (vla-get-arclength obj) l)
        l
        ) ;_ end of if
      ) ;_ end of vlax-curve-getPointAtDist
     ang1  (angle pt p2)
     ang2  (if        ccw?
      0
      pi
      ) ;_ end of if
     
     bulge (cadr (LM:Arc->Bulge
            pt
            (if        ccw?
              ang2
              ang1
              ) ;_ end of if
            (if        ccw?
              ang1
              ang2
              ) ;_ end of if
            r
            ) ;_ end of LM:Arc->Bulge
          ) ;_ end of cadr
     ) ;_ end of setq
     
   (vla-delete obj)
   (entmakex (list '(0 . "LWPOLYLINE")
                   '(100 . "AcDbEntity")
                   '(100 . "AcDbPolyline")
                   (cons 90 3)
                   (cons 10 p1)
                   (cons 42
                         (if ccw?
                           bulge
                           (* -1.0 bulge)
                           ) ;_ end of if
                         ) ;_ end of cons
                   (cons 10 p2)
                   (cons 40  (/ l 3.0))
                   (cons 41 0)
                   (cons 10 p3)
                   ) ;_ end of list
             ) ;_ end of entmakex
   ) ;_ end of progn
   ) ;_ end of if
 (princ)
 ) ;_ end of defun
http://www.theswamp.org/index.php?topic=12813.225
;R1.1: add object
(defun hp:pointer (_pt c obj / p tp l ip vs) ; v1.1
(if obj (setq obj(vlax-ename->vla-object obj)))
 (while (and (= (setq p (car (setq tp (grread t 15 0)))) 5) (setq l (cadr tp)))
   (redraw)
      (grvecs
(apply
 'append
 (mapcar
  ''((x)
     (list
      6
      _pt
      (polar _pt (* pi x)(* 50. (setq vs (/ (getvar "viewsize") (cadr (getvar "screensize"))))))
      )
     )
  '(0.0 0.5 1.0 1.5)
  ) ;_ end of mapcar
 ) ;_ end of apply
) ;_ end of grvecs
 (setq        ip  (osnap l "_nea")
ip  (if        ip
      ip
      l
      ) ;_ end of if
a   (angle _pt ip)
sz  (* 50. vs)
ang (/ pi 6.37)
d   (* sz 0.25)
ep  (polar ip (+ a pi) 0. );(* sz 0.5)
) ;_ end of setq
  (grvecs
    (apply 'append
    (mapcar ''((x) (list c ep x))
            (list (polar ip a sz ) (polar ep (+ a ang) d) (polar ep (- a ang) d))
            ) ;_ end of mapcar
    ) ;_ end of apply
    ) ;_ end of grvecs
   
 (if obj 
 (vlax-put obj "InsertionPoint" (trans(polar _pt (angle _pt ip) (+(distance _pt ip) 0.2 sz))1 0)))
   ) ;_ end of while
 
;;;  (redraw)
 ip
 ) ;_ end of defun
http://www.cadtutor.net/forum/member.php?117971-hanhphuc
(princ "\nhanhphuc 2014. Label Direction of View. Command: DOV")
(grtext -1 "DOV.lsp© v1.2 hanhphuc")
(princ)