Jump to content

Lisp problem , please have a look.

andy_lee

By andy_lee
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

andy_lee Collaborator

andy_lee

Posted
Posted

Hi guys

Can help me to supplement the "dot" function ? Thanks a lot!

 

;;http://bbs.xdcad.org/thread-678248-1-1.html
;;by huang
(defun C:myjoin(/ E H J LST N OBJ P11 P12 P21 P22 SS X)
 (defun twoEnt	(e1 e2)
   (setq p11 (vlax-curve-getStartPoint e1))
   (setq p12 (vlax-curve-getEndPoint e1))
   (setq p21 (vlax-curve-getStartPoint e2))
   (setq p22 (vlax-curve-getEndPoint e2))
   (cond ((and (equal (det p11 p12 p21) 0) (equal (det p11 p12 p22) 0))
   (setq H (car (Max-distance (list p11 p12 p21 p22))))
   (setq obj (vlax-ename->vla-object e1))
   (vlax-put obj 'StartPoint (car H))
   (vlax-put obj 'EndPoint (cadr H))
  )
   )
 )

 (cond
   ((setq ss (ssget '((0 . "LINE"))))
    (repeat (setq n (sslength ss))
      (setq e (ssname ss (setq n (1- n))))
      (setq lst (cons e lst))
    )
    (foreach j	lst
      (mapcar '(lambda (x) (cond ((and (entget x) (entget j)) (twoEnt j x)))) lst)
    )
   )
 )
 (princ)
)


;;(Max-distance (getpt (ssget) 10))=>(((-2670.87 3701.22 0.0) (-1725.61 3689.13 0.0)) . 945.338)
(defun Max-distance (H / D M MAXD P PAIR Q U V W)
 (setq Q (cdr (append H H (list (car H)))))		   
 (setq MaxD 0.0)					    
 (foreach U H						    
   (setq V (car Q))					   
   (setq W (cadr Q))					   
   (setq M (MJ:Mid V W))				    
   (while (> (dot M U V) 0.0)				    
     (setq Q (cdr Q))					   
     (setq V (car Q))					   
     (setq W (cadr Q))					   
     (setq M (MJ:Mid V W))				    
   )
   (setq D (distance U V))				   
   (if	(> D MaxD)					    
     (setq MaxD D					   
    Pair (list U V)				    
     )
   )
 )
 (cons Pair MaxD)					   
)

(defun MJ:Mid (P1 P2)
 (mapcar '(lambda (X Y) (* (+ X Y) 0.5)) P1 P2)
)

;;(det (getpoint)(getpoint)(getpoint))
(defun det (p1 p2 p3 / x2 y2)
 (setq        x2 (car p2)
       y2 (cadr p2)
 )
 (- (* (- x2 (car p3)) (- y2 (cadr p1)))
    (* (- x2 (car p1)) (- y2 (cadr p3)))
 )
)

Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted

The code is somewhat wrong... I don't quite know what should it do, but I guessed it should be something like this :

 

;;http://bbs.xdcad.org/thread-678248-1-1.html
;;by huang
;;mod by M.R.

(defun c:myjoin (/ e h j lst n obj p11 p12 p21 p22 ss)

 (vl-load-com)

 (defun twoent (e1 e2)
   (setq p11 (vlax-curve-getstartpoint e1))
   (setq p12 (vlax-curve-getendpoint e1))
   (setq p21 (vlax-curve-getstartpoint e2))
   (setq p22 (vlax-curve-getendpoint e2))
   (if (and (equal (det p11 p12 p21) 0)
            (equal (det p11 p12 p22) 0)
       )
 [highlight];=> if you want only WCS calculation leave this line, but if you want it 3D replace line with T[/highlight]
     (progn
       (setq h (car (max-distance (list p11 p12 p21 p22))))
       (setq obj (vlax-ename->vla-object e1))
       (vlax-put obj 'startpoint (car h))
       (vlax-put obj 'endpoint (cadr h))
     )
   )
 )

 (cond
   ((setq ss (ssget '((0 . "LINE"))))
    (repeat (setq n (sslength ss))
      (setq e (ssname ss (setq n (1- n))))
      (setq lst (cons e lst))
    )
    (foreach j lst
      (mapcar '(lambda (x)
                 (cond ((and (entget x) (entget j)) (twoent j x)))
               )
              lst
      )
    )
   )
 )
 (princ)
)

;;(max-distance ptlst)=>(((-2670.87 3701.22 0.0) (-1725.61 3689.13 0.0)) . 945.338)
(defun max-distance (h / d maxd pair q v)
 (setq q (cdr (append h h (list (car h)))))
 (setq maxd 0.0)
 (foreach u h
   (setq
     v (car
         (vl-sort q
                  '(lambda (a b) (> (distance u a) (distance u b)))
         )
       )
   )
   (setq d (distance u v))
   (if (> d maxd)
     (setq maxd d
           pair (list u v)
     )
   )
 )
 (cons pair maxd)
)

;;(det (getpoint)(getpoint)(getpoint))
(defun det (p1 p2 p3)
 (+ (* (car p1)
       (- (* (cadr p2) (caddr p3)) (* (cadr p3) (caddr p2)))
    )
    (* (- (cadr p1))
       (- (* (car p2) (caddr p3)) (* (car p3) (caddr p2)))
    )
    (* (caddr p1)
       (- (* (car p2) (cadr p3)) (* (car p3) (cadr p2)))
    )
 )
)

Link to comment
Share on other sites
andy_lee Collaborator

andy_lee

Posted
  • Author
Posted
The code is somewhat wrong... I don't quite know what should it do, but I guessed it should be something like this :

 

 

Thank you so much , marko. but , can't batch join .

 

Should be like this:

join.gif

Link to comment
Share on other sites
andy_lee Collaborator

andy_lee

Posted
  • Author
Posted 

(defun dot (p1 p2 p3 / x1 y1)
 (setq        x1 (car p1)
       y1 (cadr p1)
 )
 (+ (* (- (car p2) x1) (- (car p3) x1))
    (* (- (cadr p2) y1) (- (cadr p3) y1))
 )
)

 

I find "dot" function ,But can't work normally

Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted

I would suggest you that you use JOIN command for the same task...

 

http://www.theswamp.org/index.php?topic=46124.0

 

;Written by: Chris Wade
;small mod by M.R.
(defun c:ja ( / *error* uFlag doc StopLoop SelSet SelLen LoopCT )

 (vl-load-com)
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))

 (defun *error* (msg)
   (if doc
     (vla-EndUndoMark doc)
   )
   (if msg
     (prompt msg)
   )
   (princ)
 )

 (while (= StopLoop nil)
   (princ
     "\nPlease select the objects that you would like to join : "
   )
   (setq SelSet (ssget))
   (cond ((/= SelSet nil)
          (vla-StartUndoMark doc)
          (setq SelLen (sslength SelSet))
          (setq LoopCT 0)
          (while (< LoopCT SelLen)
            (vl-cmdf "._join" (ssname SelSet LoopCT) SelSet "")
            (setq LoopCT (+ LoopCT 1))
          )
          (setq StopLoop T)
         )
   )
 )
 (*error* nil)
)

 

I thought you wanted something like this :

 

;;by M.R.

(defun c:myjoin ( / max-distance e ptlst n p1 p2 ss filter ch x )

 ;;(max-distance ptlst)=>(((-2670.87 3701.22 0.0) (-1725.61 3689.13 0.0)) . 945.338)
 (defun max-distance ( h / d maxd pair q v )
   (setq q h)
   (setq maxd 0.0)
   (foreach u h
     (setq
       v (car
           (vl-sort q
                    '(lambda ( a b ) (> (distance u a) (distance u b)))
           )
         )
     )
     (setq d (distance u v))
     (if (> d maxd)
       (setq maxd d
             pair (list u v)
       )
     )
   )
   (cons pair maxd)
 )

 (initget "2D 3D")
 (setq ch (getkword "\n2D or 3D calculation [2D/3D] <3D> : "))
 (if (null ch)
   (setq ch "3D")
 )
 (setq filter (if (eq ch "3D")
                (list '(0 . "LINE"))
                (list '(0 . "LINE")          '(-4 . "<and")
                      '(-4 . "*,*,=")        '(10 0.0 0.0 0.0)
                      '(-4 . "*,*,=")        '(11 0.0 0.0 0.0)
                      '(-4 . "and>")
                     )
              )
 )
 (setq ss (ssget filter))
 (repeat (setq n (sslength ss))
   (setq e (ssname ss (setq n (1- n))))
   (setq p1 (cdr (assoc 10 (entget e)))
         p2 (cdr (assoc 11 (entget e)))
   )
   (setq ptlst (cons p1 ptlst)
         ptlst (cons p2 ptlst)
   )
 )
 (setq x (max-distance ptlst))
 (entmake (list '(0 . "LINE")
                (cons 10 (caar x))
                (cons 11 (cadar x))
                '(62 . 1)
          )
 )
 (princ)
)

 

Regards, M.R.

Link to comment
Share on other sites
andy_lee Collaborator

andy_lee

Posted
  • Author
Posted
I would suggest you that you use JOIN command for the same task...

http://www.theswamp.org/index.php?topic=46124.0

 

Lee's routine is very nice!!!

 

;Written by: Chris Wade
;small mod by M.R.
(defun c:ja ( / *error* uFlag doc StopLoop SelSet SelLen LoopCT )

 (vl-load-com)
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))

 (defun *error* (msg)
   (if doc
     (vla-EndUndoMark doc)
   )
   (if msg
     (prompt msg)
   )
   (princ)
 )

 (while (= StopLoop nil)
   (princ
     "\nPlease select the objects that you would like to join : "
   )
   (setq SelSet (ssget))
   (cond ((/= SelSet nil)
          (vla-StartUndoMark doc)
          (setq SelLen (sslength SelSet))
          (setq LoopCT 0)
          (while (< LoopCT SelLen)
            (vl-cmdf "._join" (ssname SelSet LoopCT) SelSet "")
            (setq LoopCT (+ LoopCT 1))
          )
          (setq StopLoop T)
         )
   )
 )
 (*error* nil)
)

 

Thank you marko, this is good too ! but if can use for pline ,That would be more perfect !!!

 

I thought you wanted something like this :

 

;;by M.R.

(defun c:myjoin ( / max-distance e ptlst n p1 p2 ss filter ch x )

 ;;(max-distance ptlst)=>(((-2670.87 3701.22 0.0) (-1725.61 3689.13 0.0)) . 945.338)
 (defun max-distance ( h / d maxd pair q v )
   (setq q h)
   (setq maxd 0.0)
   (foreach u h
     (setq
       v (car
           (vl-sort q
                    '(lambda ( a b ) (> (distance u a) (distance u b)))
           )
         )
     )
     (setq d (distance u v))
     (if (> d maxd)
       (setq maxd d
             pair (list u v)
       )
     )
   )
   (cons pair maxd)
 )

 (initget "2D 3D")
 (setq ch (getkword "\n2D or 3D calculation [2D/3D] <3D> : "))
 (if (null ch)
   (setq ch "3D")
 )
 (setq filter (if (eq ch "3D")
                (list '(0 . "LINE"))
                (list '(0 . "LINE")          '(-4 . "<and")
                      '(-4 . "*,*,=")        '(10 0.0 0.0 0.0)
                      '(-4 . "*,*,=")        '(11 0.0 0.0 0.0)
                      '(-4 . "and>")
                     )
              )
 )
 (setq ss (ssget filter))
 (repeat (setq n (sslength ss))
   (setq e (ssname ss (setq n (1- n))))
   (setq p1 (cdr (assoc 10 (entget e)))
         p2 (cdr (assoc 11 (entget e)))
   )
   (setq ptlst (cons p1 ptlst)
         ptlst (cons p2 ptlst)
   )
 )
 (setq x (max-distance ptlst))
 (entmake (list '(0 . "LINE")
                (cons 10 (caar x))
                (cons 11 (cadar x))
                '(62 . 1)
          )
 )
 (princ)
)

 

No, this is not I want. This can't batch merge Lines .

20141217192937.jpg

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...