Leaderboard

@Steven P, glad im not the only one. but when i use the code manualy, it works like a charm. When fired with a LISP-command, is refuses.

What do you mean: polyline with layer? Anyway, command MPH (for Hatch Multiple Polylines) the pattern is ANSI31; you can change it in the function hatch_closed_polyline ;; Hatch Multiple Polylines (defun c:hmp ( / ss sc i) (setq sc (getreal "\nScale: ")) ;; or do: (setq sc 1.0) ;; or whatever factor (prompt "\nSelect Closed Polylines to Hatch: ") (setq ss (ssget (list (cons 0 "*POLYLINE") ))) ;;(cons 70 1) ;;(hatch_closed_polyline ss sc) (setq i 0) (repeat (sslength ss) (hatch_closed_polyline (ssadd (ssname ss i)) sc) (setq i (+ i 1)) ) ) ;; slightly modified from this code: ;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/entmake-hatch-with-base-point-or-object-polyline-entity-name/m-p/8703197#M383362 (defun hatch_closed_polyline (ss sc / cnt e hList pat) (setq pat "ANSI31") ;; adapt to your needs (if (= 0.0 sc) (setq sc 1.0) ) (setq cnt (sslength ss)) (while (<= 0 (setq cnt (1- cnt))) (setq e (ssname ss cnt)) (if (setq tmp (CreateHatchList e)) (setq hList (cons tmp hList)) );if );while (setq hList (reverse hList)) (if (entmakex-hatch hList 0.0 pat sc) (prompt "\nSuccess!") (prompt "\n...Failure.") );if (princ) );defun (defun CreateHatchList (e / i j pList found) (foreach i (entget e) (if (= 10 (car i)) (progn (setq pList (cons i pList)) (setq found nil j (member i (entget e))) (while (and (not found) (< 0 (length j))) (if (= 42 (car (car j))) (setq pList (cons (car j) pList) found t) );if (setq j (cdr j)) );while );progn );if );foreach (reverse pList) );defun ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun entmakex-hatch (l a n s) ;; By ElpanovEvgeniy ;; L - list point ;; A - angle hatch ;; N - name pattern ;; S - scale ;; return - hatch ename (entmakex (apply 'append (list (list '(0 . "HATCH") '(100 . "AcDbEntity") '(410 . "Model") '(100 . "AcDbHatch") '(10 0.0 0.0 0.0) '(210 0.0 0.0 1.0) (cons 2 n) (if (= n "SOLID") '(70 . 1) '(70 . 0) ) ;_ if '(71 . 0) (cons 91 (length l)) ) ;_ list (apply 'append (mapcar '(lambda (a) (apply 'append (list (list '(92 . 7) '(72 . 1) '(73 . 1) (cons 93 (/ (length a) 2))) (mapcar '(lambda (b) b) a) '((97 . 0)) ) ;_ list ) ;_ apply ) ;_ lambda l ) ;_ mapcar ) ;_ apply (list '(75 . 0) '(76 . 1) (cons 52 a) (cons 41 s) '(77 . 0) '(78 . 1) (cons 53 a) '(43 . 0.) '(44 . 0.) '(45 . 1.) '(46 . 1.) '(79 . 0) '(47 . 1.) '(98 . 2) '(10 0. 0. 0.0) '(10 0. 0. 0.0) '(451 . 0) '(460 . 0.0) '(461 . 0.0) '(452 . 1) '(462 . 1.0) '(453 . 2) '(463 . 0.0) '(463 . 1.0) '(470 . "ANSI31") ) ;_ list ) ;_ list ) ;_ apply ) ;_ entmakex ) ;_ defun

