LISP: Unique Polyline Arrow

Here is a great routine to create unique arrows polyline arrows.

DPA <enter> to start
(Can specify if you want one arrow or an arrow on both ends)
Specify the width (I chose 5 for this example)
Pick the desired points Can also use ORTHO.
Right-click to end

~enjoy

(defun c:DPA (/ DrawEndArrowHead DrawStartArrowHead ActDoc CurSpc Dist ArSty Pt PtList StList Ang EndList
PtList+ PtList- oPt nPt tempPt oAng oAng+ oAng- oPt+ oPt- nPt+ nPt- cAng cAng+ cAng-
tempPt+ tempPt- ntemp+ ntemp- Pt+ Pt- PolyPtList *error* AlignX AlignY AlignZ DistX DistY DistZ)
(vl-load-com)
; Draw a polyline arrow, now shown as you move the cursor
(defun *error* (msg)
;(vl-bt)
(redraw)
(prompt (strcat "\n Error-> " msg))
)
;---------------------------------------------------------------------------------------------------------
(defun GetCurrentSpace (Doc / BlkCol SpaceList CurSpace ActSpace temp1)
; Returns the "block object" for the active space
; Thanks to Jeff Mishler
(if (= (getvar "cvport") 1)
(vla-get-PaperSpace Doc)
(vla-get-ModelSpace Doc)
)
)
;---------------------------------------------------------------------------------------------------------
(defun AlignX (pt1 pt2)
(list
(car pt1)
(cadr pt2)
(caddr pt2)
)
)
;---------------------------------------------------------------------------------------------------------
(defun AlignY (pt1 pt2)
(list
(car pt2)
(cadr pt1)
(caddr pt2)
)
)
;---------------------------------------------------------------------------------------------------------
(defun AlignZ (pt1 pt2)
(list
(car pt2)
(cadr pt2)
(caddr pt1)
)
)
;---------------------------------------------------------------------------------------------------------
(defun DrawEndArrowHead (Stpt CurPt ArrHeadDist ReturnPoints / Ang -Ang tempPt Ang+ Ang- Pt+ Pt-)
(setq Ang (angle StPt CurPt))
(setq -Ang (rem (+ Ang pi) (* pi 2.0)))
(setq tempPt (polar CurPt -Ang (* ArrHeadDist 2.0)))
(setq Ang+ (rem (+ Ang (* pi 0.5)) (* pi 2.0)))
(setq Ang- (rem (+ Ang (* pi 1.5)) (* pi 2.0)))
(setq Pt+ (polar tempPt Ang+ (* ArrHeadDist 0.5)))
(setq Pt- (polar tempPt Ang- (* ArrHeadDist 0.5)))
(grvecs
(list
1 Pt+ (polar Pt+ Ang+ (* ArrHeadDist 0.5))
1 (polar Pt+ Ang+ (* ArrHeadDist 0.5)) CurPt
1 CurPt (polar Pt- Ang- (* ArrHeadDist 0.5))
1 (polar Pt- Ang- (* ArrHeadDist 0.5)) Pt-
)
)
(if ReturnPoints
(list
(polar Pt+ Ang+ (* ArrHeadDist 0.5))
CurPt
(polar Pt- Ang- (* ArrHeadDist 0.5))
)
(list Pt+ Pt-)
)
)
;-------------------------------------------------------------------------------------------------------------------
(defun DrawStartArrowHead (StPt CurPt ArrHeadDist ReturnPoints / Ang -Ang tempPt Ang+ Ang- Pt+ Pt- Pt+2 Pt-2)
(setq Ang (angle CurPt StPt))
(setq -Ang (rem (+ Ang pi) (* pi 2.0)))
(setq tempPt (polar StPt -Ang (* ArrHeadDist 2.0)))
(setq Ang+ (rem (+ Ang (* pi 0.5)) (* pi 2.0)))
(setq Ang- (rem (+ Ang (* pi 1.5)) (* pi 2.0)))
(setq Pt+ (polar tempPt Ang+ (* ArrHeadDist 0.5)))
(setq Pt- (polar tempPt Ang- (* ArrHeadDist 0.5)))
(grvecs
(list
1 Pt+ (polar Pt+ Ang+ (* ArrHeadDist 0.5))
1 (polar Pt+ Ang+ (* ArrHeadDist 0.5)) StPt
1 StPt (polar Pt- Ang- (* ArrHeadDist 0.5))
1 (polar Pt- Ang- (* ArrHeadDist 0.5)) Pt-
)
)
(if ReturnPoints
(list
(polar Pt+ Ang+ (* ArrHeadDist 0.5))
StPt
(polar Pt- Ang- (* ArrHeadDist 0.5))
)
(list Pt- Pt+)
)
)
,-------------------------------------------------------------------------------------------------------------------
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(setq CurSpc (GetCurrentSpace ActDoc))
(initget "Single Double")
(setq Dist (getdist "\n Enter width [<Single>/Double arrow head]: "))
(if (= (type Dist) 'STR)
(progn
(setq ArSty Dist)
(setq Dist (getdist "\n Enter width: "))
)
(setq ArSty "Single")
)
(setq Pt (getpoint "\n Select starting point: "))
(setq PtList (list Pt))
(while
(and
PtList
Pt
ArSty
Dist
(not (prompt "\r Select next point [right click to exit / Undo]: "))
(not (vl-position (car (setq tempList (grread T 0))) '(11 25)))
)
(cond
((equal (car tempList) 2)
(cond
((equal (cadr tempList) 15)
(setvar "orthomode" (abs (1- (getvar "orthomode"))))
)
((and (> (length PtList) 1) (vl-position (cadr tempList) '(85 117)))
(setq PtList (cdr PtList))
(setq PtList+ (cdr PtList+))
(setq PtList- (cdr PtList-))
(redraw)
(if (= ArSty "Double")
(DrawStartArrowHead (last PtList) (nth (- (length PtList) 2) PtList) Dist nil)
(grdraw (car StList) (cadr StList) 1)
)
(setq EndList (DrawEndArrowHead (car PtList) (polar tempPt cAng (* Dist 2.0)) Dist nil))
(setq cnt 0)
(while (< (1+ cnt) (length PtList+))
(grdraw (nth cnt PtList+) (nth (1+ cnt) PtList+) 1)
(grdraw (nth cnt PtList-) (nth (1+ cnt) PtList-) 1)
(setq cnt (1+ cnt))
)
)
(t (print tempList))
)
)
((and (equal (length PtList) 1) (or (equal (car tempList) 5) (equal (car tempList) 3)))
(setq tempPt (cadr tempList))
(setq DistX (abs (- (car Pt) (car tempPt))))
(setq DistY (abs (- (cadr Pt) (cadr tempPt))))
(setq DistZ (abs (- (caddr Pt) (caddr tempPt))))
(if (equal (getvar "orthomode") 1)
(setq tempPt
(cond
((and (> DistX DistY) (> DistX DistZ))
(AlignY Pt tempPt)
)
((and (> DistY DistZ) (> DistY DistX))
(AlignX Pt tempPt)
)
((and (> DistZ DistX) (> DistZ DistY))
(AlignZ Pt tempPt)
)
)
)
)
(if (and tempPt (not (equal Pt tempPt 0.0001)))
(progn
(if (= ArSty "Double")
(setq StList (DrawStartArrowHead Pt tempPt Dist nil))
(progn
(setq Ang (angle Pt tempPt))
(setq StList
(list
(polar Pt (rem (+ Ang (* pi 0.5)) (* pi 2.0)) (* Dist 0.5))
(polar Pt (rem (+ Ang (* pi 1.5)) (* pi 2.0)) (* Dist 0.5))
)
)
)
)
(cond
((equal (car tempList) 5)
(redraw)
(if (= ArSty "Double")
(DrawStartArrowHead Pt tempPt Dist nil)
(grdraw (car StList) (cadr StList) 1)
)
(setq EndList (DrawEndArrowHead Pt tempPt Dist nil))
(grdraw (car StList) (car EndList) 1)
(grdraw (cadr StList) (cadr EndList) 1)
)
((equal (car tempList) 3)
(setq PtList+ (cons (car StList) PtList+))
(setq PtList- (cons (cadr StList) PtList-))
(setq PtList (cons tempPt PtList))
)
)
)
)
)
((and (> (length PtList) 1) (or (equal (car tempList) 5) (equal (car tempList) 3)))
(setq oPt (cadr PtList))
(setq nPt (car PtList))
(setq tempPt (cadr tempList))
(setq DistX (abs (- (car nPt) (car tempPt))))
(setq DistY (abs (- (cadr nPt) (cadr tempPt))))
(setq DistZ (abs (- (caddr nPt) (caddr tempPt))))
(if (equal (getvar "orthomode") 1)
(setq tempPt
(cond
((and (> DistX DistY) (> DistX DistZ))
(AlignY nPt tempPt)
)
((and (> DistY DistZ) (> DistY DistX))
(AlignX nPt tempPt)
)
((and (> DistZ DistX) (> DistZ DistY))
(AlignZ nPt tempPt)
)
)
)
)
(if (and tempPt (not (equal nPt tempPt 0.0001)))
(progn
(if (= ArSty "Double")
(setq StList (DrawStartArrowHead (last PtList) (nth (- (length PtList) 2) PtList) Dist nil))
(progn
(setq Ang (angle (last PtList) (nth (- (length PtList) 2) PtList)))
(setq StList
(list
(polar (last PtList) (rem (+ Ang (* pi 0.5)) (* pi 2.0)) (* Dist 0.5))
(polar (last PtList) (rem (+ Ang (* pi 1.5)) (* pi 2.0)) (* Dist 0.5))
)
)
)
)
(setq oAng (angle oPt nPt))
(setq oAng+ (rem (+ oAng (* pi 0.5)) (* pi 2.0)))
(setq oAng- (rem (+ oAng (* pi 1.5)) (* pi 2.0)))
(setq oPt+ (polar oPt oAng+ (* Dist 0.5)))
(setq oPt- (polar oPt oAng- (* Dist 0.5)))
(setq nPt+ (polar nPt oAng+ (* Dist 0.5)))
(setq nPt- (polar nPt oAng- (* Dist 0.5)))
(setq cAng (angle nPt tempPt))
(setq cAng+ (rem (+ cAng (* pi 0.5)) (* pi 2.0)))
(setq cAng- (rem (+ cAng (* pi 1.5)) (* pi 2.0)))
(if (equal (car tempList) 5)
(setq tempPt (polar tempPt (rem (+ cAng pi) (* pi 2.0)) (* Dist 2.0)))
)
(setq tempPt+ (polar tempPt cAng+ (* Dist 0.5)))
(setq tempPt- (polar tempPt cAng- (* Dist 0.5)))
(setq ntempPt+ (polar nPt cAng+ (* Dist 0.5)))
(setq ntempPt- (polar nPt cAng- (* Dist 0.5)))
(setq Pt+ (inters oPt+ nPt+ ntempPt+ tempPt+ nil))
(setq Pt- (inters oPt- nPt- ntempPt- tempPt- nil))
(if (and Pt+ Pt-)
(cond
((equal (car tempList) 5)
(redraw)
(if (= ArSty "Double")
(DrawStartArrowHead (last PtList) (nth (- (length PtList) 2) PtList) Dist nil)
(grdraw (car StList) (cadr StList) 1)
)
(setq EndList (DrawEndArrowHead (car PtList) (polar tempPt cAng (* Dist 2.0)) Dist nil))
(setq cnt 0)
(while (< (1+ cnt) (length PtList+))
(grdraw (nth cnt PtList+) (nth (1+ cnt) PtList+) 1)
(grdraw (nth cnt PtList-) (nth (1+ cnt) PtList-) 1)
(setq cnt (1+ cnt))
)
(grvecs
(list
1 (car PtList+) Pt+
1 Pt+ tempPt+
1 tempPt- Pt-
1 Pt- (car PtList-)
)
)
)
((equal (car tempList) 3)
(setq PtList+ (cons Pt+ PtList+))
(setq PtList- (cons Pt- PtList-))
(setq PtList (cons tempPt PtList))
)
)
)
)
)
)
)
)
(if (> (length PtList) 1)
(progn
(setq EndList (DrawEndArrowHead (cadr PtList) (car PtList) Dist nil))
(setq PtList+ (cons (car EndList) PtList+))
(setq PtList- (cons (cadr EndList) PtList-))
(setq EndPtList (DrawEndArrowHead (cadr PtList) (car PtList) Dist T))
(if (= ArSty "Double")
(progn
(setq StPtList (DrawStartArrowHead (last PtList) (nth (- (length PtList) 2) PtList) Dist T))
(setq tempPtList (append StPtList (append (reverse PtList+) (append EndPtList PtList-))))
)
(setq tempPtList (append (reverse PtList+) (append EndPtList PtList-)))
)
(foreach Pt (mapcar '(lambda (x) (trans x 1 0)) tempPtList)
(setq PolyPtList (cons (car Pt) PolyPtList))
(setq PolyPtList (cons (cadr Pt) PolyPtList))
)
(vla-put-Closed (vlax-invoke CurSpc 'AddLightWeightPolyline (reverse PolyPtList)) :vlax-true)
)
)
(redraw)
(vla-EndUndoMark ActDoc)
(princ)
)

11 Responses to LISP: Unique Polyline Arrow

Kevin says:

November 6, 2011 at 2:47 PM

Hi. When I load the routine and type DPA I get the following error: Error-> no function definition: VLAX-GET-ACAD-OBJECT

- AutoCAD Tips says:
  
  November 6, 2011 at 3:49 PM
  
  Sorry about that Kevin. I updated the code.
  Just as a general note, when you are testing LISP routines and see a message for the “no function definition…” and then it says any type of “VL…” message, it most likely is because it is missing one line of code. The code is (VL-LOAD-COM) and can be placed any where, preferably near the top. All that this line of code does is load the Visual Lisp functions. Another tip would be to add that line of code in your acad.lsp file so that if you have it set up to load the acad,lsp every time you open AutoCAD, this line will load the Visual Lisp and be ready to use if needed.
  
  thanks for stopping by the blog. I hope that you find it useful
  ~Greg
  
  - Kevin says:
    
    November 6, 2011 at 4:37 PM
    
    Thanks Greg, perfect
phuong says:

March 11, 2012 at 1:50 PM

thanhk Greg.. i am try a gaint

phuong says:

March 11, 2012 at 2:10 PM

hic….i try but i can’t. you can share me Lsp file (Email: maixu_phong@YAHOO.COM), thank you so much

Fiona says:

April 17, 2012 at 8:27 AM

Hi,
Sorry but this list routine would be perfect for me, however i dont know how to create it? Am i right in thinking that i save the code above in a notepad as .lsp file? I have tried that and it comes up with unknown command when i type in DPA
Thanks
Fiona

- AutoCAD Tips says:
  
  April 17, 2012 at 9:30 AM
  
  You are correct – How are you loading the lisp into the drawing? If you want to simply test it after you have saved it as a .lsp file you can drag & drop it into the drawing and then type in the command DPA to start it.
  
  Another issue might be how you are copying the code. WordPress isn’t that great for copying code. if you hover your cursor over the code area, you will see a couple of little icons appear in the upper right. Select the one that says “View source” and then select all of the code from the little window that pops up. If you select the other option “Copy to Clip board” the code ends up all messed up and unusable.
  
  ~Greg
  
acad steve says:

February 18, 2014 at 4:36 AM

Thanks Greg,

I was just searching for something like your arrow script.
I can use it very well – script loaded at once, when I tried, very good job.
I like it very much.
Can I have a request about it, maybe two?

Could You please add a function that remember the width value you add during the command, so if you draw lot of arrow with the same width in one session you wouldn’t have to retype the width value every time after restarting the command …
That would be very useful.

And the other thing is … The recent version becomes a standard polyline after completing the command,
and it is a very good thing … that’s why we use Autocad, because every object drawn in it is fully editable as we like them, this makes Autocad the No.1 CAD software forever over other stuff…
but extendedly your arrow, it would be very handy if the arrow have ‘control curves/lines’, (I could say the arrow could be ‘associative’ so after completing the command you would have an intelligent object like associative polar array pattern) and with control lines ‘under’ the arrow (in the theoretical axis of its segments) with easy grip edit function you would be able refine the arrow’s angle(s) very easyly without having to redraw the arrow from the start.

I hope you can add these functions easily to the lisp and post the updated code to us.

Thanks again
acad steve

Wicher says:

October 20, 2014 at 5:35 AM

Hi Greg,
Nice working Lisp, I’ve just a few additional questions: Is it possible to create polyline-arces instead of corners? JUst like using the arc command within the usual Polyline-command? So the created polyline with arrow-heads, becomes more smoother?

I’m curious if it’s possible…

Thanks!

Wicher

Pingback: Draw Filled Arrow | LispBox
Pingback: Draw filled arrow with option to set current layer for arrow | LispBox