[编程交流] 舱口2组

;;----------------------=={ Inside-p }==----------------------;;
;;                                                            ;;
;;  Predicate function to determine whether a point lies      ;;
;;  inside a supplied LWPolyline.                             ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac - www.lee-mac.com                         ;;
;;  Using some code by gile (as marked below), thanks gile.   ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  pt  - 3D WCS point to test                                ;;
;;  ent - LWPolyline Entity against which to test point       ;;
;;------------------------------------------------------------;;
;;  Returns:  T if supplied point lies inside supplied LWPoly ;;
;;------------------------------------------------------------;;
(defun LM:Inside-p (pt ent / _GroupByNum lst nrm obj tmp)
 (defun _GroupByNum (l n / r)
   (if        l
     (cons
(reverse (repeat n
           (setq r (cons (car l) r)
                 l (cdr l)
           )
           r
         )
)
(_GroupByNum l n)
     )
   )
 )
 (if (= (type ent) 'VLA-OBJECT)
   (setq obj ent
  ent (vlax-vla-object->ename ent)
   )
   (setq obj (vlax-ename->vla-object ent))
 )
 (setq        lst
 (_GroupByNum
   (vlax-invoke
     (setq tmp
            (vlax-ename->vla-object
              (entmakex
                (list
                  (cons 0 "RAY")
                  (cons 100 "AcDbEntity")
                  (cons 100 "AcDbRay")
                  (cons 10 pt)
                  (cons 11 (trans '(1. 0. 0.) ent 0))
                )
              )
            )
     )
     'IntersectWith
     obj
     acextendnone
   )
   3
 )
 )
 (vla-delete tmp)
 (setq nrm (cdr (assoc 210 (entget ent))))
 ;; gile:
 (and
   lst
   (not (vlax-curve-getparamatpoint ent pt))
   (=
     1
     (rem
(length
  (vl-remove-if
    (function
      (lambda (p / pa p- p+ p0 s1 s2)
        (setq pa (vlax-curve-getparamatpoint ent p))
        (or
          (and (equal (fix (+ pa
                              (if (minusp pa)
                                -0.5
                                0.5
                              )
                           )
                      )
                      pa
                      1e-8
               )
               (setq p-
                      (cond
                        ((setq p- (vlax-curve-getPointatParam
                                    ent
                                    (- pa 1e-
                                  )
                         )
                         (trans p- 0 nrm)
                        )
                        ((trans        (vlax-curve-getPointatParam
                                  ent
                                  (- (vlax-curve-getEndParam ent) 1e-
                                )
                                0
                                nrm
                         )
                        )
                      )
               )
               (setq p+
                      (cond
                        ((setq p+ (vlax-curve-getPointatParam
                                    ent
                                    (+ pa 1e-
                                  )
                         )
                         (trans p+ 0 nrm)
                        )
                        ((trans        (vlax-curve-getPointatParam
                                  ent
                                  (+ (vlax-curve-getStartParam ent) 1e-
                                )
                                0
                                nrm
                         )
                        )
                      )
               )
               (setq p0 (trans pt 0 nrm))
               (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+))))
               ;; LM Mod
          )
          (and
            (/= 0. (vla-getBulge obj (fix pa)))
            (equal
              '(0. 0.)
              (cdr
                (trans (vlax-curve-getFirstDeriv ent pa) 0 nrm)
              )
              1e-9
            )
          )
        )
      )
    )
    lst
  )
)
2
     )
   )
 )
)
(defun c:hatch2group (/ ss i lst pt ent drehwink pt1 as OBJ AWS mypick)
 (setq mypick (getvar "pickstyle"))
 (setvar "pickstyle" 0)
 (setq OBJ (entlast))
 (command "_ADDSELECTED"
   Pause
   (setq pt1 (getpoint "\nPick Point: "))
 )
 (while (/= (getvar "CMDACTIVE") 0) (command pause))
 (setq AWS (ssadd))
 (while (setq OBJ (entnext OBJ)) (ssadd OBJ AWS))
 (sssetfirst AWS AWS)
 (setq as (entlast))
 (if
   (and (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
 (repeat (setq i (sslength ss))
   (setq lst (cons (ssname ss (setq i (1- i))) lst))
 )
 (setq pt pt1)
   )
    ;(if
      (setq ent
      (car
        (vl-member-if
          (function
            (lambda (x) (LM:Inside-p (trans pt 1 0) x))
          )
          lst
        )
      )
      )
;(vla-put-color (vlax-ename->vla-object ent) acRed)
    
 )
 (princ)
 (command "_groupedit" ent "H" AWS "")
 (while (/= (getvar "CMDACTIVE") 0) (command pause))
 (setvar "pickstyle" mypick)
 (princ)
)
(princ)