Hello everyone, I've been coding a lot the past few days and I just wanted to share my code for those who may have some use for them, and also for me to keep track of my progress. ;********************************************************; ;; MA:perp-test - Test if two angles are perpendicular ;; Arguments: ;; - a (float): First angle in radians ;; - b (float): Second angle in radians ;; - tol (float): Tolerance value for comparison ;; Returns: ;; - test (bool): True if the angles are perpendicular within the given tolerance, False otherwise ;; Usage: (MA:perp-test a b tol) (defun MA:perp-test (a b tol / test) (if (and a b tol) (if (< (abs (- (abs (cos a)) (abs (sin b)))) tol) (setq test T) (setq test nil) ) ) ) This is a very simple script for when you want to compare two angles, especially of blocks you're working with. This can be modified to where it has a default tolerance value for orthogonality, but that would be a good exercise for you guys to test for yourselves.

Nice and easy to understand function. You may want to consider using a simple square-function so you don't have to keep saving variables and makes the code more readable. (defun sqr (x) (* x x)) (defun c:ra ( / a b c c1 c2 h fuzz) ;right angle (setq a (getpoint) b (getpoint) c (getpoint) fuzz 1e-6) (equal (+ (sqr (distance a b)) (sqr (distance b c))) (sqr (distance a c)) fuzz) )

Like this? What it does: I expect 1number between a prefix and postfix (both of which can be empty) So for example: destination = 23.6GT56, source = 123.50 => result = 123.50GT56 From the moment the number starts the prefix ends; from the moment the number stops then all the rest is postfix. It doesn't see 12E+3 (which is 12000) as a number. That's a TODO. (defun c:mt (/ cEnt mEnt newString) (if (and (setq cEnt (car (nentsel "\nSelect Source Text: "))) ;; user selects source TEXT/MTEXT/ATTRIB cEnt (member (cdr (assoc 0 (entget cEnt))) '("TEXT" "MTEXT" "ATTRIB"))) (progn (redraw cEnt 3) (while (and (setq mEnt (car (nentsel "\nSelect Destination Text: "))) ;; user selects destination TEXT/MTEXT/ATTRIB mEnt (member (cdr (assoc 0 (entget mEnt))) '("TEXT" "MTEXT" "ATTRIB"))) (setq newString (keepAlphabets (cdr (assoc 1 (entget cEnt))) (cdr (assoc 1 (entget mEnt))) )) (princ newString) (entmod (subst (cons 1 newString) (assoc 1 (entget mEnt)) (entget mEnt) )) ) (redraw cEnt 4) ) (princ "\n<!> Incorrect Selection <!>") ) (princ) ) ;; For example src = "123.50" , dest = "CL1.50TG" . result = "CL123.50TG" (defun keepAlphabets ( src dest / chars a prefix num post) (setq prefix "") (setq num "") (setq post "") ;; string to characters list (setq chars (vl-string->list dest)) (foreach a chars (if (and (= post "") (or (= a 46) (< 47 a 58))) ;; character is a "." or [0->9]. Skip this if the postcript has started (progn (setq num (strcat num (chr a))) ) (progn (if (= num "") (setq prefix (strcat prefix (chr a))) (setq post (strcat post (chr a))) ) ) ) ) (strcat prefix src post) )

Pythagoras would be proud

To build on what Steven said. When things are not working right using command. use the command manualy by adding a - infront and step thought the command line entrys and see what you need to change. -plot Also at my old job we had to print the drawing with a revision number at the end. Made this lisp would always print to Documents and then copy the file back to where the dwg was. **Be aware that their is a line in here to delete the PDF your replacing. (vl-file-delete fp) ;;----------------------------------------------------------------------------;; ;; Copy Printed PDF in My Documents to Drawing location. ;; http://www.lee-mac.com/open.html (defun C:CP (/ path fn fs fp) (vl-load-com) (setq path (strcat (getvar 'DWGPREFIX)) fn (vl-filename-base (getvar 'dwgname)) fs (strcat (getenv "userprofile") "\\Documents\\" fn ".pdf") ;fn (substr (getvar 'dwgname) 1 (- (strlen (getvar 'dwgname)) 6)) ;remove the minor Revision number from name fp (strcat path fn ".pdf") ) (if (= (findfile fs) nil) (progn (prompt "NO PDF TO COPY") (QUIT) ) ) (cond ((findfile fp) (setq reply (ACET-UI-MESSAGE (strcat "\nDo you want to update PDF \"" fn "\"") "Existing PDF" (+ Acet:YESNO Acet:ICONWARNING))) (if (= reply 6) ;Yes (progn (vl-file-delete fp) (vl-file-copy fs fp) (LM:Open fp) ) ) ) (t (progn (vl-file-copy fs fp) (LM:Open fp) ) ) ) (princ) ) ;;----------------------------------------------------------------------------;; ;; A wrapper for the 'Open' method of the Shell Object ;; f (target) - [int/str] File, folder or ShellSpecialFolderConstants enum ;; http://www.lee-mac.com/open.html (defun LM:open (f / rtn shl) (if (and (or (= 'int (type f)) (and (= (type f) 'STR) (setq f (findfile f)))) (setq shl (vla-getinterfaceobject (vlax-get-acad-object) "shell.application")) ) (progn (setq rtn (vl-catch-all-apply 'vlax-invoke (list shl 'open f))) (vlax-release-object shl) (if (vl-catch-all-error-p rtn) (prompt (vl-catch-all-error-message rtn)) t) ) ) )

