HotOffTheGrill lisp

[macros55]

Good day, I found such a LISP (from Mr. PBEJSE), it is very useful, who can help me make some additions?

 

The command writes the slope and distance between two selected objects with different elevations.

 

These are what I want. Let each added object have its own different layer. Also slope, distance and arrow be in blocks.
Thanks for help.

 

HOTOFFTHEGRILL.LSP HotOffTheGrill.dwg

[pBe]

This is where you posted the request.

Let me have a look-see

 

You want to use an Attribute block?

Its easy, but one thing the program will not do for you is to create the block, it will check if the block exist. You should have that block at the ready.

 

Edited May 21 by pBe

[macros55]

Good day Mr pBe, yes I added the sample dwg file here.
Whatever you think about Block is possible. Let slope, distance and arrow all be compact.
Also It makes the process like a straight line in curves. How to find a solution for this?

[pBe]

Quote

Also It makes the process like a straight line in curves. How to find a solution for this?

What is that?

 

[macros55]

Like This,

 

 

[pBe]

Really now? . definitely doable 

 

[macros55]

Mr. pBe, İf possible like that, you would be of great help to me. 

Thanks very much 

[Steven P]

I think these might be handy

 

Poly2Chords will take a polyline and straighten curved segments into straight lines / chords

 

(defun c:Poly2Chords ( / MyEnt MyChords ModifiedEnt)
;;Select Entity
  (setq MyEnt (entget (car (entsel))))     ; Select Polyline / Line Entity 
  (setq MyChords (getreal "Chords in 360 degrees: "))
  (setq ModifiedEnt (PolyChords MyEnt MyChords)) ; Returns modified entity definition list
  (entmod ModifiedEnt)                    ; Here create a new polyline, can also (entmod...) instead
  (princ)
)
(defun c:Poly2Chords_List ( / MyEnt MyChords ModifiedEnt)
  (defun mAssoc ( key lst / result )
    (foreach x lst (if (= key (car x)) (setq result (cons (cdr x) result)) ) )
    (reverse result)
  )
  (setq MyEnt (entget (car (entsel))))     ; Select Polyline / Line Entity 
  (setq MyChords (getreal "Chords in 360 degrees: "))
  (setq ModifiedEnt (PolyChords MyEnt MyChords))
  (princ (mAssoc 10 ModifiedEnt))

)

(defun PolyChords ( MyEnt vertexin360 / vertexin360 NewEnt acount p1 p2 open Open b MyBulge MyBulgeC StartAng EndAng MyRadius ccw Chordangle Chords ChordCount NewPt)

;;Add in start / end thickness 40, 41
;;Add in if arc selected do conversion

;;;;; Sub Functions
  (defun LM:Bulge->Arc ( p1 p2 b / c r ) ;; Refer to Lee Mac Website ;;Gives Arc definition from pline Bulge
    (setq r (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
          c (polar p1 (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b)))) r)
    )
    (if (minusp b)
        (list c (angle c p2) (angle c p1) (abs r))
        (list c (angle c p1) (angle c p2) (abs r))
    )
  )
  (defun LM:BulgeCenter ( p1 p2 b ) ;; Refer to Lee Mac Website ;;Gives Arc definition from pline Bulge
    (polar p1
        (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b))))
        (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
    )
  )
  (defun mAssoc ( key lst / result ) ;;Lee Mac: https://www.cadtutor.net/forum/topic/27914-massoc-implementations/
   (foreach x lst
     (if (= key (car x))
       (setq result (cons (cdr x) result))
     )
   )
   (reverse result)
  )
;;;;; End Sub Functions

;;Set Variables
;;  (setq vertexin360 180)               ; Number of chords in full circle, 360: every 1 degree
  (setq NewEnt (list))                 ; New List for the modified entity definition
  (setq acount 0)                      ; A counter

