_

[Lisp] Podział zamkniętych polilinii

Forum poświęcone flagowemu produktowi oraz aplikacjom pochodnym Autodesku. To jedyne forum mające w tytule nazwę programu, a to ze względu na jego olbrzymią popularność w Polsce. Można tutaj umieszczać również posty z ogólnie pojętej tematyki "Kreślarskie 2D".

Re: [Lisp] Podział zamkniętych polilinii

Postprzez ziele_o2k » mar 14, 2017 22:31

EDIT:
ignorować lispa, jak potestowałem to się sypie. Pomysł mam, ale trza się mocno wgryźć w kod break_obj, a na to czasu brak


taka moja* wariacja :)

example.gif

Kod: Zaznacz cały
(defun c:test1 ( / LM:SelectIf LM:intersections obj_1 p1 p2 obj_2 intlst)
  (defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred)) 
    (while
      (progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg))
        (cond
          ( (= 7 (getvar 'ERRNO))
            (princ "\nMissed, Try again.")
          )
          ( (eq 'STR (type sel))
            nil
          )
          ( (vl-consp sel)
            (if (and pred (not (pred sel)))
              (princ "\nInvalid Object Selected.")
            )
          )
        )
      )
    )
    sel
  )
  (defun LM:intersections ( ob1 ob2 mod / lst rtn )
    (if (and (vlax-method-applicable-p ob1 'intersectwith)
             (vlax-method-applicable-p ob2 'intersectwith)
             (setq lst (vlax-invoke ob1 'intersectwith ob2 mod))
        )
        (repeat (/ (length lst) 3)
            (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn)
                  lst (cdddr lst)
            )
        )
    )
    (reverse rtn)
  )
  (if
    (and
      (setq obj_1 (vlax-ename->vla-object (car
        (LM:SelectIf
          "\nWskaż polilinię"
          (lambda ( x )
            (and
              (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))
              (eq (vla-get-closed (vlax-ename->vla-object(car x) )) :vlax-true)
     
            )
          )
          entsel
          nil
        )
      )))
      (setq p1 (getpoint "\nWskaż pierwszy punkt cięcia: "))
      (setq p2 (getpoint p1 "\nWskaż drugi punkt cięcia: "))
    )
    (progn
      (setq obj_2 (cd:ACX_AddLine (cd:ACX_ASpace) p1 p2 T))
      (setq intlst (LM:intersections obj_1 obj_2 acextendnone))
      (vla-Delete obj_2)
      (if (and intlst (> (length intlst) 1))
        (break_obj (vlax-vla-object->ename obj_1) intlst 0)
      )
    )
  )
)

(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
                  minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
                  brkptE brkpt result GapFlg result ignore dist tmppt
                  #ofpts 2gap enddist lastent obj2break stdist
                 
                  GetLastEnt
                 )
  (defun GetLastEnt ( / ename result )
    (if (setq result (entlast))
      (while (setq ename (entnext result))
        (setq result ename)
      )
    )
    result
  )
  (or BrkGap (setq BrkGap 0.0)) ; default to 0
  (setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point
 
  (setq obj2break ent
        brkobjlst (list ent)
        enttype   (cdr (assoc 0 (entget ent)))
        GapFlg    (not (zerop BrkGap)) ; gap > 0
        closedobj (vlax-curve-isclosed obj2break)
  )
  ;; when zero gap no need to break at end points, not closed
  (if (and (zerop Brkgap)(not closedobj)) ; Revision 2.2
    (setq spt (vlax-curve-getstartpoint ent)
          ept (vlax-curve-getendpoint ent)
          brkptlst (vl-remove-if '(lambda(x) (or (< (distance x spt) 0.0001)
                                                 (< (distance x ept) 0.0001)))
                                 brkptlst)
    )
  )
  (if brkptlst
    (progn
  ;;  sort break points based on the distance along the break object
  ;;  get distance to break point, catch error if pt is off end
  ;; ver 2.0 fix - added COND to fix break point is at the end of a
  ;; line which is not a valid break but does no harm
  (setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
                                               ;; ver 2.0 fix
                                               (cond ((vlax-curve-getparamatpoint obj2break x))
                                                   ((vlax-curve-getparamatpoint obj2break
                                                     (vlax-curve-getclosestpointto obj2break x))))))
                            ) brkptlst))
  ;; sort primary list on distance
  (setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))
 
  (if GapFlg ; gap > 0
    ;; Brkptlst starts as the break point and then a list of pairs of points
    ;;  is creates as the break points
    (progn
      ;;  create a list of list of break points
      ;;  ((idx# stpoint distance)(idx# endpoint distance)...)
      (setq idx 0)
      (foreach brkpt brkptlst
       
        ;; ----------------------------------------------------------
        ;;  create start break point, then create end break point   
        ;;  ((idx# startpoint distance)(idx# endpoint distance)...) 
        ;; ----------------------------------------------------------
        (setq dist (cadr brkpt)) ; distance to center of gap
        ;;  subtract gap to get start point of break gap
        (cond
          ((and (minusp (setq stDist (- dist BrkGap))) closedobj )
           (setq stdist (+ (vlax-curve-getdistatparam obj2break
                             (vlax-curve-getendparam obj2break)) stDist))
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                         (vlax-curve-getparamatdist obj2break stDist))
                                  stDist) dlst))
           )
          ((minusp stDist) ; off start of object so get startpoint
           (setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
           )
          (t
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                         (vlax-curve-getparamatdist obj2break stDist))
                                  stDist) dlst))
          )
        )
        ;;  add gap to get end point of break gap
        (cond
          ((and (> (setq stDist (+ dist BrkGap))
                   (setq endDist (vlax-curve-getdistatparam obj2break
                                     (vlax-curve-getendparam obj2break)))) closedobj )
           (setq stdist (- stDist endDist))
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                         (vlax-curve-getparamatdist obj2break stDist))
                                  stDist) dlst))
           )
          ((> stDist endDist) ; off end of object so get endpoint
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                        (vlax-curve-getendparam obj2break))
                                  endDist) dlst))
           )
          (t
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                         (vlax-curve-getparamatdist obj2break stDist))
                                  stDist) dlst))
          )
        )
        ;; -------------------------------------------------------
        (setq idx (1+ IDX))
      ) ; foreach brkpt brkptlst
     

      (setq dlst (reverse dlst))
      ;;  remove the points of the gap segments that overlap
      (setq idx -1
            2gap (* BrkGap 2)
            #ofPts (length Brkptlst)
      )
      (while (<= (setq idx (1+ idx)) #ofPts)
        (cond
          ((null result) ; 1st time through
           (setq result (list (car dlst)) ; get first start point
                 result (cons (nth (1+(* idx 2)) dlst) result))
          )
          ((= idx #ofPts) ; last pass, check for wrap
           (if (and closedobj (> #ofPts 1)
                    (<= (+(- (vlax-curve-getdistatparam obj2break
                            (vlax-curve-getendparam obj2break))
                          (cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))
             (progn
               (if (zerop (rem (length result) 2))
                 (setq result (cdr result)) ; remove the last end point
               )
               ;;  ignore previous endpoint and present start point
               (setq result (cons (cadr (reverse result)) result) ; get last end point
                     result (cdr (reverse result))
                     result (reverse (cdr result)))
             )
           )
          )
          ;; Break Gap Overlaps
          ((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))
           (if (zerop (rem (length result) 2))
             (setq result (cdr result)) ; remove the last end point
           )
           ;;  ignore previous endpoint and present start point
           (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point
           )
          ;; Break Gap does Not Overlap previous point
          (t
           (setq result (cons (nth (* idx 2) dlst) result)) ; get this start point
           (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point
          )
        ) ; end cond stmt
      ) ; while
     
      ;;  setup brkptlst with pair of break pts ((p1 p2)(p3 p4)...)
      ;;  one of the pair of points will be on the object that
      ;;  needs to be broken
      (setq dlst     (reverse result)
            brkptlst nil)
      (while dlst ; grab the points only
        (setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)
              dlst   (cddr dlst))
      )
    )
  )
  ;;   -----------------------------------------------------

  ;; (if (equal  a ent) (princ)) ; debug CAB  -------------
 
  (foreach brkpt (reverse brkptlst)
    (if GapFlg ; gap > 0
      (setq brkptS (car brkpt)
            brkptE (cadr brkpt))
      (setq brkptS (car brkpt)
            brkptE brkptS)
    )
    ;;  get last entity created via break in case multiple breaks
    (if brkobjlst
      (progn
        (setq tmppt brkptS) ; use only one of the pair of breakpoints
        ;;  if pt not on object x, switch objects
        (if (not (numberp (vl-catch-all-apply
                            'vlax-curve-getdistatpoint (list obj2break tmppt))))
          (progn ; find the one that pt is on
            (setq idx (length brkobjlst))
            (while (and (not (minusp (setq idx (1- idx))))
                        (setq obj (nth idx brkobjlst))
                        (if (numberp (vl-catch-all-apply
                                       'vlax-curve-getdistatpoint (list obj tmppt)))
                          (null (setq obj2break obj)) ; switch objects, null causes exit
                          t
                        )
                   )
            )
          )
        )
      )
    )

    ;; (if (equal (if (null a)(setq a (car(entsel"\nTest Ent"))) a) ent) (princ)) ; debug CAB  -------------

    ;;  Handle any objects that can not be used with the Break Command
    ;;  using one point, gap of 0.000001 is used
    (setq closedobj (vlax-curve-isclosed obj2break))
    (if GapFlg ; gap > 0
      (if closedobj
        (progn ; need to break a closed object
          (setq brkpt2 (vlax-curve-getPointAtDist obj2break
                     (- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
          (command "._break" obj2break "_non" (trans brkpt2 0 1)
                   "_non" (trans brkptE 0 1))
          (and (= "CIRCLE" enttype) (setq enttype "ARC"))
          (setq BrkptE brkpt2)
        )
      )
      ;;  single breakpoint ----------------------------------------------------

      (if (and closedobj
               (not (setq brkptE (vlax-curve-getPointAtDist obj2break
                       (+ (vlax-curve-getdistatparam obj2break
                            ;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
                            ;; ver 2.0 fix
                            (cond ((vlax-curve-getparamatpoint obj2break brkpts))
                                  ((vlax-curve-getparamatpoint obj2break
                                      (vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))))
        (setq brkptE (vlax-curve-getPointAtDist obj2break
                       (- (vlax-curve-getdistatparam obj2break
                            ;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
                            ;; ver 2.0 fix
                            (cond ((vlax-curve-getparamatpoint obj2break brkpts))
                                  ((vlax-curve-getparamatpoint obj2break
                                      (vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
       )
    ) ; endif
   
    ;; (if (null brkptE) (princ)) ; debug
   
    (setq LastEnt (GetLastEnt))
    (command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
    (and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
    (and (= "CIRCLE" enttype) (setq enttype "ARC"))
    (if (and (not closedobj) ; new object was created
             (not (equal LastEnt (entlast))))
        (setq brkobjlst (cons (entlast) brkobjlst))
    )
  )
  )
  ) ; endif brkptlst
 
 
  ;; changes by ziele_o2k below
  (if brkobjlst
    (foreach _1 brkobjlst
      (vla-put-closed (vlax-ename->vla-object _1) :vlax-true)
    )
  )

 
) ; defun break_obj


*) moja - znaczy skleiłem trochę kodu z neta i coś tam śmiga. Różnica taka że przerywa w wielu miejscach.
Od razu mówię, że czasem jak segment polilini nakłada się na prostą tnącą to potrafi się sypnąć.
źródła to:
http://www.lee-mac.com
https://www.theswamp.org/index.php?topic=10370.msg132035#msg132035


Trza cadpacka wczytać

EDIT:
ignorować lispa, jak potestowałem to się sypie. Pomysł mam, ale trza się mocno wgryźć w kod break_obj, a na to czasu brak
Ziele
Avatar użytkownika
ziele_o2k
 
Posty: 395
Dołączył(a): mar 18, 2014 11:33
Lokalizacja: Poznań

Re: [Lisp] Podział zamkniętych polilinii

Postprzez Lukaszs85 » mar 16, 2017 12:02

Dzięki za staranie, widzę że to skomplikowana sprawa i lata świetlne dalej od moich znajomości lispa i programowania.
Lukaszs85
 
Posty: 20
Dołączył(a): lut 24, 2017 00:24

Re: [Lisp] Podział zamkniętych polilinii

Postprzez Lukaszs85 » mar 17, 2017 10:53

ziele_o2k, po kilku próbach program działa w stopniu zupełnie wystarczającym. O to dokładnie chodziło, co prawda gorzej radzi sobie z podziałami przez łuki w polilinii, ale to jest do przełknięcia bo rzadko trzeba robić. Najważniejsze że lwią cześć uciążliwej roboty robi. Dzięki wielkie.
Ostatnio edytowany przez Lukaszs85, mar 17, 2017 13:03, edytowano w sumie 1 raz
Lukaszs85
 
Posty: 20
Dołączył(a): lut 24, 2017 00:24

Re: [Lisp] Podział zamkniętych polilinii

Postprzez ziele_o2k » mar 17, 2017 11:47

Lukaszs85 napisał(a):ziele_o2k, po kilku próbach program działa w stopniu zupełnie wystarczającym. O to dokładnie chodziło, co prawda gorzej radzi sobie z podziałami przez łuki w polilinii, ale to jest do przełknięcia bo rzadko trzeba robić. Najważniejsze że lwią cześć uciążliwej roboty robi. Dziękie wielkie

Teraz powinno być lepiej:
Kod: Zaznacz cały
(defun c:test1 ( / LM:SelectIf LM:intersections obj_1 p1 p2 obj_2 intlst)
  (defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred)) 
    (while
      (progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg))
        (cond
          ( (= 7 (getvar 'ERRNO))
            (princ "\nMissed, Try again.")
          )
          ( (eq 'STR (type sel))
            nil
          )
          ( (vl-consp sel)
            (if (and pred (not (pred sel)))
              (princ "\nInvalid Object Selected.")
            )
          )
        )
      )
    )
    sel
  )
  (defun LM:intersections ( ob1 ob2 mod / lst rtn )
    (if (and (vlax-method-applicable-p ob1 'intersectwith)
             (vlax-method-applicable-p ob2 'intersectwith)
             (setq lst (vlax-invoke ob1 'intersectwith ob2 mod))
        )
        (repeat (/ (length lst) 3)
            (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn)
                  lst (cdddr lst)
            )
        )
    )
    (reverse rtn)
  )
  (if
    (and
      (setq obj_1 (vlax-ename->vla-object (car
        (LM:SelectIf
          "\nWskaż polilinię"
          (lambda ( x )
            (and
              (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))
              (eq (vla-get-closed (vlax-ename->vla-object(car x) )) :vlax-true)
     
            )
          )
          entsel
          nil
        )
      )))
      (setq p1 (getpoint "\nWskaż pierwszy punkt cięcia: "))
      (setq p2 (getpoint p1 "\nWskaż drugi punkt cięcia: "))
    )
    (progn
      (setq obj_2 (cd:ACX_AddLine (cd:ACX_ASpace) p1 p2 T))
      (setq intlst (LM:intersections obj_1 obj_2 acextendnone))
      (vla-Delete obj_2)
      (if (and intlst (> (length intlst) 1))
        (break_obj (vlax-vla-object->ename obj_1) intlst 0)
      )
    )
  )
)

(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
                  minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
                  brkptE brkpt result GapFlg result ignore dist tmppt
                  #ofpts 2gap enddist lastent obj2break stdist
                 
                  GetLastEnt x b
                 )
  (defun GetLastEnt ( / ename result )
    (if (setq result (entlast))
      (while (setq ename (entnext result))
        (setq result ename)
      )
    )
    result
  )
  (or BrkGap (setq BrkGap 0.0)) ; default to 0
  (setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point
 
  (setq obj2break ent
        brkobjlst (list ent)
        enttype   (cdr (assoc 0 (entget ent)))
        GapFlg    (not (zerop BrkGap)) ; gap > 0
        closedobj (vlax-curve-isclosed obj2break)
  )
  ;; when zero gap no need to break at end points, not closed
  (if (and (zerop Brkgap)(not closedobj)) ; Revision 2.2
    (setq spt (vlax-curve-getstartpoint ent)
          ept (vlax-curve-getendpoint ent)
          brkptlst (vl-remove-if '(lambda(x) (or (< (distance x spt) 0.0001)
                                                 (< (distance x ept) 0.0001)))
                                 brkptlst)
    )
  )
  (if brkptlst
    (progn
  ;;  sort break points based on the distance along the break object
  ;;  get distance to break point, catch error if pt is off end
  ;; ver 2.0 fix - added COND to fix break point is at the end of a
  ;; line which is not a valid break but does no harm
  (setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
                                               ;; ver 2.0 fix
                                               (cond ((vlax-curve-getparamatpoint obj2break x))
                                                   ((vlax-curve-getparamatpoint obj2break
                                                     (vlax-curve-getclosestpointto obj2break x))))))
                            ) brkptlst))
  ;; sort primary list on distance
  (setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))
 
  (if GapFlg ; gap > 0
    ;; Brkptlst starts as the break point and then a list of pairs of points
    ;;  is creates as the break points
    (progn
      ;;  create a list of list of break points
      ;;  ((idx# stpoint distance)(idx# endpoint distance)...)
      (setq idx 0)
      (foreach brkpt brkptlst
       
        ;; ----------------------------------------------------------
        ;;  create start break point, then create end break point   
        ;;  ((idx# startpoint distance)(idx# endpoint distance)...) 
        ;; ----------------------------------------------------------
        (setq dist (cadr brkpt)) ; distance to center of gap
        ;;  subtract gap to get start point of break gap
        (cond
          ((and (minusp (setq stDist (- dist BrkGap))) closedobj )
           (setq stdist (+ (vlax-curve-getdistatparam obj2break
                             (vlax-curve-getendparam obj2break)) stDist))
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                         (vlax-curve-getparamatdist obj2break stDist))
                                  stDist) dlst))
           )
          ((minusp stDist) ; off start of object so get startpoint
           (setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
           )
          (t
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                         (vlax-curve-getparamatdist obj2break stDist))
                                  stDist) dlst))
          )
        )
        ;;  add gap to get end point of break gap
        (cond
          ((and (> (setq stDist (+ dist BrkGap))
                   (setq endDist (vlax-curve-getdistatparam obj2break
                                     (vlax-curve-getendparam obj2break)))) closedobj )
           (setq stdist (- stDist endDist))
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                         (vlax-curve-getparamatdist obj2break stDist))
                                  stDist) dlst))
           )
          ((> stDist endDist) ; off end of object so get endpoint
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                        (vlax-curve-getendparam obj2break))
                                  endDist) dlst))
           )
          (t
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                         (vlax-curve-getparamatdist obj2break stDist))
                                  stDist) dlst))
          )
        )
        ;; -------------------------------------------------------
        (setq idx (1+ IDX))
      ) ; foreach brkpt brkptlst
     

      (setq dlst (reverse dlst))
      ;;  remove the points of the gap segments that overlap
      (setq idx -1
            2gap (* BrkGap 2)
            #ofPts (length Brkptlst)
      )
      (while (<= (setq idx (1+ idx)) #ofPts)
        (cond
          ((null result) ; 1st time through
           (setq result (list (car dlst)) ; get first start point
                 result (cons (nth (1+(* idx 2)) dlst) result))
          )
          ((= idx #ofPts) ; last pass, check for wrap
           (if (and closedobj (> #ofPts 1)
                    (<= (+(- (vlax-curve-getdistatparam obj2break
                            (vlax-curve-getendparam obj2break))
                          (cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))
             (progn
               (if (zerop (rem (length result) 2))
                 (setq result (cdr result)) ; remove the last end point
               )
               ;;  ignore previous endpoint and present start point
               (setq result (cons (cadr (reverse result)) result) ; get last end point
                     result (cdr (reverse result))
                     result (reverse (cdr result)))
             )
           )
          )
          ;; Break Gap Overlaps
          ((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))
           (if (zerop (rem (length result) 2))
             (setq result (cdr result)) ; remove the last end point
           )
           ;;  ignore previous endpoint and present start point
           (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point
           )
          ;; Break Gap does Not Overlap previous point
          (t
           (setq result (cons (nth (* idx 2) dlst) result)) ; get this start point
           (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point
          )
        ) ; end cond stmt
      ) ; while
     
      ;;  setup brkptlst with pair of break pts ((p1 p2)(p3 p4)...)
      ;;  one of the pair of points will be on the object that
      ;;  needs to be broken
      (setq dlst     (reverse result)
            brkptlst nil)
      (while dlst ; grab the points only
        (setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)
              dlst   (cddr dlst))
      )
    )
  )
  ;;   -----------------------------------------------------

  ;; (if (equal  a ent) (princ)) ; debug CAB  -------------
 
  (foreach brkpt (reverse brkptlst)
    (if GapFlg ; gap > 0
      (setq brkptS (car brkpt)
            brkptE (cadr brkpt))
      (setq brkptS (car brkpt)
            brkptE brkptS)
    )
    ;;  get last entity created via break in case multiple breaks
    (if brkobjlst
      (progn
        (setq tmppt brkptS) ; use only one of the pair of breakpoints
        ;;  if pt not on object x, switch objects
        (if (not (numberp (vl-catch-all-apply
                            'vlax-curve-getdistatpoint (list obj2break tmppt))))
          (progn ; find the one that pt is on
            (setq idx (length brkobjlst))
            (while (and (not (minusp (setq idx (1- idx))))
                        (setq obj (nth idx brkobjlst))
                        (if (numberp (vl-catch-all-apply
                                       'vlax-curve-getdistatpoint (list obj tmppt)))
                          (null (setq obj2break obj)) ; switch objects, null causes exit
                          t
                        )
                   )
            )
          )
        )
      )
    )

    ;; (if (equal (if (null a)(setq a (car(entsel"\nTest Ent"))) a) ent) (princ)) ; debug CAB  -------------

    ;;  Handle any objects that can not be used with the Break Command
    ;;  using one point, gap of 0.000001 is used
    (setq closedobj (vlax-curve-isclosed obj2break))
    (if GapFlg ; gap > 0
      (if closedobj
        (progn ; need to break a closed object
          (setq brkpt2 (vlax-curve-getPointAtDist obj2break
                     (- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
          (command "._break" obj2break "_non" (trans brkpt2 0 1)
                   "_non" (trans brkptE 0 1))
          (and (= "CIRCLE" enttype) (setq enttype "ARC"))
          (setq BrkptE brkpt2)
        )
      )
      ;;  single breakpoint ----------------------------------------------------

      (if (and closedobj
               (not (setq brkptE (vlax-curve-getPointAtDist obj2break
                       (+ (vlax-curve-getdistatparam obj2break
                            ;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
                            ;; ver 2.0 fix
                            (cond ((vlax-curve-getparamatpoint obj2break brkpts))
                                  ((vlax-curve-getparamatpoint obj2break
                                      (vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))))
        (setq brkptE (vlax-curve-getPointAtDist obj2break
                       (- (vlax-curve-getdistatparam obj2break
                            ;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
                            ;; ver 2.0 fix
                            (cond ((vlax-curve-getparamatpoint obj2break brkpts))
                                  ((vlax-curve-getparamatpoint obj2break
                                      (vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
       )
    ) ; endif
   
    ;; (if (null brkptE) (princ)) ; debug
   
    (setq LastEnt (GetLastEnt))
    (command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
    (and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
    (and (= "CIRCLE" enttype) (setq enttype "ARC"))
    (if (and (not closedobj) ; new object was created
             (not (equal LastEnt (entlast))))
        (setq brkobjlst (cons (entlast) brkobjlst))
    )
  )
  )
  ) ; endif brkptlst
 
 
  ;; changes by ziele_o2k below
  (if brkobjlst
    (foreach _1 brkobjlst
            (setq x (reverse (entget _1))
                  b (assoc 70 x)
            )
            (entmod (reverse (vl-list* (car x) (cadr x) '(42 . 0.0) (subst (cons 70 (logior 1 (cdr b))) b (cdddr x)))))
    )
  )
 
 
 
) ; defun break_obj
Ziele
Avatar użytkownika
ziele_o2k
 
Posty: 395
Dołączył(a): mar 18, 2014 11:33
Lokalizacja: Poznań

Re: [Lisp] Podział zamkniętych polilinii

Postprzez kojacek » mar 17, 2017 15:18

Lukaszs85 napisał(a):ziele_o2k, po kilku próbach program działa w stopniu zupełnie wystarczającym. O to dokładnie chodziło, co prawda gorzej radzi sobie z podziałami przez łuki w polilinii, ale to jest do przełknięcia bo rzadko trzeba robić. Najważniejsze że lwią cześć uciążliwej roboty robi. Dzięki wielkie.


a https://kojacek.wordpress.com/2017/03/14/podzial-zamknietej-polilinii/ testowałeś na łukach :?:
Avatar użytkownika
kojacek
 
Posty: 5224
Dołączył(a): paź 03, 2005 20:17

Re: [Lisp] Podział zamkniętych polilinii

Postprzez Lukaszs85 » mar 18, 2017 20:15

kojacek napisał(a):
Lukaszs85 napisał(a):ziele_o2k, po kilku próbach program działa w stopniu zupełnie wystarczającym. O to dokładnie chodziło, co prawda gorzej radzi sobie z podziałami przez łuki w polilinii, ale to jest do przełknięcia bo rzadko trzeba robić. Najważniejsze że lwią cześć uciążliwej roboty robi. Dzięki wielkie.


a https://kojacek.wordpress.com/2017/03/14/podzial-zamknietej-polilinii/ testowałeś na łukach :?:


Jeszcze nie, ale przetestuje na pewno. Dzięki.
Lukaszs85
 
Posty: 20
Dołączył(a): lut 24, 2017 00:24

Re: [Lisp] Podział zamkniętych polilinii

Postprzez Lukaszs85 » mar 20, 2017 10:37

Kojacek, twój program na Autocadzie 2010 wyrzuca błąd:
Kod: Zaznacz cały
*** Błąd: no function definition: GETPROPERTYVALUE ***

CADPACK mam załadowany, chyba że muszę zaktualizować.

Natomiast program Ziele_o2k działa pierwszorzędnie nawet z podziałem przez dwa łuki jak na rysunku:
Dzięki wielkie za pomoc
Załączniki
podział.jpg
Lukaszs85
 
Posty: 20
Dołączył(a): lut 24, 2017 00:24

Re: [Lisp] Podział zamkniętych polilinii

Postprzez kojacek » mar 20, 2017 11:04

Lukaszs85 napisał(a):Kojacek, twój program na Autocadzie 2010 wyrzuca błąd:
Kod: Zaznacz cały
*** Błąd: no function definition: GETPROPERTYVALUE ***

CADPACK mam załadowany, chyba że muszę zaktualizować.

Natomiast program Ziele_o2k działa pierwszorzędnie nawet z podziałem przez dwa łuki jak na rysunku:
Dzięki wielkie za pomoc


Nie pójdzie: AutoCAD 2010... trochę stary...
Avatar użytkownika
kojacek
 
Posty: 5224
Dołączył(a): paź 03, 2005 20:17

Poprzednia strona

Powrót do AutoCAD

Kto przegląda forum

Użytkownicy przeglądający ten dział: Brak zidentyfikowanych użytkowników