วันจันทร์ที่ 1 พฤศจิกายน พ.ศ. 2564

Closed Boundary Selection

 

;| 

    closed boundary in the  selection                                            

|;

(defun my_error (msg)

(setvar "cmdecho" old_cmdecho)

(if

  (or

    (= msg "Function cancelled")

    (= msg "quit / exit abort")

  )

 (princ)

 (princ (strcat "\nError: " msg))

)

(if msg (Alert (strcat "\nApplication error: " msg)))

      (setvar "cmdecho" old_cmdecho)

      (setvar "osmode" old_osnap)

      (setvar "snapmode" old_snap)

      (setvar "orthomode" old_ortho)

      (setvar "dimdec" old_dimdec)

      (setq *error* old_error)

       

(princ)

);;end my_error

 

(defun c:cbs (/ clayer pa pb dis ay by th th0 lp rp inter1 inter1mid inter2 inter2mid i len plboundary)

(setq old_cmdecho(getvar "cmdecho"))

(setq old_osnap  (getvar "osmode"))

(setq old_layer  (getvar "clayer")) ; layer

(setq old_error   *error*)

(setq *error* my_error )

 

(setvar "cmdecho" 0)

(setvar "osmode" 0)

 

      (command "_undo" "_be")

      (setq old_layer (getvar "clayer"))

      (if (not (tblsearch "LAYER" "mybound"))

            (command "._layer" "_M" "mybound" "_Color" "3" "" "LType" "Continuous" "" "")

      )

      (setq pa (getpoint "\n Pick the left up point"))

      (setq pb (getcorner pa "\n Pick the bottom right point"))

      (setq dis (getdist "\n Enter minimum distance"))

 

      (setq ay (nth 1 pa)

          by (nth 1 pb)

      )

      (setq th by)

      (setq th0 dis)

(while (< th ay)

    (setq lp (list (nth 0 pa) th 0))

    (setq rp (list (nth 0 pb) th 0))

    (grdraw lp rp 249)

    (setq inter1 (vl-Get-Int-Pt lp rp "mybound" 0))

    (setq inter1mid (midlist inter1))

    (setq inter2 (vl-Get-Int-Pt lp rp "mybound" 1)

          inter2mid (midlista inter2)

    )

      (setvar "clayer" "mybound")

    (setq i 0

          len (length inter1)

    )

    (repeat (1- len)

            (setq midpoint (nth i inter1mid))   

            (if (not (member1 midpoint inter2mid))

                  (progn

                        (setq plboundary (STD-BPOLY midpoint nil))

                        (if plboundary

                              (setq inter2 (vl-Get-Int-Pt lp rp "bound" 1)

                                      inter2mid (midlista inter2)

                              )

                        )

                  )

            )

            (setq i (1+ i))

    )

    (setvar "clayer" old_layer)

    (setq th (+ th th0))

)

  (command "_undo" "_e"

               "_redraw"

  )

(setvar "cmdecho" old_cmdecho)

(setvar "osmode" old_osnap)

(setvar "clayer" old_layer)

(setq *error* old_error)

(princ)

)

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

(prompt "\n Enter CBS to Start closed boundary in the selection.")

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

(defun member1 (a b / res)

  (if b

    (foreach x b

      (if (< (distance x a) 0.01)

        (progn

          (setq res T)

        )                      ; (setq res nil)

      )

    )                          ; (setq res nil)

  )

  res

)

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

(defun midlist (lst / len lst1 midpoint i)

  (setq i 0

        len (length lst)

  )

  (repeat (1- len)

    (setq midpoint (midp (nth i lst) (nth (1+ i) lst)))

    (setq lst1 (append

                 lst1

                 (list midpoint)

               )

    )

    (setq i (1+ i))

  )

  lst1

)

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

(defun midlista (lst / len lst1 midpoint i)

  (setq i 0

        len (length lst)

  )

  (repeat (/ len 2)

    (setq midpoint (midp (nth i lst) (nth (1+ i) lst)))

    (setq lst1 (append

                 lst1

                 (list midpoint)

               )

    )

    (setq i (+ i 2))

  )

  lst1

)

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