;;Find curves '42'
  (while (< acount (length MyEnt))
    (if  (and (=  (car (nth acount MyEnt)) 42) ; if dxf code 42
              (/= (cdr (nth acount MyEnt)) 0)  ; and is a value: a bulge!
         ) ; end and
      (progn
        (setq p1 (cdr (nth (- acount 3) MyEnt))) ; Start Coordinate
        (setq p2 (nth (+ acount 2) MyEnt))       ; End Coordinate as dxf code
          (if (= (car p2) 210)                   ; If P2 is "210" and not a "10" - end of polyline
          (if (= (cdr (assoc 70 MyEnt)) 1)
            (progn                               ; Closed Polyline
              (setq p2 (assoc 10 MyEnt))         ; Set end coordinate to start coordinate
              (setq open nil)
            ) ; end progn
            (progn                               ;Open PolyLine, end of polyline
              (setq Open "Open")
            ) ; end progn
          ) ; end if closed / open
        ) ; end if 210
        (setq p2 (cdr p2))                       ; End Coordinate
        (setq b (cdr (nth acount MyEnt)))        ; Bulge
        (if (= Open "Open")                      ; If next point is '210'
          ()                                     ; End of chords
          (progn                                 ; Calculate Chords
            (setq MyBulge (LM:Bulge->Arc p1 p2 b))    ; Bulge as arc
            (setq MyBulgeC (LM:BulgeCenter p1 p2 b) ) ; Bulge Centre
            (setq StartAng (nth 1 MyBulge))           ; start angle centre to point
            (setq EndAng   (nth 2 MyBulge))           ; End angle centre to point
            (setq MyRadius (nth 3 MyBulge))           ; Bulge radius
            (if (< 0 b)(setq ccw 1)(setq ccw -1))     ; clockwise / anticlockwise
            (setq Chordangle (/ (* 4 (atan b))) )
            (setq Chords (* ( /  Chordangle (/ (* 2 pi) vertexin360)) ccw) ) ; point every nth degree

;            (if (> Chords vertexin360) ;;Check number of chords isn't too big: TL, TR 'corners'. Not needed?
;              (progn
;                (setq Chordangle (+ (- (cadr MyBulge) (caddr MyBulge)) (* 1 pi)) )
;                (setq Chords (/  Chordangle (/ (* 2 pi) vertexin360) )) ; point every x degrees
;            )) ; end progn ; end if
            (setq ChordCount 1)

            (while (< ChordCount Chords)
              (if (= ccw 1)
                (setq NewPt (polar MyBulgeC (+ (* (/ (* 2 pi) vertexin360) ChordCount) StartAng) MyRadius) )
                (setq NewPt (polar MyBulgeC (- EndAng (* (/ (* 2 pi) vertexin360) ChordCount) ) MyRadius) )
              )
              (setq NewEnt (append NewEnt (list (cons 42 0)) ) )    ; bulge value: 0
              (setq NewEnt (append NewEnt (list (cons 91 0)) ) )    ; Vertex Identifier
              (setq NewEnt (append NewEnt (list (cons 10 NewPt)) )) ; Point
              (setq NewEnt (append NewEnt (list (cons 40 0)) ) )    ; Start width
              (setq NewEnt (append NewEnt (list (cons 41 0)) ) )    ; end width
              (setq ChordCount (+ ChordCount 1))
            ) ; end while
          ) ; end progn
        ) ; end if Open (end of line)
      ) ; end progn

      (progn
        (setq NewEnt (append NewEnt (list (nth acount MyEnt)) ) ) ; Add other DXF codes to NewEnt listing
      ) ; end progn
    ) ; end if '42'
    (setq acount (+ acount 1))
  ) ; end while length MyEnt

  (setq NewEnt (subst (cons 90 (length (mAssoc 10 NewEnt))) (assoc 90 NewEnt) NewEnt )) ; update number of verticies
;;add in 70 for continuos line types
  NewEnt ; return new entity definition
)

 

Arc2Lines takes an arc and converts that to straight lines.

 

