Leaderboard

@3dwannab I've modified my latest version to be just slightly more reliable... My mistake was in sub (removetrailingzeros)... And plus I changed ' (apostrophes) with adequate (function) or (quote) calls... That's all, but I haven't tested it yet on more complex DWGs... Here is the code : (defun c:savehatchfromstrcur ( / *error* trim0trailing trimlineto80chr acet-geom-ss-extents-accurate intrecsang detk detdxdy detaall aall chksurrpts getp cmde s boundary ch minp maxp w h lil fuzz fuzzz tol des fn a x y p ip dx dy l v k i ooo g ll f al scf ww hh dxdy dyy kk ddx ddy n ) (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com)) (defun *error* ( m ) (if cmde (setvar (quote cmdecho) cmde)) (if m (prompt m)) (princ) ) (defun trim0trailing ( str / lst flag ) (setq lst (vl-string->list str)) (if (vl-position 46 lst) (progn (setq lst (reverse lst)) (while (and (not flag) (or (= (car lst) 46) (= (car lst) 48))) (if (= (car lst) 46) (setq flag t) ) (setq lst (cdr lst)) ) (setq lst (reverse lst)) ) ) (vl-list->string lst) ) (defun trimlineto80chr ( str / lst ) (setq lst (vl-string->list str)) (setq lst (reverse lst)) (while (> (length lst) 80) (setq lst (cdr lst)) ) (setq lst (reverse lst)) (vl-list->string lst) ) (defun acet-geom-ss-extents-accurate ( ss / layers i lck e layer minp maxp minl maxl ) (if ss (progn (setq layers (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))) (repeat (setq i (sslength ss)) (setq lck nil) (setq e (ssname ss (setq i (1- i)))) (if (= (vla-get-lock (vla-item layers (setq layer (vla-get-layer (vlax-ename->vla-object e))))) :vlax-true) (progn (vla-put-lock (vla-item layers layer) :vlax-false) (setq lck t) ) ) (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar (function (lambda ( vector origin ) (append (trans vector 1 0 t) (list origin)))) (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)) (trans (list 0.0 0.0 0.0) 0 1)) (list (list 0.0 0.0 0.0 1.0))))) (vla-getboundingbox (vlax-ename->vla-object e) (quote minp) (quote maxp)) (vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix (append (mapcar (function (lambda ( vector origin ) (append (trans vector 0 1 t) (list origin)))) (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)) (trans (list 0.0 0.0 0.0) 1 0)) (list (list 0.0 0.0 0.0 1.0))))) (if lck (vla-put-lock (vla-item layers layer) :vlax-true) ) (mapcar (function set) (list (quote minp) (quote maxp)) (mapcar (function safearray-value) (list minp maxp))) (setq minl (cons minp minl) maxl (cons maxp maxl)) ) (list (apply (function mapcar) (cons (function min) minl)) (apply (function mapcar) (cons (function max) maxl))) ) ) ) (defun intrecsang ( minp w h a / r1 r2 r3 r4 d li ip ) (setq r1 (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 38 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (mapcar (function +) minp (list w 0.0)) 1 0)) (cons 10 (trans (mapcar (function +) minp (list w h)) 1 0)) (cons 10 (trans (mapcar (function +) minp (list 0.0 h)) 1 0)) (list 210 0.0 0.0 1.0)))) (setq r2 (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 38 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (mapcar (function +) minp (list (- w) 0.0)) 1 0)) (cons 10 (trans (mapcar (function +) minp (list (- w) h)) 1 0)) (cons 10 (trans (mapcar (function +) minp (list 0.0 h)) 1 0)) (list 210 0.0 0.0 1.0)))) (setq r3 (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 38 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (mapcar (function +) minp (list (- w) 0.0)) 1 0)) (cons 10 (trans (mapcar (function +) minp (list (- w) (- h))) 1 0)) (cons 10 (trans (mapcar (function +) minp (list 0.0 (- h))) 1 0)) (list 210 0.0 0.0 1.0)))) (setq r4 (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 38 0.0) (cons 10 (trans minp 1 0)) (cons 10 (trans (mapcar (function +) minp (list w 0.0)) 1 0)) (cons 10 (trans (mapcar (function +) minp (list w (- h))) 1 0)) (cons 10 (trans (mapcar (function +) minp (list 0.0 (- h))) 1 0)) (list 210 0.0 0.0 1.0)))) (setq d (sqrt (+ (expt w 2) (expt h 2)))) (setq li (entmakex (list (cons 0 "LINE") (cons 10 (trans (polar minp a 1e-4) 1 0)) (cons 11 (trans (polar minp a d) 1 0))))) (cond ( (equal a 0.0 1e-8) (setq ip (trans (polar minp 0.0 w) 1 0)) ) ( (equal a (* 0.5 pi) 1e-8) (setq ip (trans (polar minp (* 0.5 pi) h) 1 0)) ) ( (equal a pi 1e-8) (setq ip (trans (polar minp pi w) 1 0)) ) ( (equal a (* 1.5 pi) 1e-8) (setq ip (trans (polar minp (* 1.5 pi) h) 1 0)) ) ( t (cond ( (setq ip (vlax-invoke (vlax-ename->vla-object r1) (quote intersectwith) (vlax-ename->vla-object li) acextendnone)) ) ( (setq ip (vlax-invoke (vlax-ename->vla-object r2) (quote intersectwith) (vlax-ename->vla-object li) acextendnone)) ) ( (setq ip (vlax-invoke (vlax-ename->vla-object r3) (quote intersectwith) (vlax-ename->vla-object li) acextendnone)) ) ( (setq ip (vlax-invoke (vlax-ename->vla-object r4) (quote intersectwith) (vlax-ename->vla-object li) acextendnone)) ) ) ) ) (mapcar (function entdel) (list r1 r2 r3 r4 li)) (setq ip (mapcar (function +) (list 0.0 0.0) (trans ip 0 1))) ) (defun detk ( minp v w h fuzz kk / vx vy k ) (setq vx (car v) vy (cadr v)) (cond ( (and (equal (abs (car v)) w 1e-6) (equal (abs (cadr v)) h 1e-6)) (setq k 1) ) ( (or (and (equal vx 0.0 1e-6) (equal (abs vy) h 1e-6)) (and (equal vy 0.0 1e-6) (equal (abs vx) w 1e-6))) (setq k 1) ) ( (< (abs vx) w) (while (not (or (equal (rem (abs (- (cadr (inters (mapcar (function +) minp (list (* w (setq kk ((if (minusp vx) 1- 1+) kk))) 0.0)) (polar (mapcar (function +) minp (list (* w kk) 0.0)) (* 0.5 pi) 1.0) minp (mapcar (function +) minp v) nil)) (cadr minp))) h) 0.0 fuzz) (equal (rem (abs (- (cadr (inters (mapcar (function +) minp (list (* w kk) 0.0)) (polar (mapcar (function +) minp (list (* w kk) 0.0)) (* 0.5 pi) 1.0) minp (mapcar (function +) minp v) nil)) (cadr minp))) h) h fuzz)))) (setq k (fix (+ 0.5 (/ (abs (- (cadr (inters (mapcar (function +) minp (list (* w kk) 0.0)) (polar (mapcar (function +) minp (list (* w kk) 0.0)) (* 0.5 pi) 1.0) minp (mapcar (function +) minp v) nil)) (cadr minp))) h)))) ) ( (< (abs vy) h) (while (not (or (equal (rem (abs (- (car (inters (mapcar (function +) minp (list 0.0 (* h (setq kk ((if (minusp vy) 1- 1+) kk))))) (polar (mapcar (function +) minp (list 0.0 (* h kk))) 0.0 1.0) minp (mapcar (function +) minp v) nil)) (car minp))) w) 0.0 fuzz) (equal (rem (abs (- (car (inters (mapcar (function +) minp (list 0.0 (* h kk))) (polar (mapcar (function +) minp (list 0.0 (* h kk))) 0.0 1.0) minp (mapcar (function +) minp v) nil)) (car minp))) w) w fuzz)))) (setq k (fix (+ 0.5 (/ (abs (- (car (inters (mapcar (function +) minp (list 0.0 (* h kk))) (polar (mapcar (function +) minp (list 0.0 (* h kk))) 0.0 1.0) minp (mapcar (function +) minp v) nil)) (car minp))) w)))) ) ) (list k kk) ) (defun detdxdy ( k / ddx ddy ) (setq ww (fix (/ (+ (abs (car (mapcar (function *) v (list k k)))) 1e-2) w)) hh (fix (/ (+ (abs (cadr (mapcar (function *) v (list k k)))) 1e-2) h))) (cond ( (< 0.0 a (* 0.5 pi)) (setq ooo (mapcar (function +) minp (list (* w ww) (* h hh)))) ) ( (< (* 0.5 pi) a pi) (setq ooo (mapcar (function +) minp (list (* (- w) ww) (* h hh)))) ) ( (< pi a (* 1.5 pi)) (setq ooo (mapcar (function +) minp (list (* (- w) ww) (* (- h) hh)))) ) ( (< (* 1.5 pi) a (* 2.0 pi)) (setq ooo (mapcar (function +) minp (list (* w ww) (* (- h) hh)))) ) ) (cond ( (or (equal a 0.0 1e-6) (equal a pi 1e-6) (equal a (* 2.0 pi) 1e-6)) (setq p (mapcar (function +) (car li) (list 0.0 h))) ) ( (or (equal a (* 0.5 pi) 1e-6) (equal a (* 1.5 pi) 1e-6)) (setq p (mapcar (function +) (car li) (list w 0.0))) ) ( (and (equal (abs (car v)) w 1e-6) (equal (abs (cadr v)) h 1e-6)) (setq p (getp minp a w h 1 1)) ) ( t (setq p (mapcar (function +) (car li) (mapcar (function -) ooo minp))) ) ) (setq ip (inters p (polar p (+ a (* 0.5 pi)) 1.0) (car li) (polar (car li) a 1.0) nil)) (setq ddx (distance (car li) ip) ddy (if (equal (rem (+ a (* 0.5 pi)) (* 2.0 pi)) (angle ip p) 1e-6) (distance ip p) (- (distance ip p)))) (list ddx ddy) ) (defun detaall ( o w h n / unique uniqueang k kk oo l1 l2 l3 l4 ) (defun unique ( l ) (if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l)))) ) (defun uniqueang ( l ) (if l (cons (car l) (uniqueang (vl-remove-if (function (lambda ( x ) (equal (car x) (caar l) 1e-6))) l)))) ) (setq k 0) (repeat n (setq k (1+ k)) (setq kk -1) (repeat (1+ k) (setq kk (1+ kk)) (setq oo (mapcar (function +) o (list (* k w) (* kk h)))) (setq l1 (cons oo l1)) ) (repeat k (setq kk (1- kk)) (setq oo (mapcar (function +) o (list (* kk w) (* k h)))) (setq l1 (cons oo l1)) ) ) (setq l1 (reverse l1)) (setq l2 (mapcar (function (lambda ( x ) (mapcar (function +) o (list (- (car (mapcar (function -) x o))) (cadr (mapcar (function -) x o)))))) l1)) (setq l3 (mapcar (function (lambda ( x ) (mapcar (function +) o (list (- (car (mapcar (function -) x o))) (- (cadr (mapcar (function -) x o))))))) l1)) (setq l4 (mapcar (function (lambda ( x ) (mapcar (function +) o (list (car (mapcar (function -) x o)) (- (cadr (mapcar (function -) x o))))))) l1)) (uniqueang (mapcar (function (lambda ( x ) (list (angle o x) (distance o x)))) (unique (append l1 l2 l3 l4)))) ) (defun chksurrpts ( dx dy aall / chkdxdy ) (defun chkdxdy ( dx dy aa ll / p pp r ) (setq p (polar (polar (car li) a dx) (+ a (* 0.5 pi)) dy)) (setq pp (inters (polar (car li) a (- l g)) (polar (polar (car li) a (- l g)) aa 1.0) (car li) p nil)) (if (and pp (or (equal (rem ll (distance (polar (car li) a (- l g)) pp)) 0.0 5e-2) (equal (rem ll (distance (polar (car li) a (- l g)) pp)) (distance (polar (car li) a (- l g)) pp) 5e-2))) (setq r t) ) r ) (vl-every (function (lambda ( x ) (chkdxdy dx dy (car x) (cadr x)))) aall) ) (defun getp ( o a w h ww hh / r c d p pp dd ) (setq d 1e+99) (cond ( (< 0.0 a (* 0.5 pi)) (setq r -1) (repeat (1+ ww) (setq c -1) (setq r (1+ r)) (repeat (1+ hh) (setq c (1+ c)) (setq p (mapcar (function +) o (list (* r w) (* c h)))) (if (and (or (/= r 0) (/= c 0)) (or (/= r ww) (/= c hh)) (< (setq dd (distance p (inters p (polar p (+ a (* 0.5 pi)) 1.0) o (polar o a 1.0) nil))) d)) (setq pp p d dd) ) ) ) ) ( (< (* 0.5 pi) a pi) (setq r -1) (repeat (1+ ww) (setq c -1) (setq r (1+ r)) (repeat (1+ hh) (setq c (1+ c)) (setq p (mapcar (function +) o (list (* r (- w)) (* c h)))) (if (and (or (/= r 0) (/= c 0)) (or (/= r ww) (/= c hh)) (< (setq dd (distance p (inters p (polar p (+ a (* 0.5 pi)) 1.0) o (polar o a 1.0) nil))) d)) (setq pp p d dd) ) ) ) ) ( (< pi a (* 1.5 pi)) (setq r -1) (repeat (1+ ww) (setq c -1) (setq r (1+ r)) (repeat (1+ hh) (setq c (1+ c)) (setq p (mapcar (function +) o (list (* r (- w)) (* c (- h))))) (if (and (or (/= r 0) (/= c 0)) (or (/= r ww) (/= c hh)) (< (setq dd (distance p (inters p (polar p (+ a (* 0.5 pi)) 1.0) o (polar o a 1.0) nil))) d)) (setq pp p d dd) ) ) ) ) ( t (setq r -1) (repeat (1+ ww) (setq c -1) (setq r (1+ r)) (repeat (1+ hh) (setq c (1+ c)) (setq p (mapcar (function +) o (list (* r w) (* c (- h))))) (if (and (or (/= r 0) (/= c 0)) (or (/= r ww) (/= c hh)) (< (setq dd (distance p (inters p (polar p (+ a (* 0.5 pi)) 1.0) o (polar o a 1.0) nil))) d)) (setq pp p d dd) ) ) ) ) ) pp ) (setq cmde (getvar (quote cmdecho))) (setvar (quote cmdecho) 0) (alert "SAVE DWG BEFORE APPLYING THIS ROUTINE...\nSet SNAP to ON and draw boundary rectangle and hatching geometry (lines) inside boundary. IF YOU HAVE STRAIGHT POLYLINES INSIDE BOUNDARY, YOU MUST EXPLODE THEM TO LINES AND RESTART ROUTINE... SNAP must be 0.1x0.1 or greater - best 0.5x0.5...") (while (or (prompt "\nSelect boundary rectangle and hatching geometry...") (not (setq s (ssget (list (cons -4 "<or") (cons 0 "LINE") (cons -4 "<and") (cons 0 "LWPOLYLINE") (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>") (cons -4 "and>") (cons -4 "or>"))))) (if s (not (equal (mapcar (function last) (acet-geom-ss-extents-accurate s)) (list 0.0 0.0) 1e-6)) ) ) (prompt "\nEmpty sel set or selected geometry not planar with WCS...") ) (setq boundary (ssname (ssget "_C" (setq oo (car (acet-geom-ss-extents-accurate s))) oo (list (cons 0 "LWPOLYLINE") (cons 90 4) (cons -4 "&=") (cons 70 1) (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>"))) 0)) (initget "Yes No") (setq ch (getkword "\nDo you want to implement boundary into hatch [Yes/No] <No> : ")) (mapcar (function set) (list (quote minp) (quote maxp)) (acet-geom-ss-extents-accurate (ssadd boundary))) (setq w (- (car maxp) (car minp)) h (- (cadr maxp) (cadr minp))) (if (= ch "Yes") (progn (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) minp) (mapcar (function +) (list w 0) minp)) lil)) (setq lil (cons (list (mapcar (function +) (list w 0) minp) (mapcar (function +) (list 0.0 0.0) maxp)) lil)) (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) maxp) (mapcar (function +) (list (- w) 0) maxp)) lil)) (setq lil (cons (list (mapcar (function +) (list (- w) 0) maxp) (mapcar (function +) (list 0.0 0.0) minp)) lil)) ) ) (ssdel boundary s) (foreach e (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s))) (setq lil (cons (list (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 (entget e))) 0 1)) (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 11 (entget e))) 0 1))) lil)) ) (setq lil (reverse lil)) (initget 6) (setq fuzz (getreal "\nSpecify fuzz factor for determining gap - smallest fuzz <1e-6> : ")) (if (null fuzz) (setq fuzz 1e-6) ) (initget 6) (setq tol (getreal "\nSpecify tolerance value for fullfilling gap - delta-y ratio expression (< (/ (abs g) (abs dy)) tol) - biggest tol ; Note that if this value is too big ACAD may not display hatch even though it's correct, so you must lower this value - smaller than with your previous attempt, but when you find solution for displaying hatch - it may not be so accurate, so you should raise value - all until you find satisfactory solution for your pattern - default is <3.3e+8> : ")) (if (null tol) (setq tol 3.3e+8) ) (initget 6) (setq n (getint "\nSpecify number of checking rings around origin point (1 - less reliable - fastest; 2 - normal; 3 - more reliable - slowest; ... ) <3> : ")) (if (null n) (setq n 3) ) (setq fuzzz fuzz) (setq aall (detaall minp w h n)) (initget 1) (setq des (getstring "\nSpecify description : ")) (while (or (not (snvalid des)) (> (strlen des) 8)) (prompt "\nSpecified string not valid, or number of characters greater than 8...") (initget 1) (setq des (getstring "\nSpecify description : ")) ) (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar (quote roamablerootprefix)) "support\\") "pat" 1)) (while (or (not (snvalid (vl-filename-base fn))) (> (strlen (vl-filename-base fn)) 8)) (prompt "\nSpecified filename not valid, or number of characters greater than 8...") (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar (quote roamablerootprefix)) "support\\") "pat" 1)) ) (foreach li lil (setq a (angle (car li) (cadr li))) (setq l (distance (car li) (cadr li))) (setq x (caar li) y (cadar li)) (setq ip (intrecsang minp w h a)) (setq v (mapcar (function -) ip minp)) (setq fuzz fuzzz) (setq k (detk minp v w h (setq fuzz (* 100000.0 fuzz)) 0)) (setq kk k) (gc) (while (and (/= (car k) 1) (< (car k) 3000) (> fuzz fuzzz)) (setq kk k) (setq k (detk minp v w h (setq fuzz (/ fuzz 10.0)) (if (or (and (< (abs (car v)) w) (minusp (car v))) (and (< (abs (cadr v)) h) (minusp (cadr v)))) (1+ (cadr k)) (1- (cadr k))))) (gc) ) (if (/= (car k) 1) (setq k kk) ) (setq g (- (- (distance minp (mapcar (function +) minp (mapcar (function *) v (list (car k) (car k))))) l))) (setq dyy 1e+99) (setq i 0) (setq dx nil dy nil) (repeat (if (= (car k) 1) 1 (1- (car k))) (if (and (< (abs (cadr (setq dxdy (detdxdy (setq i (1+ i)))))) (abs dyy)) (> (abs (cadr dxdy)) 1e-8) (< (/ (abs g) (abs (cadr dxdy))) tol)) (progn (setq ddx (car dxdy) ddy (cadr dxdy) dyy ddy) (if (or (not (or (equal a 0.0 1e-6) (equal a (* 0.5 pi) 1e-6) (equal a pi 1e-6) (equal a (* 1.5 pi) 1e-6) (equal a (* 2.0 pi) 1e-6))) (/= (car k) 1)) (if (chksurrpts ddx ddy aall) (setq dx ddx dy ddy) ) (setq dx ddx dy ddy) ) ) ) ) (gc) (if (and (null dx) (null dy)) (progn (setq k (detk minp v w h fuzzz (if (or (and (< (abs (car v)) w) (minusp (car v))) (and (< (abs (cadr v)) h) (minusp (cadr v)))) (1+ (cadr k)) (1- (cadr k))))) (gc) (setq g (- (- (distance minp (mapcar (function +) minp (mapcar (function *) v (list (car k) (car k))))) l))) (repeat (- (1- (car k)) i) (if (and (< (abs (cadr (setq dxdy (detdxdy (setq i (1+ i)))))) (abs dyy)) (> (abs (cadr dxdy)) 1e-8) (< (/ (abs g) (abs (cadr dxdy))) tol)) (progn (setq ddx (car dxdy) ddy (cadr dxdy) dyy ddy) (if (not (or (equal a 0.0 1e-6) (equal a (* 0.5 pi) 1e-6) (equal a pi 1e-6) (equal a (* 1.5 pi) 1e-6) (equal a (* 2.0 pi) 1e-6))) (if (chksurrpts ddx ddy aall) (setq dx ddx dy ddy) ) (setq dx ddx dy ddy) ) ) ) ) (gc) ) ) (if (and (null dx) (null dy)) (if (and ddx ddy) (setq dx ddx dy ddy) ) ) (setq ll (cons (list (cvunit a "radian" "degree") x y dx dy l g) ll)) (setq al (cons (cvunit a "radian" "degree") al)) ) (setq ll (reverse ll)) (setq al (reverse al)) (initget 6) (setq scf (getreal "\nSpecify scale factor for multiplication hatch data <1.0> : ")) (if (null scf) (setq scf 1.0) ) (setq ll (mapcar (function (lambda ( x ) (mapcar (function (lambda ( y ) (* y scf))) x))) ll)) (setq f (open fn "w")) (write-line (strcat "*" (vl-filename-base fn) ", " des) f) (setq k -1) (foreach li ll (setq k (1+ k)) (if (zerop (last li)) (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 8)) "," (trim0trailing (rtos (cadr li) 2 8)) "," (trim0trailing (rtos (caddr li) 2 8)) "," (trim0trailing (rtos (nth 3 li) 2 8)) "," (trim0trailing (rtos (nth 4 li) 2 8)))) f) (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 8)) "," (trim0trailing (rtos (cadr li) 2 8)) "," (trim0trailing (rtos (caddr li) 2 8)) "," (trim0trailing (rtos (nth 3 li) 2 8)) "," (trim0trailing (rtos (nth 4 li) 2 8)) "," (trim0trailing (rtos (nth 5 li) 2 8)) "," (trim0trailing (rtos (nth 6 li) 2 8)))) f) ) ) (close f) (*error* nil) ) Regards, M.R. HTH.