Leaderboard

I'm not sure I follow .. the code HERE does that already? Nevermind .. I see what you are saying... let me take a look. Try this version: (defun c:foo (/ a c d) ;; RJP » 2023-08-13 ;; Sets hatch background color in blocks to 'none' (vlax-for l (vla-get-layers (setq d (vla-get-activedocument (vlax-get-acad-object)))) (cond ((= -1 (vlax-get l 'lock)) (vlax-put l 'lock 0) (setq a (cons l a)))) ) (vlax-for b (vla-get-blocks d) ;; This line will only process block definitions (if (= 0 (vlax-get b 'isxref) (vlax-get b 'islayout)) (vlax-for o b (cond ((and (vlax-write-enabled-p o) (wcmatch (vla-get-objectname o) "AcDbHatch")) (setq c (vla-get-backgroundcolor o)) (vla-put-EntityColor c -939524096) (vla-put-backgroundcolor o c) ) ) ) ) ) (foreach l a (vlax-put l 'lock -1)) (vla-regen d acallviewports) (princ) )

AS @marko_ribar SAY @asdfgh TRY THIS (defun c:Spline_Copy (/ ACADOBJ CONTROLPOINT CONTROLPOINTN DOC ENAME INT IPOINT LEN OBJENTGET OBJOBJECCOPYT OBJOBJECT POINT1 POINT2 PT1 PTN STT ) (setq acadObj (vlax-get-acad-object)) (setq doc (vla-get-activedocument acadObj)) (if (and (setq objENTGET (entget (setq eName (car (entsel "\nSelect"))))) (setq int (getdist "\nSpecify spacing interval: ")) ) ;_ end of and (progn (setq objobject (vlax-ename->vla-object eName)) (setq objobjeccopyt (vla-copy objobject)) ;; Define the points that make up the move vector (setq point1 (vlax-3d-point 0 0 0) point2 (vlax-3d-point 0 0 -5) ) ;_ end of setq (vla-move objobjeccopyt point1 point2) (setq iPoint 0) ;_ end of setq (while (> (vla-get-numberofcontrolpoints objobjeccopyt) iPoint) (progn (setq controlPoint (vlax-safearray->list (vlax-variant-value (vla-getcontrolpoint objobjeccopyt iPoint) ) ;_ end of vlax-variant-value ) ;_ end of vlax-safearray->list ) ;_ end of setq (setq controlPointn (vlax-3d-point (car controlPoint) (cadr controlPoint) 0 ) ;_ end of vlax-3d-point ) ;_ end of setq (vla-setcontrolpoint objobjeccopyt iPoint controlPointn) (vla-update objobjeccopyt) (setq iPoint (1+ iPoint)) ) ;_ end of progn ) ;_ end of while (setq len (vlax-curve-getdistatparam objobjeccopyt (vlax-curve-getendparam objobjeccopyt) ) ;_ end of vlax-curve-getDistAtParam ) ;_ end of setq (setq stt 0) ;_ end of setq (while (<= stt len) (progn (setq pt1 (vlax-curve-getpointatdist objobjeccopyt stt)) (setq ptn (vlax-curve-getclosestpointtoprojection objobject pt1 ;'(0.0 1.0 0.0) '(0.0 0.0 1.0) ) ) ;_ end of setq ;;; (entmakex (list '(0 . "POINT") (cons 10 ptn) (cons 8 "00-point") ) ;_ end of list ) ;_ end of entmakex (setq stt (+ int stt)) ) ;_ end of progn ) ;_ end of while (vla-delete objobjeccopyt) ) ;_ end of progn ) ;_ end of if (princ) ) ;_ end of defun ;|«Visual LISP© Format Options» (72 2 50 2 T "end of " 60 9 1 0 0 nil T nil T) ;*** DO NOT add text below the comment! ***|;

Hi SLW Here is a better approximation of cylindrical gradients. Don't ask what those numbers are. Long story. I forgot to tell you, the spherical gradients family is ignored. That would be the challenge... Also, there is a property of gradient, "Centered", which in your case is always true. If you change it to not centered, the gradient is shifted and that's another story for another day. ;Replace gradient Hatch with lines ;Stefan M - 12.08.2023 (defun c:gradline ( / *error* o ss i e a col1 col2 en l c x1 x2 c1 c2 rgb r m q ) ;(setq *error* (err)) (setq o (vlax-3d-point 0.0 0.0 0.0)) (or *spacing* (setq *spacing* 0.1)) (or *del* (setq *del* "No")) (if (and (setq ss (ssget "_:L" '((0 . "HATCH") (450 . 1) (470 . "LINEAR,CYLINDER,INVCYLINDER")))) (progn (initget 6) (setq *spacing* (cond ((getdist (strcat "\nSpecify line spacing <" (rtos *spacing*) ">: "))) (*spacing*) ) ) ) (progn (initget "Yes No") (setq *del* (cond ((getkword (strcat "\nDelete original hatch [Yes/No] <" *del* ">: "))) (*del*) ) ) ) ) (repeat (setq i (sslength ss)) (setq e (vlax-ename->vla-object (ssname ss (setq i (1- i)))) a (vla-get-gradientangle e) col1 (vla-get-gradientcolor1 e) col2 (vla-get-gradientcolor2 e) ) (setq en (entlast) l nil) (setq c (vla-copy e)) (vla-rotate c o (- a)) (vla-getboundingbox c 'x1 'x2) (setq x1 (car (vlax-safearray->list x1)) x2 (car (vlax-safearray->list x2)) ) (if (> (- x2 x1) *spacing*) (progn (vla-put-HatchObjectType c acHatchObject) (vla-setpattern c acHatchPatternTypeUserDefined "_USER") (vla-put-patternangle c (/ pi 2)) (vla-put-patternscale c *spacing*) (setq c1 (mapcar '(lambda (p) (vlax-get col1 p)) '(red green blue)) c2 (mapcar '(lambda (p) (vlax-get col2 p)) '(red green blue)) ) (if (eq (vla-get-gradientname e) "INVCYLINDER") (mapcar 'set '(c1 c2) (list c2 c1)) ) (vla-put-truecolor c col1) (command "_explode" (vlax-vla-object->ename c)) (while (setq en (entnext en)) (setq l (cons (list (car (vlax-curve-getstartpoint en)) (vlax-ename->vla-object en) ) l ) ) ) (foreach x l (if (eq (vla-get-gradientname e) "LINEAR") (setq rgb (mapcar '(lambda (c1 c2) (fix (+ 0.5 c1 (/ (* (- c2 c1) (- (car x) x1)) (- x2 x1)))) ) c1 c2 ) ) (progn (setq r (/ (- x2 x1) 2.0) m (/ (+ x2 x1) 2.0) q (/ (- m (car x)) r) rgb (mapcar '(lambda (c1 c2) (fix (+ 0.5 c1 (* (- c2 c1) (+ (* 0.2684 (expt q 4)) (* -1.2598 (expt q 2)) 0.9954)))) ) c1 c2 ) ) ) ) (vla-setrgb col1 (car rgb) (cadr rgb) (caddr rgb)) (vla-put-truecolor (cadr x) col1) (vla-rotate (cadr x) o a) ) (if (eq *del* "Yes") (vla-delete e)) ) ) ) ) ;(*error* nil) (princ) )

A quick test cut down the time to do what I was doing from 12 to 4 seconds so a big improvement - barely time to get a drink, but short enough for me to stop wondering if it was all going wrong though (but overall a mornings work to 4 seconds is acceptable). Cheers

oops put a not in the if statement so it was removing the ones that it should be keeping.

I played with this some yesterday at home, should do what I need with some custom tweaks. Thanks!!

Consider the following code - (defun c:bd ( / ang ber dis mid pt1 pt2 scl ) (initget 6) (if (and (setq scl (getreal "\nSpecify drawing scale: ")) (setq pt1 (getpoint "\nSpecify 1st point: ")) (setq pt2 (getpoint "\nSpecify 2nd point: " pt1)) ) (progn (setq ang (angle pt1 pt2) dis (* scl 0.001 (distance pt1 pt2)) mid (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) pt1 pt2) ) (entmake (list '(000 . "TEXT") '(008 . "DIM") '(062 . 256) '(006 . "BYLAYER") '(040 . 2.0) '(072 . 1) '(073 . 2) (cons 007 (if (tblsearch "style" "SS") "SS" (getvar 'textstyle))) (cons 010 (polar mid (+ ang (/ pi 2.0)) 5.0)) (cons 011 (polar mid (+ ang (/ pi 2.0)) 5.0)) (cons 050 ang) (cons 001 (vl-string-translate "." "|" (rtos dis 2 3))) ) ) (setq ber (angtos ang) ber (vl-string-subst "%%d" "d" ber) ber (vl-string-subst "%%135" "'" ber) ber (vl-string-subst "%%136" "\"" ber) ) (entmake (list '(000 . "TEXT") '(008 . "BEAR") '(062 . 256) '(006 . "BYLAYER") '(040 . 2.0) '(072 . 1) '(073 . 2) (cons 007 (if (tblsearch "style" "SU") "SU" (getvar 'textstyle))) (cons 010 (polar mid (+ ang (/ pi 2.0)) 2.5)) (cons 011 (polar mid (+ ang (/ pi 2.0)) 2.5)) (cons 050 ang) (cons 001 ber) ) ) ) ) (princ) )