(defun c:Arc2Lines ( / oldsnap oldecho MySS ent obj div endpt totlen arclen chrdpt num newpt objlst)
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark thisdrawing)         ; Start Undo

  (setq MySS (ssget '((0 . "ARC"))))

  (setq div (getint "Enter number of divisions (25): "))
  (if (= div nil)(setq div 25))

  (if (= MySS nil)
    ()
    (progn
      (setq acount 0)
        (while (< acount (sslength MySS))
          (setq ent (ssname MySS acount))
          (setq obj (vlax-ename->vla-object ent))
;          (setq div 25) ; number of divisions - need to set by arc angle? 3 deg / division
          (setq  endpt (vlax-curve-getEndPoint obj)
                 totlen (vlax-curve-getDistAtPoint obj endpt)
                 arclen (/ totlen div)
                 chrdpt (vlax-curve-getStartPoint obj)
                 num 1     
          ) ; end setq
          (repeat div
            (setq newpt (vlax-curve-getPointatDist obj (* arclen num)))
            (command "line" chrdpt "_non" newpt "_non" "")
            (setq num (+ num 1))   
            (setq chrdpt newpt)
          ) ;repeat
          (setq objlst (cons obj objlst))
          (entdel ent)
          (setq acount (+ acount 1))
        ) ; end while
      ) ; end progn
    ) ; end if MySS
    (vla-endundomark thisdrawing)      ; end undo
    (princ)
)

 

 

I should really combine these 2 together one day but haven't yet, perhaps also to add in splines

[macros55]

43 minutes ago, Steven P said:

(defun c:Poly2Chords ( / MyEnt MyChords ModifiedEnt)
;;Select Entity
  (setq MyEnt (entget (car (entsel))))     ; Select Polyline / Line Entity 
  (setq MyChords (getreal "Chords in 360 degrees: "))
  (setq ModifiedEnt (PolyChords MyEnt MyChords)) ; Returns modified entity definition list
  (entmod ModifiedEnt)                    ; Here create a new polyline, can also (entmod...) instead
  (princ)
)
(defun c:Poly2Chords_List ( / MyEnt MyChords ModifiedEnt)
  (defun mAssoc ( key lst / result )
    (foreach x lst (if (= key (car x)) (setq result (cons (cdr x) result)) ) )
    (reverse result)
  )
  (setq MyEnt (entget (car (entsel))))     ; Select Polyline / Line Entity 
  (setq MyChords (getreal "Chords in 360 degrees: "))
  (setq ModifiedEnt (PolyChords MyEnt MyChords))
  (princ (mAssoc 10 ModifiedEnt))

)

(defun PolyChords ( MyEnt vertexin360 / vertexin360 NewEnt acount p1 p2 open Open b MyBulge MyBulgeC StartAng EndAng MyRadius ccw Chordangle Chords ChordCount NewPt)

;;Add in start / end thickness 40, 41
;;Add in if arc selected do conversion

;;;;; Sub Functions
  (defun LM:Bulge->Arc ( p1 p2 b / c r ) ;; Refer to Lee Mac Website ;;Gives Arc definition from pline Bulge
    (setq r (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
          c (polar p1 (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b)))) r)
    )
    (if (minusp b)
        (list c (angle c p2) (angle c p1) (abs r))
        (list c (angle c p1) (angle c p2) (abs r))
    )
  )
  (defun LM:BulgeCenter ( p1 p2 b ) ;; Refer to Lee Mac Website ;;Gives Arc definition from pline Bulge
    (polar p1
        (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b))))
        (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
    )
  )
  (defun mAssoc ( key lst / result ) ;;Lee Mac: https://www.cadtutor.net/forum/topic/27914-massoc-implementations/
   (foreach x lst
     (if (= key (car x))
       (setq result (cons (cdr x) result))
     )
   )
   (reverse result)
  )
;;;;; End Sub Functions

;;Set Variables
;;  (setq vertexin360 180)               ; Number of chords in full circle, 360: every 1 degree
  (setq NewEnt (list))                 ; New List for the modified entity definition
  (setq acount 0)                      ; A counter