Be careful of how "tol" is used in your program. Due to the slope of the sine function being close to 45 degrees near zero degrees compared to its slope near 90 degress (almost flat) you wil get more precision when angle "a" i,s closer to 0 degrees than when it's near 90 degrees. Your program should use sin(a) cos(b) for when a is < 45 and sin(b), cos(a) otherwise. In each of the following examples, the angle difference between a and b is 89.7 degrees. Note how the difference varies as a function of the angles used.

Hi Here is a lisp from my archive Works in WCS and parallel UCS. Z rotation allowed, but not 3D rotation. Text is inserted in both ends of each line Text height is 1% of grid spacing. ;Stefan M. 12.02.2018 (defun C:SURVGRID ( / *error* acdoc acobj dimzin GET_POINTS REMOVE_DUPLICATES SEL_OBJ ROT ADD_GRID e dir msg o a pts a1 a2 x1 x2 y1 y2 p1 p2 int ) (vl-load-com) (setq acobj (vlax-get-acad-object) acdoc (vla-get-activedocument acobj) ) (if (= (logand 8 (getvar 'undoctl))) (vla-endundomark acdoc)) (setq dimzin (getvar 'dimzin)) (setvar 'dimzin 8) (defun *error* (msg) (and msg (not (wcmatch (strcase msg) "*EXIT*,*CANCEL*,*ABORT*")) (princ (strcat "\nEroare: " msg)) ) (setvar 'dimzin dimzin) (if (= (logand 8 (getvar 'undoctl))) (vla-endundomark acdoc)) (princ) ) ;Get list of polyline vertexes. ;Bulged segments are refined with points at max. 5° apart (defun get_points (e / a b p q n d l a1) (setq e (vlax-ename->vla-object e) a (vlax-curve-getstartparam e) b (vlax-curve-getendparam e) ) (while (< a b) (setq p (vlax-curve-getpointatparam e a) q (atan (abs (vla-getbulge e a))) n (fix (/ (* 80 q) pi)) a1 a ) (if (not (equal p (car l) 1e-8)) (setq l (cons p l))) (if (> n 0) (repeat (1- n) (setq a1 (+ a1 (/ 1.0 n)) p (vlax-curve-getpointatparam e a1) ) (if (not (equal p (car l) 1e-8)) (setq l (cons p l))) ) ) (setq a (1+ a)) ) l ) (defun remove_duplicates (l / r) (while l (if (not (equal (car l) (car r) 1e-8)) (setq r (cons (car l) r)) ) (setq l (cdr l)) ) r ) (defun sel_obj (msg etype / e) (setvar 'errno 0) (setq e (car (entsel msg))) (cond ((= (getvar 'errno) 7) (princ "\nNothing selected. Try again.") (sel_obj msg etype) ) ((not e) nil) ((wcmatch (cdr (assoc 0 (entget e))) etype) e) (t (princ "\nInvalid object. Try again.") (sel_obj msg etype) ) ) ) (defun rot (p a) (list (- (* (car p) (cos a)) (* (cadr p) (sin a))) (+ (* (car p) (sin a)) (* (cadr p) (cos a))) ) ) (defun add_grid (p1 p2 str a) (entmakex (list '(0 . "TEXT") '(8 . "Grid") (cons 10 (mapcar '+ o (rot (polar p1 (* 0.25 pi) (* (sqrt 2) 0.01 *dist*)) a))) (cons 40 (* 0.02 *dist*)) (cons 1 str) (cons 50 a) (assoc 41 (tblsearch "style" (getvar 'textstyle))) (cons 7 (getvar 'textstyle)) ) ) (entmakex (list '(0 . "TEXT") '(8 . "Grid") '(10 0.0 0.0 0.0) (cons 40 (* 0.02 *dist*)) (cons 1 str) (cons 50 a) (assoc 41 (tblsearch "style" (getvar 'textstyle))) (cons 7 (getvar 'textstyle)) '(72 . 2) (cons 11 (mapcar '+ o (rot (polar p2 (* 0.75 pi) (* (sqrt 2) 0.01 *dist*)) a))) '(73 . 0) ) ) (entmakex (list '(0 . "LINE") '(8 . "Grid") (cons 10 (mapcar '+ o (rot p1 a))) (cons 11 (mapcar '+ o (rot p2 a))) ) ) ) (or *dist* (setq *dist* 100.0)) (if (and (setq e (sel_obj "\nSelect polyline: " "*POLYLINE")) (progn (setq dir (if (zerop (getvar 'worlducs)) "Ucs" "Wcs")) (initget "Wcs Ucs") (setq dir (cond ((getkword (strcat "\nSpecify origin [Wcs/Ucs] <" dir ">: "))) (dir) ) ) ) (setq msg "\nUCS is not parallel to WCS.") (or (eq dir "Wcs") (and (equal (caddr (getvar 'ucsxdir)) 0.0 1e-8) (equal (caddr (getvar 'ucsydir)) 0.0 1e-8) ) ) (if (eq dir "Wcs") (setq o '(0.0 0.0 0.0) a 0.0 ) (setq o (getvar 'ucsorg) a (angle '(0.0 0.0 0.0) (getvar 'ucsxdir)) ) ) (setq pts (remove_duplicates ( (lambda (l) (cons (last l) l)) (get_points e) ) ) ) (setq msg "\nPolyline is not parallel to WCS.") ( (lambda (l) (vl-every '(lambda (x) (equal (car l) x 1e-8)) l) ) (mapcar 'caddr pts) ) (setq pts (mapcar '(lambda (p) (rot (mapcar '- p o) (- a)) ) pts ) ) (setq *dist* (cond ((getdist (strcat "\nSpecify grid distance <" (rtos *dist*) ">: "))) (*dist*) ) ) ) (foreach u (list nil (/ pi -2.0)) (if u (setq pts (mapcar '(lambda (p) (rot p u)) pts)) (setq u 0.0) ) (mapcar '(lambda (p f) (set p (apply 'mapcar (cons f pts)))) '(a1 a2) '(min max) ) (setq x1 (- (car a1) *dist*) y1 (* *dist* (fix (/ (cadr a1) *dist*))) x2 (+ (car a2) *dist*) y2 (* *dist* (1+ (fix (/ (cadr a2) *dist*)))) ) (while (<= y1 y2) (setq p1 (list x1 y1) p2 (list x2 y1) ) (if (and (setq int (vl-remove nil (mapcar '(lambda (p3 p4) (inters p1 p2 p3 p4 T)) pts (cdr pts)))) (setq int (vl-sort int '(lambda (a b) (> (car a) (car b))))) (setq int (remove_duplicates int)) (> (length int) 1) ) (while (cadr int) (add_grid (car int) (cadr int) (if (zerop u) (strcat "N " (rtos y1 2 3)) (strcat "E " (rtos (- y1) 2 3)) ) (- a u) ) (setq int (cddr int)) ) ) (setq y1 (+ y1 *dist*)) ) ) (if msg (princ msg)) ) (*error* nil) (princ) )