(defun c:gisprog ()(setq x 200000.00)(setq y 5170000.00)(setq pt ( getpoint "\nPick a point : ")) (multiple-value-bind (q r) (floor (- (car pt) 200000) 150000) q) (setq column (+ q 1)) (multiple-value-bind (q r) (floor (- 5170000 (cadr pt)) 100000) q) (setq row (+ q 1) princ (strcat "\n250-" rtos (+ row 100) "-" rtos column))) You have used true LISP programming functions not Autocad Lisp which is a subset of the LISP programming language. Floor and multiple-value-bind do not exist.
Go back to what I posted as a start you need to look at functions like FIX to round the numbers.
actually the previous function does the same concept, but results just echo in the command line ,without label
(MAP-SHEET 250000 600000 600000 nil)
however, as mentioned in post#7 slightly modify the function which user can supply more argument to be more generic
code updated v:1.0
hanhphuc 18.01.2017
;|argument - Type ---------------------------pt - specified pointbp - Base coordinates n - scale, number mX - max X, number mY - max Y, number $ - suffix, string -------------------------Return value: A string ---------------------------example : (MAP-SHEET: '(409354.53 4937853.7) '(200000 5170000)250000 60000 60000 nil)pt,'(409354.53 4937853.7) = specified point inside the required sheetbp, '(200000 5170000) = base coordinates of sheet at upper left corner, listn, 250000 = scale 1:10000 mX, 600000 = maximum X range of sheet mY, 600000 = maximum Y range of sheet $, nil = suffix of upper level sheetreturns: list, (suffix x y z )example call:(MAP-SHEET: pt bp 250000 600000 600000 nil)'("102-2" 418370.0 5.03597e+006 0.0)|;(defun MAP-SHEET: (pt bp n mX mY $ / ls d l p k) ;hanhphuc 20.12.2016 (if (setq ls '((250000 150000 100000) (100000 60000 40000) (50000 30000 20000) (25000 15000 10000) (10000 6000 4000) (5000 3000 2000) (2000 1200 800) (1000 600 400) (500 300 200) ) l(assoc n ls) ) (progn (setq d(mapcar '- pt bp) ls (reverse (mapcar '+ '(1 -101) (mapcar ''((x y) (fix (/ x y))) d (cdr l)))) k(mapcar '+ '(1 -1) (mapcar ''((x y) (fix (/ x y))) d (cdr l))) k(- (* (1+ (cadr k)) (/ mY (caddr l))) (car k)) %(if (or (> (abs (car d)) mX) (> (abs (cadr d)) mY) (minusp (car d)) (minusp (- (cadr d)))) "\rOut of range!! " (cond ($ (apply 'strcat (append (mapcar 'itoa (list (/ (car l) 1000) k)) (list "-" $)))) ((vl-string-right-trim "-" (apply 'strcat (mapcar ''((x) (strcat (itoa x) "-")) (cons (/ (car l) 1000) (mapcar 'abs ls))) ) ) ) ) ) ) (cons (if (and % (/= % "\rOut of range!! ")) (substr % (+ 2 (vl-string-search "-" %))) "" ) pt ) ) ; progn ) )
example applied in labeling function , map-label
;|example call:(map-label "250K" ; str - message for sheet selection '(200000.005170000.00 ) ; p1 - coordinates of sheet at upper left corner 1 ; f - repeating flag, 1 or 0 7000 ; text height 250000 ; scale factor 1:250000 600000 ; maximum X range of sheet 600000 ;maximum Y range of sheet nil ; suffix of upper level sheet or N/A )|;(defun map-label (str p1 f h n mX mY $ / l p2) (prompt (strcat "\nSpecify point " str "\n")) (eval (cons (if (zerop f) 'progn 'while ) '((while (and (setq p (grread t 1 0)) (= 5 (car p)) (setq p2 (cadr p))) (setq l (MAP-SHEET: p2 p1 n mX mY $)) (if (/= (car l) "") (princ (strcat "\rSHEET " (setq str (itoa (/ n 1000))) "-" (car l) " ")) (prompt "\rOut of range! ") ) ) (entmakex (mapcar ''((a b) (cons a b)) '(0 1 10 40 50) (list "TEXT" (strcat str "-" (car l)) (trans (cdr l) 1 0) h (angle '(0. 0. 0.) (getvar 'ucsxdir)) ) ) ) ) ) )(car l) )
look at the example for map250K ,map50K, map10K, you can simply modify the argument for other sheets
;with '(200000.005170000.00 ) known base coordinates without user picking(defun c:map250K nil (if (= (getvar 'dwgname) "250k.dwg") (map-label "Sheet " '(200000.005170000.00 ) ;known upper left corner 1 7000 250000 600000 600000 nil) (alert "\nInvalid working drawing!") ) (princ) );if corner unknown, user pick example(defun c:map50K (/ pt) (if (= (getvar 'dwgname) "50k (25k-5k, 10k, 2k-1k-0.5k).dwg") (and (setq pt (getpoint "\nPick Upper Left corner of sheet - ")) (map-label "Sheet " pt 1 2000 50000 600000 600000 nil) ) (alert "\nInvalid working drawing!") ) (princ) );if known base point of 2 different sheets(defun c:map10K nil (Alert "\nSelect sheet in \nthen specify label insertion point in .. ") (if (= (getvar 'dwgname) "50k (25k-5k, 10k, 2k-1k-0.5k).dwg") (map-label "Sheet " '(928187.08 5276613.90) ;for sheet 1:10K 1 500 10000 30000 20000 (map-label "Sheet "'(200000.005170000.00 ) ;for sheet 1:50k 0200050000600000600000nil)) (alert "\nInvalid working drawing!") ) (princ) )
quite busy since last december, good luck Thank you all for your help, I've managed to write a lisp which works quite well for my requirements, so I'm putting it here for you to see..
vuongsurvey, if you need something like this, I'd be glad to help you out and modify it for your needs..
(defun c:1K ()(setq x 200000.00)(setq y 5170000.00)(setq pt ( getpoint "\nPikni točku : ")) (setq column (+ (fix (/ (- (car pt) x) 30000 ) ) 1 ) ) (setq row (+ (fix (/ (- y (cadr pt) ) 20000 ) ) 1 ) ) (setq x2 (+ x (* (fix (- column 1)) 30000) )) (setq y2 (- y (* (fix (- row 1)) 20000) )) (setq column2 (fix (/ (- (car pt) x2) 1200 ) )) (setq row2 (+ (fix (/ (- y2 (cadr pt))800 ) ) 1 ) ) (setq x3 (+ x2 (* (- column2 1) 1200))) (setq y3 (- y2 (* (- row2 1) 800))) (setq column3 (fix (/ (- (car pt) x3) 600 ) )) (setq row3 (+(fix (/ (- y3 (cadr pt))400 ) ) 1 ) ) (setq x4 (+ x3 (* (- column3 1) 600))) (setq y4 (- y3 (* (- row3 1) 400))) (setq nom (strcat "1-" (itoa (- (+ column3 (* (- row3 1) 2)) 1)) "-" (itoa (+ (+ column2 (* (- row2 1) 25)) 1)) "-" (itoa (+ row 100)) "-" (itoa column))) (setq ptrec1 (list (+ x4 1200) (- y4 400) 0)) (setq ptrec2 (list (+ x4 600) y4 0)) (setq oldosmode (getvar "osmode")) (setvar "osmode" 0) (command "_rectangle" "_from" ptrec1 "@0,0" "_from" ptrec2 "@0,0") (setvar "osmode" oldosmode) princ (strcat "1-" (itoa (- (+ column3 (* (- row3 1) 2)) 1)) "-" (itoa (+ (+ column2 (* (- row2 1) 25)) 1)) "-" (itoa (+ row 100)) "-" (itoa column)) (if (not (tblsearch "Layer" "Nomenklatura_1K")) (command "-layer" "m" "Nomenklatura_1K" "") ) (entmake (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText") (cons 10 ptrec2) (cons 71 1) ; 1 = Top Left (cons 50 0.0) ; rotation angle (cons 040 20) (cons 8 "Nomenklatura_1K") (cons 1 nom) ) ))
页:
1
[2]