;;Find curves '42'
  (while (< acount (length MyEnt))
    (if  (and (=  (car (nth acount MyEnt)) 42) ; if dxf code 42
              (/= (cdr (nth acount MyEnt)) 0)  ; and is a value: a bulge!
         ) ; end and
      (progn
        (setq p1 (cdr (nth (- acount 3) MyEnt))) ; Start Coordinate
        (setq p2 (nth (+ acount 2) MyEnt))       ; End Coordinate as dxf code
          (if (= (car p2) 210)                   ; If P2 is "210" and not a "10" - end of polyline
          (if (= (cdr (assoc 70 MyEnt)) 1)
            (progn                               ; Closed Polyline
              (setq p2 (assoc 10 MyEnt))         ; Set end coordinate to start coordinate
              (setq open nil)
            ) ; end progn
            (progn                               ;Open PolyLine, end of polyline
              (setq Open "Open")
            ) ; end progn
          ) ; end if closed / open
        ) ; end if 210
        (setq p2 (cdr p2))                       ; End Coordinate
        (setq b (cdr (nth acount MyEnt)))        ; Bulge
        (if (= Open "Open")                      ; If next point is '210'
          ()                                     ; End of chords
          (progn                                 ; Calculate Chords
            (setq MyBulge (LM:Bulge->Arc p1 p2 b))    ; Bulge as arc
            (setq MyBulgeC (LM:BulgeCenter p1 p2 b) ) ; Bulge Centre
            (setq StartAng (nth 1 MyBulge))           ; start angle centre to point
            (setq EndAng   (nth 2 MyBulge))           ; End angle centre to point
            (setq MyRadius (nth 3 MyBulge))           ; Bulge radius
            (if (< 0 b)(setq ccw 1)(setq ccw -1))     ; clockwise / anticlockwise
            (setq Chordangle (/ (* 4 (atan b))) )
            (setq Chords (* ( /  Chordangle (/ (* 2 pi) vertexin360)) ccw) ) ; point every nth degree

;            (if (> Chords vertexin360) ;;Check number of chords isn't too big: TL, TR 'corners'. Not needed?
;              (progn
;                (setq Chordangle (+ (- (cadr MyBulge) (caddr MyBulge)) (* 1 pi)) )
;                (setq Chords (/  Chordangle (/ (* 2 pi) vertexin360) )) ; point every x degrees
;            )) ; end progn ; end if
            (setq ChordCount 1)

            (while (< ChordCount Chords)
              (if (= ccw 1)
                (setq NewPt (polar MyBulgeC (+ (* (/ (* 2 pi) vertexin360) ChordCount) StartAng) MyRadius) )
                (setq NewPt (polar MyBulgeC (- EndAng (* (/ (* 2 pi) vertexin360) ChordCount) ) MyRadius) )
              )
              (setq NewEnt (append NewEnt (list (cons 42 0)) ) )    ; bulge value: 0
              (setq NewEnt (append NewEnt (list (cons 91 0)) ) )    ; Vertex Identifier
              (setq NewEnt (append NewEnt (list (cons 10 NewPt)) )) ; Point
              (setq NewEnt (append NewEnt (list (cons 40 0)) ) )    ; Start width
              (setq NewEnt (append NewEnt (list (cons 41 0)) ) )    ; end width
              (setq ChordCount (+ ChordCount 1))
            ) ; end while
          ) ; end progn
        ) ; end if Open (end of line)
      ) ; end progn

      (progn
        (setq NewEnt (append NewEnt (list (nth acount MyEnt)) ) ) ; Add other DXF codes to NewEnt listing
      ) ; end progn
    ) ; end if '42'
    (setq acount (+ acount 1))
  ) ; end while length MyEnt

  (setq NewEnt (subst (cons 90 (length (mAssoc 10 NewEnt))) (assoc 90 NewEnt) NewEnt )) ; update number of verticies
;;add in 70 for continuos line types
  NewEnt ; return new entity definition
)

 

HotOffTheGrill _ rev2.dwg

[macros55]

Mr. Steven P, 

 

Thanks for interesting, unfortunately this LISP for different situation. I have added a dwg file please see attached HotOffThePress _ rev2.dwg

HotOffTheGrill _ rev2.dwg

[Steven P]

That's no problem - I was in a 90 minute new project briefing, decided to do something more useful but only read your question quickly. 

[devitg]

1 hour ago, macros55 said:

Mr. Steven P, 

 

Thanks for interesting, unfortunately this LISP for different situation. I have added a dwg file please see attached HotOffThePress _ rev2.dwg

HotOffTheGrill _ rev2.dwg 493.85 kB · 1 download

 

@macros55 , it is not to download such  HotOffThePress _ rev2.dwg 

 

 

[macros55]

Please try these

HotOffTheGrill _ rev2.dwg HOTOFFTHEGRILL.LSP

[devitg]

4 hours ago, pBe said:

What is that?

 

 

Hi @pBe please clear me a bot this 2 lines 

;(setq zedv (lambda (p)(mapcar 'caddr (mapcar 'car p))))

;;;(setq rsu (lambda (a)
;;;	    (and (> a (/ pi 2)) (<= a (* pi 1.5))))
;;;	    )
 
  I change to  
 (defun zedv (lambda (p)(mapcar 'caddr (mapcar 'car p))))
 
  (defun rsu (lambda (a)
	    (and (> a (/ pi 2)) (<= a (* pi 1.5))))
	    )

As I know it shall both be a DEFUN, not a SETQ. 
Or Lamda it is out off my understand   

 

 

 

 

[devitg]

15 minutes ago, macros55 said:

Please try these

HotOffTheGrill _ rev2.dwg 493.85 kB · 0 downloads HOTOFFTHEGRILL.LSP 3.5 kB · 0 downloads

 

@macros55 so the lisp shall select whatever is between the 2 points or insert.  And neither you need to make such curve .  just in case there is nothing between the select point or insert , make a straight line .  

 

 

 

 

[macros55]

 If direction is straight I agree with you but direction is not always straight, sometimes curve, spline or pllne

[devitg]

1 hour ago, macros55 said:

 If direction is straight I agree with you but direction is not always straight, sometimes curve, spline or pllne

@macros55, at your first dwg there was not a straight line. 

[macros55]

Please sea attached new example drawing rev3

The drawing describes the current(before) situation and the situation needed (after).

