Topic: Challenge ( Create line )

[Mark]

Write a program that will create a line with the same angle of the user selected line and user supplied distance. The line should begin from the end point of the selected line closest to the pick point. Hope that makes sense...

Pseudo code:
Prompt user to select a LINE.
Make sure we got a LINE.
Determine angle of selected LINE.
Determine end point of LINE nearest pick point.
Create a new LINE using angle, distance and end point info.

[M-dub]

Sounds almost like the insertion of a block ( ? )

[David Hall]

offset

[T.Willey]

Here is a lazy command version.

Code: [Select]

(defun c:NewLine (/ Sel EntData Ang StPt EndPt Dist NewPt OldOs)

(setq OldOs (getvar "osmode"))
(setvar "osmode" 0)
(and
 (setq Sel (entsel "\n Select line near end point to add new line: "))
 (setq EntData (entget (car Sel)))
 (= (cdr (assoc 0 EntData)) "LINE")
 (setq Ang
  (if
   (<
    (distance (cadr Sel) (setq StPt (cdr (assoc 10 EntData))))
    (distance (cadr Sel) (setq EndPt (cdr (assoc 11 EntData))))
   )
   (progn
    (setq NewPt StPt)
    (angle EndPt StPt)
   )
   (progn
    (setq NewPt EndPt)
    (angle StPt EndPt)
   )
  )
 )
 (setq Dist (getdist "\n Enter length of line: "))
 (setq EndPt (polar NewPt Ang Dist))
 (command "_.line" NewPt EndPt "")
)
(setvar "osmode" OldOs)
(princ)
)


[Joe Burke]

Hey Tim,

Works in a UCS. Not well tested, but seems OK.

Code: [Select]

