;;; Inpirated by http://autocadtips1.com/2011/05/09/lisp-unique-polyline-arrow/

;;; Modified by Igal Averbuh 2016

```
```(defun c:DFA (/ 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)

(if (not (tblsearch "LAYER" "TPZ-TXT"))

(command "._-layer" "NEW" "TPZ-TXT" "C" "1" "TPZ-TXT" "" )

(command "._-layer" "ON" "TPZ-TXT" "T" "TPZ-TXT" "")

)

(command "._-layer" "SET" "TPZ-TXT" "" )

(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 "\nSelect arrowhead type [Single arrowhead/Double arrowhead]: "))(if (= (type Dist) 'STR)

(progn

(setq ArSty Dist)

(setq Dist (getdist "\n Enter arrow width by two points: "))

)

(setq ArSty "Single")

)

(setq Pt (getpoint "\n Select arrow starting point (not an arrowhead 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 ( 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 ( (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)

(command "-hatch" "s" "l" "" "p" "s" "co" "t" "7,7,7" "" )

)

)

(redraw)

(vla-EndUndoMark ActDoc)

(princ)

)

(c:dfa)

Advertisements

```
```