HotOffTheGrill _ rev3.dwg

[Tsuky]

This? With only your exemple... for start!

(defun c:foo ( / AcDoc Space n typ_ent sel l_z ss ent p_start p_end pt_start pt_end pt_mid len deriv rtx OK old-dim)
  (setq
    AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
    Space
    (if (= 1 (getvar "CVPORT"))
      (vla-get-PaperSpace AcDoc)
      (vla-get-ModelSpace AcDoc)
    )
  )
  (vla-startundomark AcDoc)
  (setq n 1 typ_ent nil)
  (repeat 2
    (while (not (eq typ_ent "INSERT"))
      (setq sel (entsel (strcat "\nSelect insert " (itoa n) ": ")))
      (if sel (setq typ_ent (cdr (assoc 0 (setq dxf_ent (entget (car sel)))))))
    )
    (setq l_z (cons (cdr (assoc 10 dxf_ent)) l_z) n (1+ n) typ_ent nil)
  )
  (princ "\nSelect a curve object")
  (while
    (not
      (setq ss
        (ssget "_+.:E:S"
          '(
            (-4 . "<OR")
              (-4 . "<AND")
                (0 . "*POLYLINE")
                (-4 . "<AND")
                  (-4 . "<NOT") (-4 . "&") (70 . 121) (-4 . "NOT>")
                (-4 . "AND>")
              (-4 . "AND>")
              (0 . "ARC")
              (0 . "LINE")
              (-4 . "<AND")
                (0 . "SPLINE")
                (-4 . "<AND")
                  (-4 . "<NOT") (-4 . "&") (70 . 1) (-4 . "NOT>")
                (-4 . "AND>")
              (-4 . "AND>")
            (-4 . "OR>")
          )
        )
      )
    )
  )
  (setq
    ent (ssname ss 0)
    p_start (vlax-curve-getStartParam ent)
    p_end (vlax-curve-getEndParam ent)
    pt_start (vlax-curve-getStartPoint ent)
    pt_end (vlax-curve-getEndPoint ent)
    pt_mid (vlax-curve-getPointAtParam ent (* 0.5 (- p_end p_start)))
    len (vlax-curve-getDistAtPoint ent pt_end)
    deriv (vlax-curve-getFirstDeriv ent (* 0.5 (- p_end p_start)))
    rtx (- (atan (cadr deriv) (car deriv)) (angle '(0 0 0) (getvar "UCSXDIR")))
    OK (apply 'append (mapcar '(lambda (x) (mapcar '(lambda (zx) (equal (list (car x) (cadr x)) (list (car zx) (cadr zx)) 1E-08)) l_z)) (list pt_start pt_end)))
  )
  (cond
    ((eq (length (vl-remove nil OK)) 2)
      (setq old-dim (getvar "DIMZIN"))
      (setvar "DIMZIN" 0)
      (if (or (> rtx (* pi 0.5)) (< rtx (- (* pi 0.5)))) (setq rtx (+ rtx pi)))
      (mapcar
        '(lambda (x y z r w / nw_obj)
          (setq nw_obj
            (vla-addMtext Space
              (vlax-3d-point x)
              0.0
              y
            )
          )
          (mapcar
            '(lambda (pr val)
              (vlax-put nw_obj pr val)
            )
            (list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation 'Color)
            (list 5 0.79 5 x "Arial" z r w)
          )
        )
        (list (polar pt_mid (- rtx (* pi 0.5)) 0.79) (polar pt_mid (+ rtx (* pi 0.5)) 0.79) (polar (car l_z) pi 0.79) (polar (cadr l_z) pi 0.79) pt_mid)
        (list (rtos len 2 2) (strcat (rtos (* (/ (apply '- (mapcar 'caddr l_z)) len) 100.0) 2 2) "%") (rtos (caddar l_z) 2 2) (rtos (car (cddadr l_z)) 2 2) "<<<")
        (list "H-Distance" "H-Slope" "H-Elevation" "H-Elevation" "H-Arrow")
        (list rtx rtx (* pi 0.5) (* pi 0.5) rtx)
        (list 1 3 4 4 5)
      )
      (vlax-put (vlax-ename->vla-object ent) 'Layer "H-Line")
      (vlax-put (vlax-ename->vla-object ent) 'Color 2)
      (setvar "DIMZIN" old-dim)
    )
    (T
      (princ "\nInsufficient coincidence between curvilinear object and insertion")
    )
  )
  (vla-endundomark AcDoc)
  (prin1)
)

 

[macros55]

Mr Tsuky, Thank you very much for your interest, could you please make some arrangements?