(defun c:CopyLine ( / ent obj len pt param p1 p2 end newline)
  (if
    (and
      (setq ent (entsel "\nSelect line: "))
      (setq obj (vlax-ename->vla-object (car ent)))
      (eq "AcDbLine" (vlax-get obj 'ObjectName))
      (setq len (getdist "\nEnter length of new line: "))
    )
    (progn
      (setq pt (trans (cadr ent) 1 0)
            pt (vlax-curve-GetClosestPointTo obj pt)
            param (vlax-curve-getParamAtPoint obj pt)
      )
      (if (< param (* 0.5 (vlax-curve-GetEndParam obj)))
        (setq p1 (vlax-get obj 'StartPoint)
              p2 (vlax-get obj 'EndPoint)
              end "StartPoint"
        )
        (setq p1 (vlax-get obj 'EndPoint)
              p2 (vlax-get obj 'StartPoint)
              end "EndPoint"
        )
      )
      (setq newline (vlax-invoke obj 'Copy))
      (vlax-invoke newline 'Move p2 p1)
      (vlax-put newline end (polar p1 (angle p2 p1) len))
    )
  )
  (princ)
) ;end


[T.Willey]

Okay, I like Joe's better.  It will keep the information of the original line (which I was to lazy to do).

[CAB]

Another version.

Code: [Select]

(defun c:newline (/ ss len entdata ent pt elst stpt enpt p10 p11)
  (and
    (progn (prompt "\nSelect line: ")
           (setq ss (ssget "_+.:E:S" '((0 . "LINE")))))
    (setq len (getdist "\nEnter length of new line: "))
    (setq entdata (ssnamex ss 0)
          ent     (cadar entdata)
          pt      (last (last (cdar entdata)))
          elst    (entget ent)
    )
    (if (> (distance pt (setq stpt (cdr (assoc 10 elst))))
           (distance pt (setq enpt (cdr (assoc 11 elst))))
        )
      (setq p10 (cons 10 enpt)
            p11 (cons 11 (polar enpt (angle enpt stpt) len)))
      (setq p10 (cons 10 stpt)
            p11 (cons 11 (polar stpt (angle stpt enpt) len)))
    )
    (entmake (subst p10 (assoc 10 elst) (subst p11 (assoc 11 elst) elst)))
  )
  (princ)
)
<edit: removed dependance on dxf routine>

[Joe Burke]

CAB,

Your code doesn't produce the same result as what Tim and I posted.

[Kerry]

Alan, that's a unique use of progn ...

[CAB]

Thanks Kerry.

CAB,
Your code doesn't produce the same result as what Tim and I posted.

I'm sorry you miss understood the requirements.
Just kidding. 

Code: [Select]

(defun c:newline (/ ss len entdata ent pt elst stpt enpt p10 p11)
  (and
    (progn (prompt "\nSelect line: ")
           (setq ss (ssget "_+.:E:S" '((0 . "LINE")))))
    (setq len (getdist "\nEnter length of new line: "))
    (setq entdata (ssnamex ss 0)
          ent     (cadar entdata)
          pt      (last (last (cdar entdata)))
          elst    (entget ent)
    )
    (if (> (distance pt (setq stpt (cdr (assoc 10 elst))))
           (distance pt (setq enpt (cdr (assoc 11 elst))))
        )
      (setq p10 (cons 10 enpt)
            p11 (cons 11 (polar enpt (angle stpt enpt) len)))
      (setq p10 (cons 10 stpt)
            p11 (cons 11 (polar stpt (angle enpt stpt) len)))
    )
    (entmake (subst p10 (assoc 10 elst) (subst p11 (assoc 11 elst) elst)))
  )
  (princ)
)

[Joe Burke]

Alan,

That works.

Also interesting, I wasn't aware ssnamex returns a WCS point in this case. So your routine works in a UCS. Thanks for the example.

[CAB]

Thank you for saying so Joe.
Evgeniy has kindled new interest in the ssnamex function for me.

http://www.theswamp.org/index.php?topic=10851.msg137381#msg137381
http://www.theswamp.org/index.php?topic=10851.msg138115#msg138115

[Andrea]

one of mine...

Code: [Select]

;;New Extention Line  NEL
(defun c:nel (/ lname q0 q1 q2 q3 q4 sscount val1 p#1 p#2 layername ltypelist color# ltype# ang col lay fp sp lin)
  
 (setq lname (ssget '((0 . "LINE"))))
  (if (not lname)
    (progn
      (alert " No LINE entity was selected please try again.")
      (exit)
    )
  (progn
  (setq q0 (getdist "\nEnter required distance or pick..."))
  (initget "L R")
  (setq q1 (getkword "\nLeft or Right extension <L R>?: "))
  (initget "Y N")
  (setq q2 (getkword "\nWould you like same layer <Yes No>?: "))
  (if (eq q2 "N")
  (setq lay (getstring "\nEnter new Layer name : "))
  )
  (initget "Y N")
  (setq q3 (getkword "\nWould you like same Color <Yes No>?: "))
  (if (eq q3 "N")
  (setq col (acad_colordlg 1 8))
  )
  (initget "Y N")
  (setq q4 (strcase (getkword "\nWould you like same linetype <Yes No>?: ")))
  (if (eq q4 "N")
      (progn
      (setq lin (strcase (getstring "\nEnter new LineType name : ")))
      (foreach n (ai_table "ltype" 4)
      (setq ltypelist (append ltypelist (list (strcase n))))
      );;foreach
      (if (not (member lin ltypelist))
  (setq acq1 (acet-ui-message "Your Linetype is not loaded.\n Would you like to load it ?" "NL message" 4))
      );;if
      (if (eq acq1 6)(progn (initdia 1)(command "_.linetype")))
        );;progn
  );;if
 
   
(setq sscount (sslength lname))
(setq val1 (- sscount 1))

 (repeat sscount
   (setq a1 (entget (ssname lname val1)))
     (setq Layername (cdr (assoc 8 a1))) ;;layer name
     (setq color# (cdr (assoc 62 a1))) ;;color #
     (setq ltype# (cdr (assoc 6 a1))) ;;linetype #
     (setq p#1 (cdr (assoc 10 a1))) ;;point 1
     (setq p#2 (cdr (assoc 11 a1))) ;;point 2
     (setq ang (angle p#1 p#2)) ;;angle 1
(if (< (car p#1)(car p#2))
  (progn
  (setq flp p#1) 
  (setq slp (polar p#1 (angle p#2 p#1) q0))
  (setq frp p#2)
  (setq srp (polar p#2 (angle p#1 p#2) q0))
  )
  (progn
  (setq flp p#2) 
  (setq slp (polar p#2 (angle p#1 p#2) q0))
  (setq frp p#1)
  (setq srp (polar p#1 (angle p#2 p#1) q0))
  )
)
 
(if (eq q1 "L")
 (command "_.line" flp slp "")
 (command "_.line" frp srp "")
) 
(if col (command "_.chprop" "_L" "" "_C" col ""))

(if (eq q2 "Y")
  (command "_.chprop" "_L" "" "_LA" Layername "")
  (progn
(if lay
    (progn
      (foreach n (ai_table "layer" 4)
      (setq laylist (append laylist (list (strcase n))))
      )
   
(if (not (member lay laylist))
  (command "_.-layer" "_n" lay ""))

(command "_.chprop" "_L" "" "_LA" lay ""))
);;if
);;progn
)

(if (eq q4 "Y")(command "_.chprop" "_L" "" "_LT" ltype# ""))
(foreach n (ai_table "ltype" 4)
      (setq ltypelist (append ltypelist (list (strcase n))))
      );;foreach
(if (and (eq q4 "N")(member lin ltypelist))
(command "_.chprop" "_L" "" "_LT" lin ""))
   (setq val1 (- val1 1))
   
);;repeat
);;progn
);;if
);;defun