nkmjg 发表于 2024-2-21 15:49:50

三点画矩形3-Point Rectangle

(defun c:3prnil (3p-rec nil)) ;; Standard version
(defun c:3prd nil (3p-rect )) ;; Dynamic version

;;----------------------------------------------------------------------;;

(defun 3p-rec ( dyn / *error* gr1 gr2 len lst msg ocs osf osm pt1 pt2 pt3 pt4 pt5 pt6 str tmp vec )

    (defun *error* ( msg )
      (LM:endundo (LM:acdoc))
      (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
      )
      (redraw) (princ)
    )
   
    (if
      (and
            (setq pt1 (getpoint "\nSpecify 1st point: "))
            (setq pt2 (getpoint "\nSpecify 2nd point: " pt1))
            (or   dyn (setq pt3 (getpoint "\nSpecify 3rd point: " pt1)))
            (setq vec (trans (mapcar '- pt2 pt1) 1 0 t)
                  ocs (trans '(0.0 0.0 1.0) 1 0 t)
                  pt4 (trans pt1 1 vec)
                  pt5 (trans pt2 1 vec)
            )
            (if dyn
                (progn
                  (setq osf (LM:grsnap:snapfunction)
                        osm (getvar 'osmode)
                        msg "\nSpecify 3rd point: "
                        str ""
                  )
                  (princ msg)
                  (while
                        (progn
                            (setq gr1 (grread t 15 0)
                                  gr2 (cadr gr1)
                                  gr1 (cargr1)
                            )
                            (cond
                              (   (or (= 5 gr1) (= 3 gr1))
                                    (redraw)
                                    (osf gr2 osm)
                                    (setq pt6 (trans gr2 1 vec))
                                    (mapcar '(lambda ( a b ) (grdraw a b 1 1))
                                        (setq lst
                                          (list pt1 pt2
                                                (trans (list (car pt6) (cadr pt6) (caddr pt5)) vec 1)
                                                (trans (list (car pt6) (cadr pt6) (caddr pt4)) vec 1)
                                          )
                                        )
                                        (cons (last lst) lst)
                                    )
                                    (= 5 gr1)
                              )
                              (   (= 2 gr1)
                                    (cond
                                        (   (= 6 gr2)
                                          (if (zerop (logand 16384 (setq osm (setvar 'osmode (boole 6 16384 (getvar 'osmode))))))
                                                (princ "\n<Osnap on>")
                                                (princ "\n<Osnap off>")
                                          )
                                          (princ msg)
                                        )
                                        (   (= 8 gr2)
                                          (if (< 0 (strlen str))
                                                (progn
                                                    (princ "\010\040\010")
                                                    (setq str (substr str 1 (1- (strlen str))))
                                                )
                                          )
                                          t
                                        )
                                        (   (< 32 gr2 127)
                                          (setq str (strcat str (princ (chr gr2))))
                                        )
                                        (   (member gr2 '(13 32))
                                          (cond
                                                (   (= "" str) nil)
                                                (   (setq gr2 (LM:grsnap:parsepoint pt1 str))
                                                    (setq osm 16384)
                                                    nil
                                                )
                                                (   (setq tmp (LM:grsnap:snapmode str))
                                                    (setq osm tmp
                                                          str ""
                                                    )
                                                )
                                                (   (and pt6
                                                      (setq len (distof str))
                                                      (setq pt6 (list (car pt6) (cadr pt6) (caddr pt4)))
                                                      (not (equal 0.0 (setq tmp (distance pt4 pt6)) 1e-8))
                                                    )
                                                    (setq gr2 (trans (mapcar '(lambda ( a b ) (+ b (* len (/ (- a b) tmp)))) pt6 pt4) vec 1)
                                                          osm 16384
                                                    )
                                                    nil
                                                )
                                                (   (setq str "")
                                                    (princ (strcat "\n2D / 3D Point Required." msg))
                                                )
                                          )
                                        )
                                    )
                              )
                            )
                        )
                  )
                  (if (listp gr2)
                        (setq pt6 (trans (osf gr2 osm) 1 vec))
                  )
                )
                (setq pt6 (trans pt3 1 vec))
            )
      )
      (progn
            (LM:startundo (LM:acdoc))
            (entmake
                (list
                   '(000 . "LWPOLYLINE")
                   '(100 . "AcDbEntity")
                   '(100 . "AcDbPolyline")
                   '(090 . 4)
                   '(070 . 1)
                  (cons 038 (caddr (trans pt1 1 ocs)))
                  (cons 010 (trans pt1 1 ocs))
                  (cons 010 (trans pt2 1 ocs))
                  (cons 010 (trans (list (car pt6) (cadr pt6) (caddr pt5)) vec ocs))
                  (cons 010 (trans (list (car pt6) (cadr pt6) (caddr pt4)) vec ocs))
                  (cons 210 ocs)
                )
            )
            (LM:endundo (LM:acdoc))
      )
    )
    (redraw) (princ)
)

nkmjg 发表于 2024-2-21 15:51:39

;; Object Snap for grread: Snap Function-Lee Mac
;; Returns: A function requiring two arguments:
;; p - UCS Point to be snapped
;; o - Object Snap bit code
;; The returned function returns either the snapped point (displaying an appropriate snap symbol)
;; or the supplied point if the snap failed for the given Object Snap bit code.

(defun LM:grsnap:snapfunction ( )
    (eval
      (list 'lambda '( p o / q )
            (list 'if '(zerop (logand 16384 o))
                (list 'if
                   '(setq q
                        (cdar
                            (vl-sort
                              (vl-remove-if 'null
                                    (mapcar
                                        (function
                                          (lambda ( a / b )
                                                (if (and (= (car a) (logand (car a) o)) (setq b (osnap p (cdr a))))
                                                    (list (distance p b) b (car a))
                                                )
                                          )
                                        )
                                       '(
                                          (0001 . "采用end")
                                          (0002 . "采用mid")
                                          (0004 . "采用cen")
                                          (0008 . "采用nod")
                                          (0016 . "采用qua")
                                          (0032 . "采用int")
                                          (0064 . "采用ins")
                                          (0128 . "采用per")
                                          (0256 . "采用tan")
                                          (0512 . "采用nea")
                                          (2048 . "采用app")
                                          (8192 . "采用par")
                                        )
                                    )
                              )
                               '(lambda ( a b ) (< (car a) (car b)))
                            )
                        )
                  )
                  (list 'LM:grsnap:displaysnap '(car q)
                        (list 'cdr
                            (list 'assoc '(cadr q)
                              (list 'quote
                                    (LM:grsnap:snapsymbols
                                        (atoi (cond ((getenv "AutoSnapSize")) ("5")))
                                    )
                              )
                            )
                        )
                        (LM:OLE->ACI
                            (if (= 1 (getvar 'cvport))
                              (atoi (cond ((getenv "Layout AutoSnap Color")) ("117761")))
                              (atoi (cond ((getenv"Model AutoSnap Color")) ("104193")))
                            )
                        )
                  )
                )
            )
         '(cond ((car q)) (p))
      )
    )
)

;; Object Snap for grread: Display Snap-Lee Mac
;; pnt - UCS point at which to display the symbol
;; lst - grvecs vector list
;; col - ACI colour for displayed symbol
;; Returns nil

(defun LM:grsnap:displaysnap ( pnt lst col / scl )
    (setq scl (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
          pnt (trans pnt 1 2)
    )
    (grvecs (cons col lst)
      (list
            (list scl 0.0 0.0 (carpnt))
            (list 0.0 scl 0.0 (cadr pnt))
            (list 0.0 0.0 scl 0.0)
         '(0.0 0.0 0.0 1.0)
      )
    )
)

;; Object Snap for grread: Snap Symbols-Lee Mac
;; p - Size of snap symbol in pixels
;; Returns: List of vector lists describing each Object Snap symbol

(defun LM:grsnap:snapsymbols ( p / -p -q -r a c i l q r )
    (setq -p (- p) q (1+p)
          -q (- q) r (+ 2 p)
          -r (- r) i (/ pi 6.0)
         a 0.0
    )
    (repeat 12
      (setq l (cons (list (* r (cos a)) (* r (sin a))) l)
            a (- a i)
      )
    )
    (setq c (apply 'append (mapcar 'list (cons (last l) l) l)))
    (list
      (list 1
            (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
      )
      (list 2
            (list -r -q) (list 0r) (list 0r) (list r -q)
            (list -p -p) (list p -p) (list p -p) (list 0p) (list 0p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list 0q) (list 0q) (list -q -q)
      )
      (cons 4 c)
      (vl-list* 8 (list -r -r) (list r r) (list r -r) (list -r r) c)
      (list 16
            (list p 0) (list 0 p) (list 0 p) (list -p 0) (list -p 0) (list 0 -p) (list 0 -p) (list p 0)
            (list q 0) (list 0 q) (list 0 q) (list -q 0) (list -q 0) (list 0 -q) (list 0 -q) (list q 0)
            (list r 0) (list 0 r) (list 0 r) (list -r 0) (list -r 0) (list 0 -r) (list 0 -r) (list r 0)
      )
      (list 32
            (listr r) (list -r -r) (listr q) (list -q -r) (listq r) (list -r -q)
            (list -r r) (listr -r) (list -q r) (listr -q) (list -r q) (listq -r)
      )
      (list 64
            '( 01) (list0p) (list0p) (list -pp) (list -pp) (list -p -1) (list -p -1) '( 0 -1)
            '( 0 -1) (list0 -p) (list0 -p) (listp -p) (listp -p) (listp1) (listp1) '( 01)
            '( 12) (list1q) (list1q) (list -qq) (list -qq) (list -q -2) (list -q -2) '(-1 -2)
            '(-1 -2) (list -1 -q) (list -1 -q) (listq -q) (listq -q) (listq2) (listq2) '( 12)
      )
      (list 128
            (list (1+ -p) 0) '(0 0) '(0 0) (list 0 (1+ -p))
            (list (1+ -p) 1) '(1 1) '(1 1) (list 1 (1+ -p))
            (list -p q) (list -p -p) (list -p -p) (list q -p)
            (list -q q) (list -q -q) (list -q -q) (list q -q)
      )
      (vl-list* 256 (list -r r)(list r r) (list -r (1+ r)) (list r (1+ r)) c)
      (list 512
            (list -p -p) (listp -p) (list -pp) (list p p) (list -q -q) (listq -q)
            (listq -q) (list -qq) (list -qq) (list q q) (listqq) (list -q -q)
      )
      (list 2048
            (list   -p   -p) (list    p      p) (list   -p      p) (list    p   -p)
            (list (+ p 05) -p) (list (+ p 06) -p) (list (+ p 05) -q) (list (+ p 06) -q)
            (list (+ p 09) -p) (list (+ p 10) -p) (list (+ p 09) -q) (list (+ p 10) -q)
            (list (+ p 13) -p) (list (+ p 14) -p) (list (+ p 13) -q) (list (+ p 14) -q)
            (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
      )
      (list 8192 (list r 1) (list -r -q) (list r 0) (list -r -r) (list r q) (list -r -1) (list r r) (list -r 0))
    )
)

(defun LM:grsnap:parsepoint ( bpt str / str->lst lst )

    (defun str->lst ( str / pos )
      (if (setq pos (vl-string-position 44 str))
            (cons (substr str 1 pos) (str->lst (substr str (+ pos 2))))
            (list str)
      )
    )

    (if (wcmatch str "`@*")
      (setq str (substr str 2))
      (setq bpt '(0.0 0.0 0.0))
    )         

    (if
      (and
            (setq lst (mapcar 'distof (str->lst str)))
            (vl-every 'numberp lst)
            (< 1 (length lst) 4)
      )
      (mapcar '+ bpt lst)
    )
)


(defun LM:grsnap:snapmode ( str )
    (vl-some
      (function
            (lambda ( x )
                (if (wcmatch (car x) (strcat (strcase str t) "*"))
                  (progn
                        (princ (cadr x)) (caddr x)
                  )
                )
            )
      )
       '(
            ("endpoint"      " of " 00001)
            ("midpoint"      " of " 00002)
            ("center"      " of " 00004)
            ("node"          " of " 00008)
            ("quadrant"      " of " 00016)
            ("intersection"" of " 00032)
            ("insert"      " of " 00064)
            ("perpendicular" " to " 00128)
            ("tangent"       " to " 00256)
            ("nearest"       " to " 00512)
            ("appint"      " of " 02048)
            ("parallel"      " to " 08192)
            ("none"          ""   16384)
      )
    )
)


(defun LM:OLE->ACI ( c )
    (apply 'LM:RGB->ACI (LM:OLE->RGB c))
)

(defun LM:OLE->RGB ( c )
    (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)

(defun LM:RGB->ACI ( r g b / c o )
    (if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
      (progn
            (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
            (vlax-release-object o)
            (if (vl-catch-all-error-p c)
                (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                c
            )
      )
    )
)
(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)


(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
      (vla-endundomark doc)
    )
)

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)

(defun LM:acapp nil
    (eval (list 'defun 'LM:acapp 'nil (vlax-get-acad-object)))
    (LM:acapp)
)
(vl-load-com)
页: [1]
查看完整版本: 三点画矩形3-Point Rectangle