This should work for a drawing with units set to "Meters". Minimal edits were made to make changes to metric distances. Lengths were converted from Inches to equivalent meter lengths. There also appeared to be a infinite loop bug if the distances between picked points was less than the minimum spacing. An additional logic check was added in that spot.
The previous block attached in this thread should work.
Code:
(defun
C:EVACROUTE
(/ *SYSVAR* *DOC* CIRC LABELPT
PLIN PLIN2 PT1 PT2 PTLIST
RTDIST SPACE BLOCK-TAGNAME LAYERCOLOR
LAYERLTYPE LAYERNAME PLINEWID TEMP DTR
ARROWLIST BLOCK-ARROW CIRC-CENTER CIRC-LL CIRC-UR
PLINEWIDTH SPACE FINDSPACE GDESC GNAME
GROUPDESC GROUPNAME SPACE TAG
groupss
)
;;; (C) Richard Lawrence
;;; Provided as is. No Warranty. Use at your own risk.
;;; Permission granted to modify to suit needs.
;;; Only system variables changed are listed under
;;; Save Settings
;;; Evacuation Route V. 1.02 - Metric
;;; Replaced values to work for "Meter" based units
;;; Added check to flow arrows for spacing is greater than
;;; minimum spacing
;;; Evacuation Route V. 1.01
;;; Removed requirement of AutoCAD 2005+
;;; Added Flow Arrows construction
;;; Combined evacuation route entities into a group
;;||||||||||||||||||||||||||||||||||
;; Get current space
;; Function provided by others
;;||||||||||||||||||||||||||||||||||
(defun
FINDSPACE
(/ *DOC*)
(vl-load-com)
(setq *DOC* (vla-get-activedocument (vlax-get-acad-object)))
(setq SPACE (if (= 1 (vla-get-activespace *DOC*))
(vla-get-modelspace *DOC*) ;we're in modelspace
(if (= (vla-get-mspace *DOC*) :vlax-true)
(vla-get-modelspace *DOC*) ;we're in modelspace
;thru paperspace VPort
(vla-get-paperspace *DOC*) ;we're in paperspace
)
)
)
)
;;||||||||||||||||||||||||||||||||||
;; Error Handler
;; Function provided by others
;;||||||||||||||||||||||||||||||||||
(defun
*ERROR*
(MSG)
(if (not
(member
MSG
'("Function cancelled" "console break" "quit / exit abort")
)
)
(alert MSG)
)
(RESTORE_SYS)
(command "_.undo" "end")
(princ)
)
;;||||||||||||||||||||||||||||||||||
;; Set and Save System Variables
;; Function provided by others
;;||||||||||||||||||||||||||||||||||
(defun
SAVE_SYS
(SYSVAR)
(setq *SYSVAR* '()) ; global var list of saved values
(repeat (length SYSVAR)
(setq *SYSVAR*
(append
*SYSVAR*
(list (list (car SYSVAR) (getvar (car SYSVAR))))
)
)
(setq SYSVAR (cdr SYSVAR))
)
)
;;||||||||||||||||||||||||||||||||||
;; Restore System Variables
;; Function provided by others
;;||||||||||||||||||||||||||||||||||
(defun
RESTORE_SYS
()
(and (listp *SYSVAR*)
(repeat (length *SYSVAR*)
(setvar (caar *SYSVAR*) (cadar *SYSVAR*))
(setq *SYSVAR* (cdr *SYSVAR*))
)
)
)
;;||||||||||||||||||||||||||||||||||
;; Create Layer
;; Function provided by others
;;||||||||||||||||||||||||||||||||||
(defun
MLAYC
(LAYNAME COLOR)
(if (= NIL (tblsearch "layer" LAYNAME)) ; check if LAYER exist
(command "-layer" "m" LAYNAME "c" COLOR "" "")
;if not exist, create LAYER
(progn
(command "-layer" "t" LAYNAME "") ; Thaw LAYER
(command "-layer" "on" LAYNAME "") ; Turn on LAYER
(command "-layer" "s" LAYNAME "") ; Set LAYER CURRENT
)
)
)
;;; Draw Flow Arrows
(defun
FLOWARROW
(PT1 PT2 / ANG ARROWLENGTH
ARROWWIDTH ARW ARWLIST CNT DIST
EPNT EPNTL EPNTR MINSPACING PNT
REVANG SPACE SPACING VARIANCE
)
(setq ARROWLENGTH
0.3048
ARROWWIDTH
0.2286
MINSPACING
1.2192
VARIANCE
(* 0.25 MINSPACING)
)
(setq DIST (distance PT1 PT2)
CNT 2
SPACING (/ DIST CNT)
ANG (angle PT1 PT2)
REVANG (angle PT2 PT1)
SPACE (FINDSPACE)
)
(if (>= spacing minspacing)
(while (not (and (>= SPACING (- MINSPACING VARIANCE))
(<= SPACING (+ MINSPACING VARIANCE))
)
)
(setq CNT (1+ CNT)
SPACING (/ DIST CNT)
)
)
)
(setq PNT pt1); (polar PT1 REVANG (- (* 0.5 SPACING) (* 0.5 arrowlength))))
(repeat CNT
(setq PNT (polar PNT ANG SPACING)
EPNT (polar PNT REVANG ARROWLENGTH)
EPNTL (polar EPNT (+ ANG (DTR 90.0)) (* 0.5 ARROWWIDTH))
EPNTR (polar EPNT (- ANG (DTR 90.0)) (* 0.5 ARROWWIDTH))
ARW (vlax-invoke SPACE 'ADDSOLID PNT EPNTL EPNTR PNT)
ARW (entlast)
)
(if ARWLIST
(setq ARWLIST (append ARWLIST (list ARW)))
(setq ARWLIST (list ARW))
)
)
)
;;; End Draw Flow Arrows
;;; Degrees to Radians
(defun DTR (A) (* pi (/ A 180.0)))
;;; utility to insert a linetype if not already in drawing
(defun
INSLTYPE
(LTYPE LTFILE /)
(if (not (tblsearch "ltype" LTYPE))
(command "linetype" "l" LTYPE LTFILE "")
)
)
;;__ Save Settings___
(SAVE_SYS
'("CMDECHO" "CLAYER" "OSMODE" "PLINEWID")
)
;;__ Set Settings for Function __
(setvar "CMDECHO" 0)
(command "_.UNDO" "BEgin")
(setq LAYERNAME
"EVAC-ROUTE"
LAYERCOLOR
"7"
LAYERLTYPE
"HIDDEN"
PLINEWIDTH
0.0381
BLOCK-TAGNAME
"EVACUATION DISTANCE TAG"
GROUPNAME
"EVAC-RT"
GROUPDESC
"Evacuation_Route"
)
(if (not GROUPNO)
(setq GROUPNO 65)
)
(setvar "PLINEWID" PLINEWIDTH)
(MLAYC LAYERNAME LAYERCOLOR)
(if (not
(= "Continuous"
(cdr (assoc 6 (setq TEMP (tblsearch "Layer" "EVAC-ROUTE"))))
)
)
(command "-layer" "ltype" "Continuous" LAYERNAME "")
)
;;; insert block definition if not already in drawing
(if (not (tblsearch "block" BLOCK-TAGNAME))
(progn
(if (findfile BLOCK-TAGNAME)
(command "-insert" BLOCK-TAGNAME NIL)
(progn
(alert
(strcat
"Block: "
BLOCK-TAGNAME
" not found in search path. Verify location and retry."
)
)
(quit)
)
)
)
(progn
(setq SPACE (FINDSPACE))
(prompt "\nCreate Evacuation Route")
(setq PT1 (getpoint "\nSpecify Beginning of Route: ")
PTLIST (list (car PT1) (cadr PT1))
PT2 (getpoint PT1 "\nSpecify next point: ")
RTDIST 0.0
ARROWLIST NIL
)
(while PT2
(if PLIN
(entdel PLIN)
)
(setq RTDIST (+ RTDIST (distance PT2 PT1))
PTLIST (append PTLIST (list (car PT2) (cadr PT2)))
PLIN (vlax-invoke SPACE 'ADDLIGHTWEIGHTPOLYLINE PTLIST)
PLIN (entlast)
)
(if ARROWLIST
(setq ARROWLIST (append ARROWLIST (FLOWARROW PT1 PT2)))
(setq ARROWLIST (FLOWARROW PT1 PT2))
)
(setq PT1 PT2
PT2 (getpoint PT1 "\nSpecify next point: ")
)
)
(setvar "osmode" 512)
(setq LABELPT (getpoint "\nSpecify label location: "))
(setq CIRC (vlax-invoke SPACE 'ADDCIRCLE LABELPT 0.3048)
CIRC (entlast)
)
(setq CIRC-CENTER
(cdr (assoc 10 (entget CIRC)))
CIRC-LL
(polar (polar CIRC-CENTER (DTR 270.0) 0.3556)
(DTR 180.0)
0.3556
)
CIRC-UR
(polar (polar CIRC-CENTER (DTR 90.0) 0.3556) (DTR 0.0) 0.3556)
)
(command "zoom" "Window" CIRC-LL CIRC-UR)
(command "trim" CIRC "" LABELPT "")
(setq PLIN2 (entget (entlast))
PLIN (entget PLIN)
)
(if (assoc 43 PLIN)
(setq PLIN (subst (cons 43 PLINEWIDTH) (assoc 43 PLIN) PLIN))
(setq PLIN (append PLIN (list (cons 43 PLINEWIDTH))))
)
(if (assoc 43 PLIN2)
(setq PLIN2 (subst (cons 43 PLINEWIDTH) (assoc 43 PLIN2) PLIN2))
(setq PLIN2 (append PLIN2 (list (cons 43 PLINEWIDTH))))
)
(entmod PLIN)
(entmod PLIN2)
(entdel CIRC)
(command
"-insert"
BLOCK-TAGNAME
LABELPT
1
1
0
""
)
(setq TAG (entlast))
(vla-put-textstring
(vlax-ename->vla-object (entnext (entlast)))
(rtos RTDIST 2 0)
)
(setq GROUPLIST (append
ARROWLIST
(list (cdr (assoc -1 PLIN)) (cdr (assoc -1 PLIN2)) TAG)
)
GNAME (strcat GROUPNAME "-" (chr GROUPNO))
GDESC (strcat GROUPDESC "_" (chr GROUPNO))
GROUPNO (1+ GROUPNO)
)
(setq groupss (ssadd))
(foreach n grouplist (setq groupss (ssadd n groupss)))
(command "-group" "Create" GNAME GDESC GROUPss "")
(command "zoom" "Previous")
(INSLTYPE LAYERLTYPE "acad.lin")
(command "-layer" "ltype" LAYERLTYPE LAYERNAME "")
)
)
(command "_.UNDO" "End")
(RESTORE_SYS)
(princ)
)
Re: Distance Lisp Routine Help
Posting Permissions
Reply With Quote