(defun STD-BPOLY (pt ss / ele)

  (cond

    ((member (type C:BPOLY) '(SUBR EXRXSUBR EXSUBR))

      (if ss

        (C:BPOLY pt ss)               ; old arx or ads function

        (C:BPOLY pt)

      )

    )

    (pt                              ; >=r14: native command

        (setvar "CMDDIA" 0)

        (setq ele (entlast))          ; (std-break-command)

        (command "_BPOLY" "_A" "_I" "_N" "") ; advanced options

                               ; without island detection

        (if ss

          (command "_B" "_N" ss "")

        )                      ; define boundary set if ss

        (command "" pt "") (setvar "CMDDIA" 1)

        (if (/= (entlast) ele)

          (entlast)

        )

    )                          ; return created BPOLY

    (T

      (alert "command _BPOLY not available")

    )

  )

)

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

(defun vl-Get-Int-Pt (FirstPoint SecondPoint lay layindex / acadDocument

                                 mSpace SSetName SSets SSet reapp ex obj

                                 Baseline

                     )

  (vl-load-com)

  (setq acadDocument (vla-get-ActiveDocument (vlax-get-acad-object)))

  (setq mSpace (vla-get-ModelSpace acadDocument))

  (setq SSetName "MySSet")

  (setq SSets (vla-get-SelectionSets acadDocument))

  (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list SSets

                                                               SSetName

                                                         )

                            )

      )

    (vla-clear (vla-Item SSets SSetName))

  )

  (setq SSet (vla-Item SSets SSetName))

  (setq Baseline (vla-Addline mspace (vlax-3d-point FirstPoint)

                              (vlax-3d-point SecondPoint)

                 )

  )

  (vla-SelectByPolygon SSet acSelectionSetFence

                       (kht:list->safearray (append

                                              FirstPoint

                                              SecondPoint

                                            ) 'vlax-vbdouble

                       )

  )

  (vlax-for obj sset (if (setq ex (kht-intersect

                                                 (vlax-vla-object->ename BaseLine)

                                                 (vlax-vla-object->ename obj)

                                                 lay layindex

                                  )

                         )

                       (setq reapp (append

                                     reapp

                                     ex

                                   )

                       )

                     )

  )

  (vla-delete BaseLine)

  (setq reapp (vl-sort reapp '(lambda (e1 e2)

                                (< (car e1) (car e2))

                              )

              )

  )

  reapp

)

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

(defun kht-intersect (en1 en2 lay layindex / a b x ex ex-app c d e la2)

  (vl-load-com)

  (setq c (cdr (assoc 0 (entget en1)))

        d (cdr (assoc 0 (entget en2)))

        la2 (cdr (assoc 8 (entget en2)))

  )

  (if (or

        (= c "TEXT")

        (= d "TEXT")

        (= c "SPLINE")

        (= d "SPLINE")

      )

    (setq e -1)

  )

  (if (= layindex 0)

    (if (= la2 lay)

      (setq e -1)

    )

  )

  (if (= layindex 1)

    (if (/= la2 lay)

      (setq e -1)

    )

  )

  (setq En1 (vlax-ename->vla-object En1))

  (setq En2 (vlax-ename->vla-object En2))

  (setq a (vla-intersectwith en1 en2 acExtendNone))

  (setq a (vlax-variant-value a))

  (setq b (vlax-safearray-get-u-bound a 1))

  (if (= e -1)

    (setq b e)

  )

  (if (/= b -1)

    (progn

      (exapp a)

    )

    nil

  )

)

 

(defun exapp (a)

  (setq a (vlax-safearray->list a))

  (repeat (/ (length a) 3)

    (setq ex-app (append

                   ex-app

                   (list (list (car a) (cadr a) (caddr a)))

                 )

    )

    (setq a (cdr (cdr (cdr a))))

  )

  ex-app

)

(defun kht:list->safearray (lst datatype)

  (vlax-safearray-fill (vlax-make-safearray (eval datatype) (cons 0

                                                                  (1-

                                                                      (length lst)

                                                                  )

                                                            )

                       ) lst

  )

)

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

;;; |           midpoint function                            |

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

(defun midp (p1 p2)

  (mapcar

    '(lambda (x)

       (/ x 2.)

     )

    (mapcar

      '+

      p1

      p2

    )

  )

)


ไม่มีความคิดเห็น:

แสดงความคิดเห็น