Leaderboard

Hello friends, Running a forum like this often feels like a long-running battle against those who would like to deface or destroy what we do here. From time-to-time we need to change the way we operate to stay one step ahead of the hackers and haters. From today, the way you login to this forum will change. Historically, you've been able to login using your screen name and password. The problem with this approach is that your screen name is publicly available, so all a hacker has to do is to find your password. From today, you will not be able to login using your screen name, you will need to use the email address associated with your account. Since your email address is not publicly available, this change presents a significant defense against hackers. If you already login using your email address, you do not need to change the way you login. We recommend that you always use a strong password to avoid your account being hacked.

Just a note to say thanks for maintaining this site. It's a pleasure to come here, read a question, type out a response and see it instantly appear to help the other user(s). Image attachments via drag+drop work flawlessly too. It is noticed and appreciated. Cheers!

After seeing @BIGAL's suggestion, I'm wondering if I understood correctly what you're asking, Vica. Anyway, I'm attaching a short clip of what I'm talking about. FACTVM de ARCTIS.mp4 I’ve implemented a small emulator of the "pline" command in the base code, but each user should implement the code they need for their specific task instead. Basically, the distance variation from the last stored point in LASTPOINT is displayed above the cursor (though this can be easily changed by modifying the textoGR1 function). Below the cursor, any desired information about the object under it will be shown (or not, if visibility is toggled by pressing the F10 key). This information must be passed to the textoGR2 function as a list of (Property_Name StringValue) pairs. The main code must be implemented in the 'FuncionPrincipal' function.

Hi guys, As thanks for helping me out through the journey of AutoLISP from multiple posts, I've decided to make a small contribution to CADTutor.net with my own code that you can download from here: https://www.cadtutor.net/forum/files/file/27-block-overkill/ Upon issuing the BOVERKILL command, This LISP will allow you to either delete blocks that area "duplicated" on top of one another, or move them to a specified layer. This LISP deletes blocks in which the blocks in comparison abides to the following three criteria below: It shares the same insertion point to a specified tolerance It shares the same effective name It shares the same effective scale to the same specified tolerance Modes of Overkill Thanks to a wonderful suggestion from one of the insights in this forum, the program has been further upgraded as of 20 April 2023. This LISP routine now also allows for three modes of overkill: Distance Plane-Axis Axes The "Distance" mode is the default mode and is the most widely used mode of overkill. This mode determines that two blocks are considered duplicates if the distance between them is within the specified tolerance inputted by the user. The "Plane-Axis" mode determines that two blocks are duplicates if the proximity of the blocks in comparison lies within one tolerance specified for one of the planes , and a separate tolerance along the third axis (normal) of that plane. Calculations are done to the UCS. The "Axes" mode determines that two blocks are duplicates by comparing three different tolerances across each axis individually. All three tolerances must be met for the program to consider the blocks a duplicate. Just like the previous mode, the UCS will be used by the program to perform the calculations. Following this, the program will also draw a circle (of a radius set within the LISP routine) on the insertion points of the processed blocks. These circles will be drawn in the "BOVERKILL-Duplicates" layer. After which it prints a report of the quantity of the deleted or modified blocks to the command line. This feature makes it easy for users to identify where duplicates are found on a large drawing with thousands of blocks. However, the dynamic properties of the block are far too hard for me to calculate as they have different position, rotation and visibility parameters that could be altered by the user. As such, they are ignored. Note that the rotation of the block does not fall in the criteria above as mirroring the block alters it's rotation values, and thus will fail on some circumstances. This means that the blocks will still be processed if as long as the three criteria above satisfy and objects are not rotated the same way. This LISP was inspired when using block counting routines (for example from Lee Mac's Block Counter routine or your own custom routines) reporting incorrect numbers due to duplicate blocks. The OVERKILL command for one reason or another is not able to delete duplicate dynamic blocks that are (for example, rotated normally then rotate through dynamic rotation to the original position). I've also cycled through the net for solutions to no avail. Thus, I opened this program for you folks to use. It's not a perfect code but I hope it will make working for you much more convenient. Any feedbacks, comments, and criticisms are welcomed as I look to learn and get better. Enjoy. Thanks, Jonathan Handojo

Hi @rkmcswain and all who have commented - thanks for your kind words. It has been a pleasure to keep this forum in good order over so many years (the CADTutor site is 25 years old this year!). Naturally, a forum isn't anything without its members, so I thank you all, in return, for being such a great community who continue to post brilliant content and .give your time freely to help others. Long may it continue!

Also the best users, mods and admin!

I copied another function of dijkstra's algorithm to find the shortest path. It might need a lot of optimization, but just as a proof of concept. centerline voronoi dijkstra.lsp Code I forgot to include: (defun RemoveDuplicatesAux ( x ) (cond ((vl-position x index)) ((null (setq index (cons x index)))) ) ) (defun RemoveDuplicates ( lst / index ) (vl-remove-if 'RemoveDuplicatesAux lst ) )

[code edited 11/3/2025] I have enjoyed the discussion of this thread. As I gave the task more thought and anaysis it became more clear that the task was not simple. As it appears that there is still no satisfacory solution I thought I would offer the following. The first goal for me was to create a function that would create a midline between two non parallel lines. The mid-lines extents should be a function of the given line segments. This function could then be used in a program that would step through the line segments of one of the polylines and search the other polyline for relevant segments. The function "midline" accepts four points. The first two points, A1 and A2, are the ends of one line sement while the thrid and fourth points, B1 and B2, are the ends of an opposing ilne segments. The diagram below details the variables in the function. The program uses vectors as I prefer them over angles which present, for me, a variety of problems. uA = unit vector in the diection from A1 to A2 uB = unit vector in the direction from B1 to B2 uBisector = unit vector in the direction of the angle bisector of uA and UB The ends of the two lines are projected onto the bisecting line defining 4 points, A1M, A2M, B1M, B2M. I debated which of the points to output for the line to be drawn. I first used the closest and furthest points from the intersecttion point ABIntr but I found it more helpful to use the two intermediate points (A1M and A2M in the example above). Here's an example of the results after manually steppng alone the polyline. Looking at the area circled in red we find: To fill the gap we need a curve that starts with a radius of 0.1514 and ends with a radius of 0.1693. This can be done with a spline or you may find it acceptable to extend the two lines to the point of intersection. The best way to create the spline is to use the Control Vertex Method and use the two endpoints and the imaginary point of intersecton for the middle CV. This ensures tangency to the two lines. As can be seen below the distance to a random point along the spline (red) agree! Run the program "test" and specify the end points of a line segment on one of the polylines, then the endpoints on a line segment on the opposing polyline. I have found the results very accurate and although it may not be used for creating the complete "hybrid " polyline it is helpful in finding the correct line for a specific segment. ;;---------------------------------------------------------------------------- ;; Determines the endpoints of a line the is midway between two lines defined by their end points. ; Input: 4 points, the ends of the first line followed by the ens of the second line ; Output: a list containing the two point of the midline if there's a solution and nil if no solution ; L. Minardi 10/31/2025 - Revised 11/3/2025 (defun midLine (a1 a2 b1 b2 / ua ub p vp d s a1m a2m b1m b2m d1 d2 d3 d4 slist a1p a2p b1p b2p m1 m2 mmid mp) (setq ua (unitVecAB a1 a2) ub (unitVecAB b1 b2) ) (if (< (dot ua ub) 0.0) (setq ub (mapcar '* ub '(-1 -1 -1))) ) (if (> (abs (dot ua ub)) 0.9999) ; are lines parallel? (progn ; lines are parallel (setq p (mapcar '/ (mapcar '+ a1 b1) '(2 2 2)) ; point on midline vp (list (- (cadr ua)) (car ua) 0.0) ; vector perpendicular to ua d (/ (dot (mapcar '- b1 a1) vp) 2.0) ; distance to midline s (dot (mapcar '- a1 p) ua) a1m (mapcar '+ p (mapcar '* ua (list s s s))) s (dot (mapcar '- a2 p) ua) a2m (mapcar '+ p (mapcar '* ua (list s s s))) s (dot (mapcar '- b1 p) ua) b1m (mapcar '+ p (mapcar '* ua (list s s s))) s (dot (mapcar '- b2 p) ua) b2m (mapcar '+ p (mapcar '* ua (list s s s))) d1 0.0 d2 (dot ua (mapcar '- a2m a1m)) d3 (dot ua (mapcar '- b1m a1m)) d4 (dot ua (mapcar '- b2m a1m)) ) (setq slist ; sorted list of distances (vl-sort (list (list a1m d1) (list a2m d2) (list b1m d3) (list b2m d4)) (function (lambda (e1 e2)(< (cadr e1) (cadr e2)))))) ; use the middle two mid point from the line (setq m1 (car (nth 1 slist)) m2 (car (nth 2 slist)) ) (setq mmid (mapcar '/ (mapcar '+ m1 m2) '(2 2 2))) (setq mp (* (dot (mapcar '- a1m mmid) (mapcar '- a2m mmid)))) (if (<= mp 0) (setq theLine (list m1 m2)) (setq theline nil) ) ;;;;; ) ) ; end lines parallel (progn ; lines are not parallel (setq ABIntr (inters A1 A2 B1 B2 nil)) (setq p (mapcar '+ ABIntr (mapcar '/ (mapcar '+ ua ub) '(2 2 2))) ;(setq p (mapcar '+ ABIntr (mapcar '/ (mapcar '+ a1 b1) '(2 2 2))) uBisector (unitVecAB ABIntr p) vp (list (- (cadr ua)) (car ua) 0.0) A1p (mapcar '+ A1 vp) a1m (inters A1 A1P ABIntr p nil) A2p (mapcar '+ A2 vp) a2m (inters A2 A2P ABIntr p nil) vp (list (- (cadr ub)) (car ub) 0.0) B1p (mapcar '+ B1 vp) B1m (inters B1 B1P ABIntr p nil) B2p (mapcar '+ B2 vp) B2m (inters B2 B2P ABIntr p nil) d1 (distance ABIntr a1m) d2 (distance ABIntr a2m) d3 (distance ABIntr b1m) d4 (distance ABIntr b2m) ) (setq slist (vl-sort (list (list a1m d1) (list a2m d2) (list b1m d3) (list b2m d4)) (function (lambda (e1 e2) (< (cadr e1) (cadr e2))))) ) (setq m1 (car (nth 1 slist)) m2 (car (nth 2 slist)) ) (setq mmid (mapcar '/ (mapcar '+ m1 m2) '(2 2 2))) (setq mp (* (dot (mapcar '- a1m mmid) (mapcar '- a2m mmid)))) (if (<= mp 0) (setq theLine (list m1 m2)) (setq theline nil) ) ) ; end lines not parallel ) ; end if ) ; test function (defun c:test ( / a1 a2 b1 b2 mline ) (setq a1 (getpoint "\nEnter start point of first line: ") a2 (getpoint a1 "\nEnter end point of first line: ") b1 (getpoint "\nEnter start point of second line: ") b2 (getpoint b1 "\nEnter end point of second line: ") mline (midline a1 a2 b1 b2) ) (if mline (command "_line" "_non" (car mline) "_non" (cadr mline) "") (princ "\nNo Solution!") ) (princ) ) ; unit vector from point A to point B (defun unitVecAB (A B / x) (setq x (distance A B) x (mapcar '/ (mapcar '- B A) (list x x x)) ) ) ; dot product of vectors A and B (defun dot (A B / x) (setq x (mapcar '* A B)) (setq x (+ (nth 0 x) (nth 1 x) (nth 2 x))) );end of dot mid -poly.06.lsp

Hi, Written a tool for replacing (updating) blocks. Had some spare time untill my boss recently used the W-word again (work , yak!) Anywayz , its a prototype so I'm not sure its stable and safe yet because I only did some lab testing. I hope it will be usefull. Not sure if I will be able to work on it further any time soon because I still have a few ideas and wishes. gr. Rlx RlxBlk manual.doc RlxBlk.lsp RlxBlk.dcl

Hi, the lisp, anticipated with two images here and here, aligns between two curves the hatch elements and creates a block containing the lines of the new geometry. The original shape of the hatch shall be a rectangle, an isosceles triangle or an isosceles trapezoid. In case of large hatches is recommended to divide it into portions, any case it is better to try with small hatches to verify the time required for processing, in according to PC performances, too. Not all hatches are suitable for processing. I hope it works well and there are no problems. AlignH.lsp

I wrote this program like four years ago (just for fun / exercise) and maybe used it once or twice so as we say here on Mars : guaranteed to the doorstep If it works : , if it doesn't ... As usual never wrote a manual so have fun experimenting. RlxBlockSync.lsp

Hello Have to do a job that involves around 3000 loops + 2500 connection diagrams & IO-lists. Bottom line was, either I do it in half of the time and half of the money or else... (the job goes overseas) For example a loop diagram has a transmitter , connected to a Junction Box , then to a control panel + IO panel. Loops have to be made as-built (update revision, remove clouds etc). Ok already have an app for that. But I also have to check each loop against JB and CP channel (oh crap...) So I came up with the idea to first read all the titleblock titles in the project folder and save this to a (txt) file. Then, having the loop open in AutoCad , I wanted to be able to either type in part of the title in the search list box or select the JB or CP symbol and open the drawing. And that's when I decided to create my very own BFF (Bulk File Finder) App is still in its beta but so far it seems to be doing what I hoped it to do. (but some little points may yet come to surface , but hey , baby is only one weekend old so gimme a break) Make sure you put in (1) blockname of your (title)block , (2) name(s) of attributes with the titles in it, separated by comma's , (3) select your drawing source folder and (4) choose create (don't forget to save it afterwards) In the top left listbox (green) you can put in some search strings and you can also save this. When all this is done and you press ok , it should find all the drawing (titles) matching the search criterea. Some of the Select and Find buttons (purple section) are not working yet because those will involve some company special ops. Most of my time went into the interface and progress bar thats activated when scanning for folders, drawings & titles. Maybe it will be helpfull to others , maybe not because it might be too specific to my own situation but I present it on an as-it-is basis and because its been a while I posted something and posting on CadTutor seems to be getting rarer. If its not working or helpfull : trashcan , yes you can , because of my workload I don't have much time to do user request's RlxMyBFF.lsp

@leonucadomi Give this a try: (defun c:foo (/ a b e h hp p x) ;; RJP » 2022-09-08 (cond ((and (setq e (car (entsel "\nPick source hatch: "))) (= "HATCH" (cdr (assoc 0 (entget e)))) (setq b (assoc 2 (entget e))) (setq e (vlax-ename->vla-object e)) (setq a (mapcar '(lambda (x) (list x (vlax-get e x))) '(associativehatch backgroundcolor elevation entitytransparency gradientangle gradientcentered gradientcolor1 gradientcolor2 gradientname hatchobjecttype hatchstyle isopenwidth layer linetype linetypescale lineweight material origin patternangle patterndouble patternscale patternspace plotstylename truecolor visible ) ) ) ) (setq hp (getvar 'hpname)) (setvar 'hpname (cdr b)) (while (setq p (getpoint)) (setq h (entlast)) (command "_.bhatch" p "") (cond ((not (equal h (setq h (entlast)))) (setq h (vlax-ename->vla-object h)) (foreach x a (vl-catch-all-apply 'vlax-put (list h (car x) (cadr x)))) ;; patternname (RO) cannot be set via vla for some reason ? ;; (setq h (entget (vlax-vla-object->ename h))) ;; (entmod (subst b (assoc 2 h) h)) ) ) ) (setvar 'hpname hp) ) ) (princ) )

Believe it or not but I am Kenny Ramage. I cannot believe that AfraLisp is still having an influence.

Here are some more examples, along with a quick performance comparison.

All members (i.e. anyone with a post count of 10 or greater) now have access to a new theme here at the CADTutor forum. This has been a long-time request, and now it's here! In the footer of every page, eligible members will see a "Theme" link that allows a choice of the default CADTutor theme or the new Dark Mode theme. Simply choose the one you prefer. The forum will remember your choice until you change it. Try it out and let me know what you think

I agree also great forum, the biggest out there is the worst site and they just dodge around the edges of the problems by saying contact our support request department

Nice test case @PGia, it did have some undesirable zigzags on those lines. I made some changes to the code to prevent this from happening. It should create a smooth line again!

@PGia Thanks for the encouragement and checking the results. I measure from the vertices instead of the lines. Those are calculated and the lines are just to connect the points. So perpendicular to the middle of segments of the centerline will always be a bit off, but if you measure from the vertices it should be centered correctly. Just like @GP_ said. I kept going in the same direction and I have made some improvements and got rid of some bugginess: The centerline should be a little more accurate now because of extra measurements (blue line) Crossing polylines get sharp corners on negative side Corner checks are done on all intersections of temporary line now (red line) More error checking so it doesn't crash on some of the example lines I left all of the 'animation' code commented out so you can give it a try ;| ; Calculate centerline between two polylines - dexus ; Function checks intersections of the offsets of two lines to create a middle/avarage line. ; https://www.cadtutor.net/forum/topic/98778-hybrid-parallel/page/6/#findComment-677339 ; Version 0.1 - Initial release 19-11-2025 ; Version 0.2 - Added corner support on negative side of crossing polylines 27-11-2025 ; Version 0.3 - Extra check using vertex to closest point as distance 28-11-2025 ; Version 0.4 - Added error function 28-11-2025 ; Version 0.5 - Improved distance check to prevent zigzag lines 01-12-2025 ; Version 0.6 - Check if offset can be used before adding points 01-12-2025 ; Version 0.7 - Improved side check on 3 points 01-12-2025 |; (defun c:cpl (/ corners ent1 ent2 enx2 flipped loop maxlen offset offsetdistance pts sides ss start te0 te1 te2 LM:ProjectPointToLine LM:intersections _addPoints _avarageAngle _checkOffset _cornerOffset _doOffset _getAnglesAtParam _getLength _polyline _rlw _side _wait *error*) (defun *error* (st) (if (wcmatch (strcase st t) "*break,*cancel*,*exit*") (redraw) (progn (vl-bt) (princ (strcat "\nOops! Something went wrong: ") st) ) ) (if (not (vlax-erased-p te0)) (entdel te0)) (if (and te1 (not (vl-catch-all-error-p te1))) (mapcar 'vla-delete te1)) (if (and te2 (not (vl-catch-all-error-p te2))) (mapcar 'vla-delete te2)) (princ) ) ;| ; Draw Polyline - dexus ; Draw a polyline from a list of points, but filter out colinear points ; @Param lst list of points ; @Returns ename of polyline |; (defun _polyline (lst closed / prev pts) (while lst (cond ( (and (cdr lst) prev (or (equal (cdr lst) prev 1e-8) ; Remove duplicate points (null (inters prev (car lst) prev (cadr lst))) ; Remove collineair points ) ) ) ((setq pts (cons (cons 10 (setq prev (car lst))) pts))) ) (setq lst (cdr lst)) ) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length pts)) (cons 8 (getvar 'clayer)) (cons 70 (if closed 1 0)) ) (reverse pts) ) ) ) (defun _side (pline pnt / cpt end target der) ; https://www.theswamp.org/index.php?topic=55685.msg610429#msg610429 (setq cpt (vlax-curve-getClosestPointTo pline pnt) end (vlax-curve-getEndParam pline) target (vlax-curve-getParamAtPoint pline cpt) der (if (and (equal target (fix target) 1e-8) (or (vlax-curve-isClosed pline) (and (not (equal (vlax-curve-getStartParam pline) target 1e-8)) (not (equal end target 1e-8))) ) ) (mapcar '- (polar cpt (angle '(0 0) (vlax-curve-getFirstDeriv pline (rem (+ target 1e-3) end))) 1.0) (polar cpt (angle (vlax-curve-getFirstDeriv pline (rem (+ (- target 1e-3) end) end)) '(0 0)) 1.0) ) (vlax-curve-getFirstDeriv pline target) ) ) (minusp (sin (- (angle cpt pnt) (angle '(0.0 0.0) der)))) ) ;; Intersections - Lee Mac ;; mod - [int] acextendoption enum of intersectwith method (defun LM:intersections ( ob1 ob2 mod / lst rtn ) (if (and (vlax-method-applicable-p ob1 'intersectwith) (vlax-method-applicable-p ob2 'intersectwith) (setq lst (vlax-invoke ob1 'intersectwith ob2 mod)) ) (repeat (/ (length lst) 3) (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn) lst (cdddr lst)) ) ) (reverse rtn) ) (defun _getLength (ent) (- (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (vlax-curve-getDistAtParam ent (vlax-curve-getStartParam ent)) ) ) (defun _wait (msec) (not ( (lambda (start) (while (< (- (getvar 'millisecs) start) msec)) ) (getvar 'millisecs) ) ) ) (defun _addPoints (lst ent1 ent2 pts / len1 len2) (setq len1 (_getLength ent1) len2 (_getLength ent2) lst (vl-remove nil (mapcar (function (lambda (pt / d1 d2) (if (and (setq d1 (vlax-curve-getDistAtPoint ent1 pt)) (setq d2 (vlax-curve-getDistAtPoint ent2 pt)) ) (list (+ (/ d1 len1) (/ d2 len2)) pt) ) )) lst ) ) pts (append lst pts)) ; Animation ; (setq pts (vl-sort pts (function (lambda (a b) (< (car a) (car b)))))) ; (redraw) ; (foreach pt lst ; (tmpPoint (cadr pt) 1 1) ; ) ; ( ; (lambda (lst) ; (while (cadr lst) ; (grdraw (cadar lst) (cadar (setq lst (cdr lst))) 3) ; ) ; ) ; pts ; ) ; (vla-update ent1) ; (_wait 40) ; End animation pts ) (defun _checkOffset (ent1 ent2 offset) (and (equal (distance (vlax-curve-getStartPoint ent1) (vlax-curve-getStartPoint ent2)) offset 1e-4) (equal (distance (vlax-curve-getEndPoint ent1) (vlax-curve-getEndPoint ent2)) offset 1e-4) ) ) (defun _doOffset (offset / lst rtn) ; Global vars: pts ent1 ent2 sides te1 te2 (setq te1 nil) (setq te2 nil) (setq rtn (cond ((equal offset 0.0 1e-8) (if (setq lst (LM:intersections ent1 ent2 acExtendNone)) (setq pts (_addPoints lst ent1 ent2 pts)) ) lst ) ( (or ; Make offset (vl-catch-all-error-p (setq te1 (vl-catch-all-apply 'vlax-invoke (list ent1 'Offset (if (car sides) offset (- offset)))))) (cdr te1) (vl-catch-all-error-p (setq te2 (vl-catch-all-apply 'vlax-invoke (list ent2 'Offset (if (cadr sides) offset (- offset)))))) (cdr te2) (not (_checkOffset ent1 (car te1) offset)) (not (_checkOffset ent2 (car te2) offset)) (vla-put-visible (car te1) :vlax-false) (vla-put-visible (car te2) :vlax-false) ) (princ "\nOffset failed. ") nil ) ((setq lst (LM:intersections (car te1) (car te2) acExtendNone)) (setq pts (_addPoints lst (car te1) (car te2) pts)) lst ) ) ) (if (and te1 (not (vl-catch-all-error-p te1))) (mapcar 'vla-delete te1)) (if (and te2 (not (vl-catch-all-error-p te2))) (mapcar 'vla-delete te2)) rtn ) ;| ; Project Point onto Line - Lee Mac ; @Param pt point to project ; @Param p1 first point of line ; @Param p2 second point of line ; @Returns projected point |; (defun LM:ProjectPointToLine ( pt p1 p2 / nm ) (setq nm (mapcar '- p2 p1) p1 (trans p1 0 nm) pt (trans pt 0 nm)) (trans (list (car p1) (cadr p1) (caddr pt)) nm 0) ) (defun _getAnglesAtParam (ent pa / ang1 ang2) (if (and (vlax-curve-isClosed ent) (= pa 0)) ; Special case for closed Polyline (setq ang1 (vlax-curve-getFirstDeriv ent 1e-14) ang2 (vlax-curve-getFirstDeriv ent (- (fix (vlax-curve-getEndParam ent)) 1e-14))) (setq ang1 (vlax-curve-getFirstDeriv ent (+ pa 1e-14)) ang2 (vlax-curve-getFirstDeriv ent (- pa 1e-14))) ) (if (and ang1 ang2) (list (angle '(0 0 0) ang1) (angle '(0 0 0) ang2) ) ) ) ;| ; Avarage Angle - dexus ; Get angle of a line between two angles ; @Param ang1 real - Angle in radians ; @Param ang2 real - Angle in radians ; @Returns real - Angle in radians |; (defun _avarageAngle (ang1 ang2) (if (< (rem (+ ang1 pi) (+ pi pi)) (rem (+ ang2 pi) (+ pi pi)) ) (+ (* (- ang2 ang1) 0.5) ang1) (+ (* (- ang1 ang2) 0.5) ang2) ) ) ;| ; Calculate exact offset distance on a corner - dexus ; pt1 - Point on corner ; pt2 - Point on other side ; pt3 - Center for bisector ; pt4 - Target for corner of the offset ; pt5 - Find perpendicular point for offset distance ; / ; / ; -------- pt1 pt5 ; \ / ; pt4 ; \ ; ---- pt3 ----- pt2 ----- ; ; @Param ent1 Line to check corners ; @Param ent2 Opposing line ; @Returns List of offset distances (pt1 -> pt5) to calculate |; (defun _cornerOffset (ent1 ent2 / ang1 ang1a ang2 ang3 index pt1 pt2 pt3 pt4 pt5 rtn) (setq index 0) (repeat (fix (vlax-curve-getEndParam ent1)) (and (setq pt1 (vlax-curve-getPointAtParam ent1 index)) ; Point on corner (setq ang1 (_getAnglesAtParam ent1 index)) ; Angles of pt1 (setq ang1a (_avarageAngle (car ang1) (cadr ang1))) (setq te0 (entmakex (list (cons 0 "line") (cons 10 pt1) (cons 11 (polar pt1 (- ang1a halfPi) 1))))) ; Temp line for finding the angle on the other side (foreach pt2 (LM:intersections (vlax-ename->vla-object te0) ent2 acExtendThisEntity) ; Point on other side (and (setq ang2 (_getAnglesAtParam ent2 (vlax-curve-getParamAtPoint ent2 pt2))) ; Angle of pt2 (if (equal (rem (car ang1) pi) (rem (car ang2) pi) 1e-8) ; Is parallel? (and (setq pt3 (mapcar (function (lambda (a b) (* (+ a b) 0.5))) pt1 pt2)) ; Midpoint (setq ang3 (car ang1)) ; Same angle als ang1 ) (and (setq pt3 (inters pt1 (polar pt1 (car ang1) 1) pt2 (polar pt2 (car ang2) 1) nil)) ; Find center for bisector (setq ang3 (_avarageAngle (angle pt1 pt3) (angle pt2 pt3))) ; Angle of bisector ) ) (setq pt4 (inters pt3 (polar pt3 ang3 1) pt1 (polar pt1 (+ ang1a halfPi) 1) nil)) ; Find target for corner of the offset (setq pt5 (LM:ProjectPointToLine pt4 pt1 (polar pt1 (+ (car ang1) halfPi) maxlen))) ; Find perpendicular point for offset distance (setq rtn (cons (distance pt1 pt5) rtn)) ; Return offset distance ; Animation ; (progn ; (redraw) ; (grdraw pt1 pt2 1) ; (grdraw pt4 pt5 2) ; (grdraw pt1 pt5 2) ; (grdraw pt2 pt5 2) ; (vla-update ent1) ; (_wait 120) ; ) ; End Animation ) ) ) (if (not (vlax-erased-p te0)) (entdel te0)) (setq index (1+ index)) ) rtn ) (defun _rlw (lw / x1 x2 x3 x4 x5 x6) (if (and lw (= (cdr (assoc 0 lw)) "LWPOLYLINE")) (progn (foreach a1 lw (cond ((= (car a1) 10) (setq x2 (cons a1 x2))) ((= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4))) ((= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3))) ((= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5))) ((= (car a1) 210) (setq x6 (cons a1 x6))) (t (setq x1 (cons a1 x1))) ) ) (append (reverse x1) (append (apply (function append) (apply (function mapcar) (cons 'list (list x2 (cdr (reverse (cons (car x3) (reverse x3)))) (cdr (reverse (cons (car x4) (reverse x4)))) (cdr (reverse (cons (car x5) (reverse x5)))) )) )) x6) ) ) ) ) (if (and (not (while (cond ((not (setq ss (ssget '((0 . "LWPOLYLINE"))))) (princ "\nNothing selected. Try again...\n") ) ((/= (sslength ss) 2) (princ "\nSelect 2 polylines! Try again...\n") ) ((and (setq ent1 (ssname ss 0)) (setq ent2 (ssname ss 1)) (setq enx2 (entget ent2)) (setq ent1 (vlax-ename->vla-object ent1)) (setq ent2 (vlax-ename->vla-object ent2)) ) nil ; Stop loop ) ) ) ) ent1 ent2 ) (progn (and (< (distance (vlax-curve-getStartPoint ent1) (vlax-curve-getEndPoint ent2)) (distance (vlax-curve-getEndPoint ent1) (vlax-curve-getEndPoint ent2)) ) (setq flipped t) (entmod (_rlw enx2)) ) (setq sides (mapcar (function (lambda (a b / s m e) (setq s (_side a (vlax-curve-getStartPoint b)) m (_side a (vlax-curve-getPointAtParam b (* 0.5 (vlax-curve-getEndParam b)))) e (_side a (vlax-curve-getEndPoint b))) (or (and s m) (and s e) (and m e)) )) (list ent1 ent2) (list ent2 ent1) ) ) (if (not (numberp halfPi)) (setq halfPi (* pi 0.5))) (setq maxlen (* 1.1 (max (_getLength ent1) (_getLength ent2) ( (lambda (ent1 ent2 / step de1 div p_step dis dmax) (setq step (/ (setq de1 (vlax-curve-getDistAtParam ent1 (vlax-curve-getEndParam ent1))) 500) div step dmax 0.00) (while (< div de1) (setq p_step (vlax-curve-getPointAtDist ent1 div) dis (distance p_step (vlax-curve-getClosestPointTo ent2 p_step))) (if (> dis dmax) (setq dmax dis)) (setq div (+ div step)) ) dmax ) ent1 ent2 ) ) ) ) (mapcar ; Add half distances from closest point to every vertex (function (lambda (ent1 ent2 / index pt) (setq index 0) (repeat (fix (vlax-curve-getEndParam ent1)) (setq pt (vlax-curve-getPointAtParam ent1 index) corners (cons (* (distance pt (vlax-curve-getClosestPointTo ent2 pt)) 0.5) corners) index (1+ index)) ; Animation ; (redraw) ; (grdraw pt (vlax-curve-getClosestPointTo ent2 pt) 4) ; ( ; (lambda (mid) (grdraw mid (polar mid (+ (angle pt (vlax-curve-getClosestPointTo ent2 pt)) halfPi) (car corners)) 2)) ; (mapcar (function (lambda (a b) (* (+ a b) 0.5))) pt (vlax-curve-getClosestPointTo ent2 pt)) ; ) ; (vla-update ent1) ; (_wait 120) ; End animation ) )) (list ent1 ent2) (list ent2 ent1) ) (setq corners (vl-sort (append corners (_cornerOffset ent1 ent2) (_cornerOffset ent2 ent1)) '<) offsetdistance (/ maxlen 512.0)) (if (LM:intersections ent1 ent2 acExtendNone) ; For crossing polylines, add negative values (setq offset (- maxlen) corners (append (mapcar '- (reverse corners)) corners)) (setq offset 0.0) ) (while (progn (while (and corners (> offset (car corners))) ; Calculated offset values to check (_doOffset (car corners)) (setq corners (cdr corners)) ) (setq loop ; Incremental check (cond ((> offset maxlen) nil) ((_doOffset offset) (setq start t)) ((not start) t) (start nil) ) ) (setq offset (+ offset offsetdistance)) loop ) ) (if flipped (entmod enx2)) (if pts ; Draw polyline (_polyline (mapcar 'cadr (vl-sort pts (function (lambda (a b) (< (car a) (car b)))))) (and (vlax-curve-isClosed ent1) (vlax-curve-isClosed ent2)) ) ) ) ) (redraw) (princ) ) And here is an animation of it working just because they are fun to look at :

I added extra checks on every vertex like @PGia suggested two weeks ago. Those I added to the offset-loop and it gives the best of both worlds. Every point that is calculated should be the exact middle because the offset is the same on both sides. Still not perfect, but pretty close I think. ;| ; Calculate centerline between two polylines - dexus ; Function checks intersections of the offsets of two lines to create a middle/avarage line. |; (defun c:cl (/ ent1 ent2 loop maxlen offset offsetdistance pts s1 s2 ss start LM:ProjectPointToLine LM:intersections _addPoints _avarageAngle _cornerOffset _doOffset _getAnglesAtParam _getLength _polyline _side _wait) ;| ; Draw Polyline - dexus ; Draw a polyline from a list of points, but filter out colinear points ; @Param lst list of points ; @Returns ename of polyline |; (defun _polyline (lst / prev pts) (while lst (cond ((and (cdr lst) prev (null (inters prev (car lst) prev (cadr lst))))) ((setq pts (cons (cons 10 (setq prev (car lst))) pts))) ) (setq lst (cdr lst)) ) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length pts)) (cons 8 (getvar 'clayer)) (cons 70 0) ) (reverse pts) ) ) ) (defun _side (pline pnt / cpt end target der) (setq cpt (vlax-curve-getClosestPointTo pline pnt) ; https://www.theswamp.org/index.php?topic=55685.msg610429#msg610429 end (vlax-curve-getEndParam pline) target (vlax-curve-getParamAtPoint pline cpt) der (if (and (equal target (fix target) 1e-8) (or (vlax-curve-isClosed pline) (and (not (equal (vlax-curve-getStartParam pline) target 1e-8)) (not (equal end target 1e-8))) ) ) (mapcar '- (polar cpt (angle '(0 0) (vlax-curve-getFirstDeriv pline (rem (+ target 1e-3) end))) 1.0) (polar cpt (angle (vlax-curve-getFirstDeriv pline (rem (+ (- target 1e-3) end) end)) '(0 0)) 1.0) ) (vlax-curve-getFirstDeriv pline target) ) ) (minusp (sin (- (angle cpt pnt) (angle '(0.0 0.0) der)))) ) ;; Intersections - Lee Mac ;; mod - [int] acextendoption enum of intersectwith method (defun LM:intersections ( ob1 ob2 mod / lst rtn ) (if (and (vlax-method-applicable-p ob1 'intersectwith) (vlax-method-applicable-p ob2 'intersectwith) (setq lst (vlax-invoke ob1 'intersectwith ob2 mod)) ) (repeat (/ (length lst) 3) (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn) lst (cdddr lst)) ) ) (reverse rtn) ) (defun _getLength (ent) (- (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (vlax-curve-getDistAtParam ent (vlax-curve-getStartParam ent)) ) ) (defun _wait (msec) (not ( (lambda (start) (while (< (- (getvar 'millisecs) start) msec)) ) (getvar 'millisecs) ) ) ) (defun _addPoints (lst ent pts / len) (setq len (_getLength ent)) (setq lst (mapcar (function (lambda (pt) (list (/ (vlax-curve-getDistAtPoint ent pt) len) pt))) lst)) (setq pts (append lst pts)) ; Animation ; (setq pts (vl-sort pts (function (lambda (a b) (< (car a) (car b)))))) ; (redraw) ; ( ; (lambda (lst) ; (while (cadr lst) ; (grdraw (cadar lst) (cadadr lst) 3) ; (setq lst (cdr lst)) ; ) ; ) ; pts ; ) ; (vla-update ent) ; (_wait 40) ; End animation pts ) (defun _doOffset (offset / te1 te2 lst rtn) ; Global vars: pts ent1 ent2 s1 s2 (setq rtn (cond ((equal offset 0.0 1e-4) (if (setq lst (LM:intersections ent1 ent2 acExtendNone)) (setq pts (_addPoints lst ent1 pts)) ) lst ) ( (or ; Make offset (vl-catch-all-error-p (setq te1 (vl-catch-all-apply 'vlax-invoke (list ent1 'Offset (if s1 offset (- offset)))))) (vl-catch-all-error-p (setq te2 (vl-catch-all-apply 'vlax-invoke (list ent2 'Offset (if s2 offset (- offset)))))) (vla-put-color (car te1) 252) (vla-put-color (car te2) 252) ) (princ "\nOffset failed. ") nil ) ((setq lst (LM:intersections (car te1) (car te2) acExtendNone)) (setq pts (_addPoints lst (car te1) pts)) lst ) ) ) (if (and te1 (not (vl-catch-all-error-p te1))) (mapcar 'vla-delete te1)) (if (and te2 (not (vl-catch-all-error-p te2))) (mapcar 'vla-delete te2)) rtn ) ;| ; Project Point onto Line - Lee Mac ; @Param pt point to project ; @Param p1 first point of line ; @Param p2 second point of line ; @Returns projected point |; (defun LM:ProjectPointToLine ( pt p1 p2 / nm ) (setq nm (mapcar '- p2 p1) p1 (trans p1 0 nm) pt (trans pt 0 nm)) (trans (list (car p1) (cadr p1) (caddr pt)) nm 0) ) (defun _getAnglesAtParam (ent pa / ang1 ang2) (if (and (vlax-curve-isClosed ent) (= pa 0)) ; Special case for closed Polyline (list (setq ang1 (vlax-curve-getFirstDeriv ent 1e-14)) (setq ang2 (vlax-curve-getFirstDeriv ent (- (fix (vlax-curve-getEndParam ent)) 1e-14))) ) (list (setq ang1 (vlax-curve-getFirstDeriv ent (+ pa 1e-14))) (setq ang2 (vlax-curve-getFirstDeriv ent (- pa 1e-14))) ) ) (setq ang1 (angle '(0 0 0) ang1)) (setq ang2 (angle '(0 0 0) ang2)) (list ang1 (* (+ ang1 ang2) 0.5) ang2) ) ;| ; Avarage Angle - dexus ; Get angle of a line between two angles ; @Param ang1 real - Angle in radians ; @Param ang2 real - Angle in radians ; @Returns real - Angle in radians |; (defun _avarageAngle (ang1 ang2) (if (< (rem (+ ang1 pi) (+ pi pi)) (rem (+ ang2 pi) (+ pi pi)) ) (+ (* (- ang2 ang1) 0.5) ang1) (+ (* (- ang1 ang2) 0.5) ang2) ) ) ;| ; Calculate exact offset distance on a corner - dexus ; pt1 - Point on corner ; pt2 - Point on other side ; pt3 - Center for bisector ; pt4 - Target for corner of the offset ; pt5 - Find perpendicular point for offset distance ; / ; / ; -------- pt1 pt5 ; \ / ; pt4 ; \ ; ---- pt3 ----- pt2 ----- ; ; @Param ent1 Line to check corners ; @Param ent2 Opposing line ; @Returns List of offset distances (pt1 -> pt5) to calculate |; (defun _cornerOffset (ent1 ent2 / ang1 ang2 ang3 index pt1 pt2 pt3 pt4 pt5 rtn tmp vertex) (setq vertex (fix (vlax-curve-getEndParam ent1)) halfPi (* pi 0.5) index 0) (repeat vertex (and (setq pt1 (vlax-curve-getPointAtParam ent1 index)) ; Point on corner (setq ang1 (_getAnglesAtParam ent1 index)) ; Angles of pt1 (setq tmp ; Temp line for finding the angle on the other side (entmakex (list '(0 . "line") (cons 10 (polar pt1 (+ (cadr ang1) halfPi) maxlen)) (cons 11 (polar pt1 (- (cadr ang1) halfPi) maxlen)) ) ) ) (setq pt2 (car (LM:intersections (vlax-ename->vla-object tmp) ent2 acExtendNone))) ; Point on other side (setq ang2 (_getAnglesAtParam ent2 (vlax-curve-getParamAtPoint ent2 pt2))) ; Angle of pt2 (if (equal (rem (car ang1) pi) (rem (car ang2) pi) 1e-9) ; Is parallel? (and (setq pt3 (mapcar (function (lambda (a b) (* (+ a b) 0.5))) pt1 pt2)) ; Midpoint (setq ang3 (car ang1)) ; Same angle als ang1 ) (and (setq pt3 (inters pt1 (polar pt1 (car ang1) 1) pt2 (polar pt2 (car ang2) 1) nil)) ; Find center for bisector (setq ang3 (_avarageAngle (angle pt1 pt3) (angle pt2 pt3))) ; Angle of bisector ) ) (setq pt4 (inters pt3 (polar pt3 ang3 1) pt1 (polar pt1 (+ (cadr ang1) halfPi) 1) nil)) ; Find target for corner of the offset (setq pt5 (LM:ProjectPointToLine pt4 pt1 (polar pt1 (+ (car ang1) halfPi) maxlen))) ; Find perpendicular point for offset distance (setq rtn (cons (distance pt1 pt5) rtn)) ; Return offset distance ) (if (entget tmp) (entdel tmp)) (setq index (1+ index)) ) rtn ) (if (not (while (cond ((not (setq ss (ssget '((0 . "LWPOLYLINE"))))) (princ "\nNothing selected. Try again...\n") ) ((/= (sslength ss) 2) (princ "\nSelect 2 polylines! Try again...\n") ) ((and (setq ent1 (ssname ss 0)) (setq ent2 (ssname ss 1)) (setq ent1 (vlax-ename->vla-object ent1)) (setq ent2 (vlax-ename->vla-object ent2)) ) nil ; Stop loop ) ) ) ) (progn (setq s1 (_side ent1 (vlax-curve-getStartPoint ent2))) (setq s2 (_side ent2 (vlax-curve-getStartPoint ent1))) (setq maxlen (* 1.1 (max (_getLength ent1) (_getLength ent2) (distance (vlax-curve-getStartPoint ent1) (vlax-curve-getStartPoint ent2))))) (setq offsetdistance (/ maxlen 1024.0)) (if (LM:intersections ent1 ent2 acExtendNone) (setq offset (- maxlen)) (setq offset 0.0) ) (mapcar '_doOffset (_cornerOffset ent1 ent2)) (mapcar '_doOffset (_cornerOffset ent2 ent1)) (while (progn (setq loop (cond ((> offset maxlen) nil) ((_doOffset offset) (setq start t)) ((not start) t) (start nil) ) ) (setq offset (+ offset offsetdistance)) loop ) ) (if pts (_polyline (mapcar 'cadr (vl-sort pts (function (lambda (a b) (< (car a) (car b))))))) ) ) ) (redraw) (princ) )

Here I've revised Helmut's code and made it faster. ;; ; ;; Pathfinding with the A* algorithm by ymg 22/07/2024 ; ;; ; ;; Revised a prog by HELMUT SCHRÖDER - heschr@gmx.de - 2014-09-14 ; ;; found at Cadtutor.net ; ;; ; ;; Kept the same format for edges list but added lines as valid choice ; ;; Format: (((x1 y1) (x2 y2)) (((x2 y2) (x3 y3))....(xn yn))) ; ;; ; ;; The user is asked to pick a start and an endpoint. ; ;; The program will find the shortest path in a network of connected ; ;; polylines and/or lines and draw a new polyline representing the result. ; ;; ; ;; Two lists of nodes openlst and closelst are created from the above ; ;; mentionned edges list. The format of a node list is: ; ;; (((Point) (Prev Point) Cumulated_Distance Estimated_Total_Distance)...) ; ;; ; ;; Main change from origina are: ; ;; - cons the list instead of append ; ;; - vl-sort the openlist instead of the quicksort ; ;; - Replaced and renamed some vars and subroutine. ; ;; - Added fuzz 1e-4 to all points comparison ; ;; - Change the get_path function ; ;; - Added line as possible edges ; ;; - Added an error handler ; ;; - Added a timer to the search portion of the program ; ;; ; ;; The above changes amounted to an acceleration of about 4x from the ; ;; original program. ; ;; : ;; If you compile this program to a .fas you'll get more than 10x faster. ; ;; ; (defun c:A* ( / ssl ssp i edges startp endp openlst closelst found acdoc Edgelay Pathlay Pathcol Pathlwt) (vl-load-com) ; Changes values of following 4 global variables to suit your need. ; (setq Edgelay "Edges" Pathlay "Path" Pathcol 1 ; 1=Red 2=Yellow etc. ; Pathlwt 70 ; lineweight for path 0.7mm ; ) (or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))) (set_errhandler '("CLAYER" "OSMODE" "CMDECHO")) (setvar 'CMDECHO 0) (setvar 'OSMODE 1) (if (setq ssp (ssget '"X" (list (cons 0 "LWPOLYLINE") (cons 8 Edgelay)))) (foreach en (mapcar (function cadr) (ssnamex ssp)) (setq edges (append edges (mk_edge (listpol2d en)))) ) ) (if (setq ssl (ssget '"X" (list (cons 0 "LINE") (cons 8 Edgelay)))) (foreach en (mapcar (function cadr) (ssnamex ssl)) (setq edges (cons (list (butlast (vlax-curve-getstartpoint en)) (butlast (vlax-curve-getendpoint en))) edges)) ) ) (setq startp (butlast (getpoint "\nPick Start Point: ")) ; Startpoint - reduced to 2D ; endp (butlast (getpoint "\nPick End Point: ")) ; Endpoint - reduced to 2D ; openlst (list (list startp '(0 0) 0.0 (distance startp endp))) ; Add starting node to openlst ; ) (vla-startundomark acdoc) (setq ti (getvar 'MILLISECS)) (while (and openlst (not found)) (setq node (car openlst)) (if (equal (car node) endp 1e-4) (setq found T closelst (cons node closelst)) (setq closelst (cons node closelst) openlst (upd_openlst edges node endp (cdr openlst) closelst) ) ) ) (if found (mk_lwp (get_path closelst)) (alert "No path was found") ) (princ (strcat "\nExecution time:" (itoa (- (getvar 'MILLISECS) ti)) " milliseconds.")) (*error* nil) ) ;; ; ;; upd_openlst ; ;; ; ;; Each node of the openlst is passed to this sub and we scan the edges list ; ;; to find the corresponding edges. Then both points of the edges are tested ; ;; for equality to the nodes. The fixed cost (distance) is updated and so is ; ;; the estimated total distance. Updates are first put in a temporary node. ; ;; ; ;; We then proceed to test if the temp variable is already in the closelst ; ;; and proceed to the next edge. ; ;; ; ;; If temp is true and temp is not in closelst we go to the recursive sub ; ;; in_openlst which adjust the values and return the updated openlst : ;; ; ;; Upon return we sort the openlst on smallest estimated distance ; ;; and return the openlst to the main routine ; ;; ; (defun upd_openlst (edges node endp openlst closelst / pt fcost p1 p2 d temp) (setq pt (car node) fcost (caddr node)) (while edges (setq p1 (caar edges) p2 (cadar edges) edges (cdr edges) d (distance p1 p2) temp nil) ;Testing both points of an edge and building a temporary node ; (cond ((equal pt p1 1e-4) (setq temp (list p2 p1 (+ fcost d) (+ fcost d (distance p2 endp))))) ((equal pt p2 1e-4) (setq temp (list p1 p2 (+ fcost d) (+ fcost d (distance p1 endp))))) ) (if (and temp (not (memberfuzz (car temp) closelst))) (setq openlst (in_openlst temp openlst)) ) ) ; Keep openlist sorted on smallest Estimated Total Cost ; (print (vl-sort openlst (function (lambda(a b)(< (cadddr a) (cadddr b))))) ) ) ;in_lst Replaced by memberfuzz ; ;(defun in_lst (pt lst) ; (cond ; ((not lst) nil) ; ((equal pt (caar lst) 1e-4) lst) ; (T (in_lst pt (cdr lst))) ; ) ;) ; returns a new openlst with a double exchanged if cost is lower ; ;; ; (defun in_openlst (node lst) (cond ((not lst) (list node)) ((equal (car node) (caar lst) 1e-4) (if (< (cadddr node) (cadddr (car lst))) (cons node (cdr lst)) lst ) ) (T (cons (car lst) (in_openlst node (cdr lst)))) ) ) (defun in_openlst2 (node lst / s c) (setq s (splitat (caar node) lst) c (cadddr node)) (cond ((not lst) (list node)) ((not (car s)) (cons node (cadr s))) ((not (cadr s)) (cons node (car s))) (T (if (< (cadddr node) (cadddr (cadr s))) (append (car s) (cons node (cdr s))) lst )) ;(T (c ns node lst)) ) ) ;; ; ;; listpol2D by ymg (Simplified a Routine by Gile Chanteau ; ;; ; ;; Parameter: en, Entity Name or Object Name of Any Type of Polyline ; ;; ; ;; Returns: List of Points in 2D WCS ; ;; ; ;; Notes: Requires butlast function for 2d points. ; ;; ; (defun listpol2d (en / i lst) (repeat (setq i (fix (1+ (vlax-curve-getEndParam en)))) (setq lst (cons (butlast (vlax-curve-getPointAtParam en (setq i (1- i)))) lst)) ) ) ;; ; ;; mk_edge ; ;; ; ;; From a list of consecutives points as supplied by listpol2D, ; ;; Returns a list of edges (((x1 y1)(x2 y2)) ((x2 y2)(x3 y3))...) ; ;; ; (defun mk_edge (lst) (mapcar (function (lambda (a b) (list a b ))) lst (cdr lst)) ) ;; ; ;; butlast ; ;; ; ;; Returns a list without the last item ; ;; Used here mainly to change points to 2D ; ;; ; (defun butlast (lst) (reverse (cdr (reverse lst)))) ;; ; ;; get_path ; ;; ; ;; Returns The list of points of shortest path found from closelst. ; ;; ; (defun get_path (lst / path) (setq path (list (caar lst)) prev (cadar lst) lst (cdr lst)) (while (setq lst (memberfuzz prev lst)) (setq prev (cadar lst) path (cons (caar lst) path) ) ) path ) ;; ; ;; memberfuzz by Gile Chanteau ; ;; ; ;; Modified to work with nodes list ; ;; ; (defun memberfuzz (p lst) (while (and lst (not (equal p (caar lst) 1e-4))) (setq lst (cdr lst)) ) lst ) (defun splitat (p lst / tr) (while (and lst (not (equal p (caar lst) 1e-4))) (setq tr (cons (car lst) tr) lst (cdr lst)) ) (list (reverse tr) lst) ) (defun truncfuzz (p lst) (if (and lst (not (equal p (caar lst) 1e-4))) (cons (car lst) (truncfuzz p (cdr lst))) ) ) (defun posfuzz (p lst) (- (length lst) (length (memberfuzz p lst))) ) (defun rotleft (lst) (append (cdr lst) (list (car lst)))) (defun rotright (lst) (cons (last lst) (butlast lst))) ;; ; ;; mk_lwp ; ;; ; ;; Draw an lwpolyline given a point list ; ;; ; ;; Will be drawn on layer with color and lineweight defined by Variables ; ;; at beginnung of program. ; ;; ; (defun mk_lwp (pl) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 8 Pathlay) (cons 62 Pathcol) (cons 90 (length pl)) (cons 70 0) (cons 370 Pathlwt) ) (mapcar (function (lambda (a) (cons 10 a))) pl) ) ) ) ;; Error Handler by Elpanov Evgenyi ; (defun set_errhandler (l) (setq varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) l)) ) (defun *error* (msg) (mapcar 'eval varl) (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (vla-endundomark acdoc) (princ) ) (princ "A* to start") Astar rev3.lsp astar test.dwg

From what I inspected... That @dexus code works well with correct implementation of djikstra... When I used his code it bumped into endless (while) loop... Here is my revision and it should work, but result is not exact... Seems that resulting polyline is rummaging between references... Here is my revision : ; Attempt at drawing a centerline using voronoi diagram ; Voronoi diagram calculations found here: https://www.theswamp.org/index.php?topic=45085.msg503034#msg503034 (defun c:cl (/ _side ent->pts removeDuplicates minlen RemoveIDDup minpath1 triangulate getcircumcircle ss ent1 ent2 pl s1 s2 vor line) (defun _side (pline pnt / cpt end target der) (setq cpt (vlax-curve-getClosestPointTo pline pnt) ; https://www.theswamp.org/index.php?topic=55685.msg610429#msg610429 end (vlax-curve-getEndParam pline) target (vlax-curve-getParamAtPoint pline cpt) der (if (and (equal target (fix target) 1e-8) (or (vlax-curve-isClosed pline) (and (not (equal (vlax-curve-getStartParam pline) target 1e-8)) (not (equal end target 1e-8))) ) ) (mapcar (function -) (polar cpt (angle (list 0.0 0.0) (vlax-curve-getFirstDeriv pline (rem (+ target 1e-3) end))) 1.0) (polar cpt (angle (vlax-curve-getFirstDeriv pline (rem (+ (- target 1e-3) end) end)) (list 0.0 0.0)) 1.0) ) (vlax-curve-getFirstDeriv pline target) ) ) (minusp (sin (- (angle cpt pnt) (angle (list 0.0 0.0) der)))) ) (defun _polyline (pts) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length pts)) (cons 8 (getvar (quote clayer))) (cons 70 0) ) (mapcar (function (lambda (x) (cons 10 x))) pts) ) ) ) (defun ent->pts (ent acc / end ind step rtn) (setq end (vlax-curve-getEndParam ent)) (setq ind (vlax-curve-getStartParam ent)) (setq step (/ end (float acc))) (while (< ind end) (setq rtn (cons (vlax-curve-getPointAtParam ent ind) rtn)) (setq ind (+ ind step)) ) rtn ) (defun removeDuplicates (lst / a ll) (while (setq a (car lst)) (if (vl-some (function (lambda (x) (equal x a 1e-6))) (cdr lst)) (setq ll (cons a ll) lst (vl-remove-if (function (lambda (x) (equal x a 1e-6))) (cdr lst))) (setq ll (cons a ll) lst (cdr lst)) ) ) (reverse ll) ) ; https://www.theswamp.org/index.php?topic=45092.msg578984#msg578984 (defun minlen (LtsLine startEnd / ID1 ID2 IDEnd IDStart LtsID LtsIDFil LtsIDPnt LtsID_Edge LtsPath P1 P2 listpoint) (setq LtsPnt (removeDuplicates (apply (function append) LtsLine))) (setq LtsIDPnt (mapcar (function (lambda (x) (list (vl-position x LtsPnt) x))) LtsPnt)) (setq LtsID (mapcar (function (lambda (x) (vl-position x LtsPnt))) LtsPnt)) (setq IDStart (vl-position (caar startEnd) LtsPnt)) (setq IDEnd (vl-position (caadr startEnd) LtsPnt)) (setq LtsID_Edge (list)) (foreach e LtsLine (setq ID1 (caar (vl-remove-if-not (function (lambda (x) (equal (car e) (cadr x) 1e-6))) LtsIDPnt))) (setq ID2 (caar (vl-remove-if-not (function (lambda (x) (equal (cadr e) (cadr x) 1e-6))) LtsIDPnt))) (setq LtsID_Edge (append LtsID_Edge (list (list ID1 ID2 (distance (nth ID1 LtsPnt) (nth ID2 LtsPnt)))))) ) (setq LtsIDFil (RemoveIDDup LtsID_Edge)) (setq LtsPath (minpath1 IDStart IDEnd LtsID LtsIDFil)) (setq listpoint (mapcar (function (lambda (x) (nth (car x) LtsPnt))) LtsPath)) ) (defun RemoveIDDup (l) (if l (cons (car l) (RemoveIDDup (vl-remove-if (function (lambda (x) (or (and (= (car x) (car (car l))) (= (cadr x) (cadr (car l))) ) (and (= (car x) (cadr (car l))) (= (cadr x) (car (car l))) ) ) )) (cdr l) ) ) ) ) ) (defun minpath1 (g f nodes edges / brname clnodes closedl go new nodname old openl totdist ppath) (setq nodes (vl-remove g nodes)) (setq openl (list (list g 0 nil))) (setq closedl nil) (setq go t) (foreach n nodes (setq nodes (subst (list n 0 nil) n nodes)) ) (while (and go (not (= (caar closedl) f))) (setq nodname (caar openl)) (setq totdist (cadar openl)) (setq closedl (cons (car openl) closedl)) (setq openl (cdr openl)) (setq clnodes (mapcar (function car) closedl)) (foreach e edges (setq brname nil) (cond ( (= (car e) nodname) (setq brname (cadr e)) ) ( (= (cadr e) nodname) (setq brname (car e)) ) ) (if brname (progn (setq new (list brname (+ (caddr e) totdist) nodname)) (cond ( (member brname clnodes) ) ( (setq old (vl-some (function (lambda (x) (if (= brname (car x)) x))) openl)) (if (< (cadr new) (cadr old)) (setq openl (subst new old openl)) ) ) ( t (setq openl (cons new openl)) ) ) ) ) ) (setq openl (vl-sort openl (function (lambda (a b) (< (cadr a) (cadr b)))))) (and (null openl) (null (caar closedl)) (setq go nil)) ) (setq ppath (list (car closedl))) (foreach n closedl (if (= (car n) (caddr (car ppath))) (setq ppath (cons n ppath)) ) ) ppath ) ;;***************************************************************************; ;; Triangulate ; ;; Structure of Program by ElpanovEvgeniy ; ;; 17.10.2008 ; ;; edit 20.05.2011 ; ;; Program triangulate an irregular set of 3d points. ; ;; Modified and Commented by ymg June 2011. ; ;; Modified to operate on index by ymg in June 2013. ; ;; Contour Generation added by ymg in July 2013. ; ;; Removed lots of code not used for centerline function November 2025. ; ;;***************************************************************************; (defun triangulate (pl / a al b bb c cp ctr e el epos l n np npos pt r sl tl tr vl vor xmax xmin ymax ymin) (if pl (progn (setq tl nil pl (vl-sort pl (function (lambda (a b) (< (car a) (car b))))) ; Sort points list on x coordinates bb (list (apply 'mapcar (cons 'min pl)) (apply 'mapcar (cons 'max pl))) ; Replaced code to get the min and max with 3d Bounding Box Routine ; A bit slower but clearer. zmin and zmax kept for contouring xmin (caar bb) xmax (caadr bb) ymin (cadar bb) ymax (cadadr bb) np (length pl) ; Number of points to insert cp (list (/ (+ xmin xmax) 2.0) (/ (+ ymin ymax) 2.0)) ; Midpoint of points cloud and center point of circumcircle through supertriangle. r (* (distance cp (list xmin ymin)) 20) ; This could still be too small in certain case. No harm if we make it bigger. sl (list (list (+ (car cp) r) (cadr cp) 0) (list (- (car cp) r) (+ (cadr cp) r) 0) (list (- (car cp) r) (- (cadr cp) r) 0) ) ; sl list of 3 points defining the Supertriangle, I have tried initializing to an infinite triangle but it slows down calculation pl (append pl sl) ; Vertex of Supertriangle are appended to the Point list sl (list np (+ np 1) (+ np 2)) ; sl now is a list of index into point list defining the supertriangle al (list (list xmax cp r sl)) ; Initialize the Active Triangle list ; al is a list that contains active triangles defined by 4 items: ; item 0: Xmax of points in triangle. ; item 1: List 2d coordinates of center of circle circumscribing triangle. ; item 2: Radius of above circle. ; item 3: List of 3 indexes to vertices defining the triangle ctr (list cp) ; added for Voronoi n -1 ; n is a counting index into Point List ) ; Begin insertion of points (repeat np (setq n (1+ n) ; Increment Index into Point List pt (nth n pl) ; Get one point from point list el nil) ; el list of triangles edges (repeat (length al) ; Loop to go through Active triangle list (setq tr (car al) ; Get one triangle from active triangle list. al (cdr al)) ; Remove the triangle from the active list. (cond ( (< (car tr) (car pt)) (setq tl (cons (cadddr tr) tl) ctr (cons (cadr tr) ctr)) ; added for voronoi ) ; This triangle inactive. We store it's 3 vertex in tl (Final triangle list). ( (< (distance pt (cadr tr)) (caddr tr)) ; pt is inside the triangle. (setq tr (cadddr tr) ; Trim tr to vertex of triangle only. a (car tr) ; Index of First point. b (cadr tr) ; Index of Second point. c (caddr tr)) ; Index of Third point. (setq el (vl-list* (list a b) (list b c) (list c a) el)) ; ((a b) (b c) (c a) (. .) (. .).....) ) ( t (setq l (cons tr l)) ) ; tr did not meet any cond so it remain active. We store it in the swap list ) ; End cond ) ; End repeat (length al) (setq al l ; Restore active triangle list from the temporary list. l nil) ; Clear the swap list to prepare for next insertion. ; Removes doubled edges, calculates circumcircles and add them to al (while el (if (or (member (reverse (car el)) el) (member (car el) (cdr el)) ) (setq el (vl-remove (reverse (car el)) el) el (vl-remove (car el) el)) (setq al (cons (getcircumcircle n (car el) pl) al) el (cdr el)) ) ) ) ; End repeat np ; We are done with points insertion. Any triangle left in al is added to tl (foreach tr al (setq tl (cons (cadddr tr) tl) ctr (cons (cadr tr) ctr)) ; Added for Voronoi ) ; Extract all triangle edges from tl and form edges list el (setq el nil) (foreach tr tl (setq el (vl-list* (list (caddr tr) (car tr)) (list (cadr tr) (caddr tr)) (list (car tr) (cadr tr)) el ) ) ) (setq el (reverse el)) ; Here let's draw the Voronoi Diagram (setq vl nil) (foreach e el (setq npos (vl-position (reverse e) el) epos (vl-position e el)) (if npos (setq vl (cons (list (/ npos 3) (/ epos 3)) vl)) (setq vl (cons (list (- (length ctr) 1) (/ epos 3)) vl)) ) ) (setq vor nil) (while vl (setq e (car vl) vl (vl-remove (reverse e) (cdr vl)) vor (cons e vor)) ) (mapcar (function (lambda (v) (list (nth (cadr v) ctr) (nth (car v) ctr) ) )) (cdddr ; Remove the edges of Supercircle (vl-sort vor (function (lambda (a b) (> (car a) (car b)) )) ) ) ) ) ) ) ;;************************************************************************************************; ;; Written by ElpanovEvgeniy ; ;; 17.10.2008 ; ;; Calculation of the centre of a circle and circle radius ; ;; for program triangulate ; ;; ; ;; Modified ymg june 2011 (renamed variables) ; ;; Modified ymg June 2013 to operate on Index ; ;;************************************************************************************************; (defun getcircumcircle (a el pl / b c c2 cp r ang vl pt) (setq pt (nth a pl) b (nth(car el) pl) c (nth(cadr el) pl) c2 (list (car c) (cadr c)) ; c2 is point c but in 2d vl (list a (car el) (cadr el))) (if (not (zerop (setq ang (- (angle b c) (angle b pt))))) (progn (setq cp (polar c2 (+ -1.570796326794896 (angle c pt) ang) (setq r (/ (distance pt c2) (sin ang) 2.0))) r (abs r)) (list (+ (car cp) r) cp r vl) ) ) ) (if (not (while (cond ( (not (setq ss (ssget (list (cons 0 "LWPOLYLINE"))))) (princ "\nNothing selected. Try again...\n") ) ( (/= (sslength ss) 2) (princ "\nSelect 2 polylines! Try again...\n") ) ( (and (setq ent1 (ssname ss 0)) (setq ent2 (ssname ss 1)) (setq pl (append (ent->pts ent1 100) (ent->pts ent2 100))) (setq ent1 (vlax-ename->vla-object ent1)) (setq ent2 (vlax-ename->vla-object ent2)) ) nil ; Stop loop ) ) ) ) (progn (setq s1 (_side ent1 (vlax-curve-getStartPoint ent2))) (setq s2 (_side ent2 (vlax-curve-getStartPoint ent1))) (setq vor (triangulate pl)) (setq vor (vl-remove-if-not (function (lambda (line) (and (equal s1 (_side ent1 (car line))) (equal s1 (_side ent1 (cadr line))) (equal s2 (_side ent2 (car line))) (equal s2 (_side ent2 (cadr line))) ) )) (vl-remove-if (function (lambda (x) (or (equal x (list nil nil)) (not (car x)) (not (cadr x))))) vor) ) ) (if (< (distance (vlax-curve-getStartPoint ent1) (vlax-curve-getEndPoint ent2)) (distance (vlax-curve-getEndPoint ent1) (vlax-curve-getEndPoint ent2)) ) (setq start (list (vlax-curve-getEndPoint ent1) (vlax-curve-getStartPoint ent1)) end (list (vlax-curve-getStartPoint ent2) (vlax-curve-getEndPoint ent2))) (setq start (list (vlax-curve-getStartPoint ent1) (vlax-curve-getEndPoint ent1)) end (list (vlax-curve-getStartPoint ent2) (vlax-curve-getEndPoint ent2))) ) (setq startEnd (mapcar (function (lambda (end1 end2) (caar (vl-sort (mapcar (function (lambda (line) (list line (+ (distance (car line) end1) (distance (car line) end2) (distance (cadr line) end1) (distance (cadr line) end2) ) ) )) vor ) (function (lambda (a b) (< (cadr a) (cadr b)) )) ) ) )) start end ) ) (_polyline ( (lambda (lst / rtn) ; Draw a line of the midpoints of voronoi lines (while (cdr lst) (setq rtn (cons (mapcar (function (lambda (a b) (* (+ a b) 0.5))) (car lst) (cadr lst) ) rtn ) ) (setq lst (cdr lst)) ) rtn ) (minlen vor startEnd) ) ) ) ) (princ) )

As for the code from my first attempt, I suppose the least I should do for any “child of mine” is to make sure it can have a functional life, no matter how cross-eyed it was born: you never abandon a child. So here I leave a new version of “GLAVCVS’ cross-eyed child”, fresh out of the hospital. ;| G L A V C V S C R O S S - E Y E D C H I L D - o - ************************* G L A V C V S ************************* *************************** F E C I T ***************************|; (defun c:creAxis (/ e e1 e2 l i? l1 l2 lr p p0 p1 p2 px pm abis lii pmi pmf pi1 pi2 pf1 pf2 pc1 pc2 li1 o dameInters+Prox ordena decide sustituye damePuntos) (defun dameInters+Prox (p0 a lp / p1 px pt1 pt2 dmin d pf) (setq pt1 (polar p0 a 1e8) pt2 (polar p0 (+ a PI) 1e8)) (foreach p lp (if p1 (if (setq px (inters pt1 pt2 p1 p)) (if dmin (if (< (setq d (distance px p0)) dmin) (setq dmin d pf px)) (setq dmin (distance px p0) pf px)) ) ) (setq p1 p) ) pf ) (defun ordena (po px pm / p0 lr) (foreach p lii (if (and p0 (inters po px p0 p)) (setq lr (append lr (list pm))) ) (setq p0 p lr (append lr (list p))) ) ) (if (and (setq e1 (car (entsel "\nSelect FIRST LWPOLYLINE..."))) (= (cdr (assoc 0 (setq l1 (entget e1)))) "LWPOLYLINE") (not (redraw e1 3))) (if (and (setq e2 (car (entsel "\nSelect SECOND LWPOLYLINE..."))) (= (cdr (assoc 0 (setq l2 (entget e2)))) "LWPOLYLINE") (not (redraw e2 3))) (progn (setq lp1 (reverse (foreach l l1 (if (= (car l) 10) (setq lr (cons (cdr l) lr)) lr))) lr nil lp2 (reverse (foreach l l2 (if (= (car l) 10) (setq lr (cons (cdr l) lr)) lr))) lr nil ) (cond ((= (rem (cdr (assoc 70 l1)) 2) 1) (setq lp1 (append lp1 (list (car lp1) (cadr lp1) (caddr lp1)))) ) ((equal (car lp1) (last lp1)) (setq lp1 (append lp1 (list (cadr lp1) (caddr lp1)))) ) (T (setq pmi (mapcar '(lambda (a b) (/ (+ a b) 2.0)) (car lp1) (setq pc1 (vlax-curve-getClosestPointTo e2 (car lp1)))) pmf (mapcar '(lambda (a b) (/ (+ a b) 2.0)) (last lp1) (setq pc2 (vlax-curve-getClosestPointTo e2 (last lp1)))) ) ) ) (cond ((= (rem (cdr (assoc 70 l2)) 2) 1) (if pmi (progn (foreach p (append lp2 (list (car lp2))) (if (or (equal p pmi 1e-4) (equal p pmf 1e-4)) (setq l (if l (not (setq lr (append l (list p)))) (list (list p)))) (if l (setq l (append l (list p)))) ) ) (setq lp2 lr lr nil l nil) ) (setq lp2 (append lp2 (list (car lp2) (cadr lp2)))) ) ) ((equal (car lp2) (last lp2)) (if pc1 (progn (foreach p lp2 (if (or (equal p pc1 1e-4) (equal p pc2 1e-4)) (setq l (if l (not (setq lr (append l (list p)))) (list (list p)))) (if l (setq l (append l (list p)))) ) ) (setq lp2 lr lr nil l nil) ) (setq lp2 (append lp2 (list (cadr lp2)))) ) ) ) (redraw e1 4) (redraw e2 4) (foreach lp (list lp1 lp2) (foreach l lp (if p1 (if p2 (setq abis (+ (/ (+ (angle p1 p2) (angle p2 l)) 2) (/ PI 2.)) px (dameInters+Prox p2 abis (if o lp1 lp2)) lr nil pm (if px (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p2 px)) lii (if o (if pm (ordena p2 px pm) lii) (if px (append lii (list pm)) lii)) p1 p2 p2 l ) (setq p2 l) ) (setq p1 l) ) ) (if pmi (setq lii (append (list pmi) lii (list pmf)))) (setq p1 nil p2 nil lr nil o T) ) ) ) ) (entmake (append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbPolyline") (70 . 0) (60 . 0)) (list (cons 90 (length lii))) (mapcar '(lambda (a) (cons 10 a)) lii))) (princ) )

Here's a simpe solution that doesn't use LISP. Change the elevation of one of the polylines to 1.0 then use the loft command to create asurface. Section the resulting surface with an XY plane at 0,0,0.5.

did a little cleaning & tweaking and added a (grdraw) background to give it just a tiny bit more spunk ... enjoy ;;; RlxGrMenu - 2025-07-09 - Just a funny / basic / tiny 'toolbar' ;;; It draws a column on the right of your screen with 12 rows. ;;; Config is not working yet and I'm not sure it's worth the effort because its only meant as a lisp launcher. ;;; Quit by click on QUIT in toolbar or by typing Q , q or space, zoom in / out with +/-/z ;;; I've run a little out of button-space so wanted an out of the box solution to this problem. ;;; this is just a way to run my 10 most used lisp routines, nothing more , nothing less. ;;; Substitute the names in app-list (setq app-list (list "LC" "VT"...) with names from your own favorite apps ;;; Apps (lisps) have to be in search path so (findfile (strcat "MyApp" ".lsp") should work. ;;; Also apps should not be self executing and the start command should be same as app name. ;;; If your app is named "MyApp" this routine loads the app if found and starts it with (eval (read (strcat "C:" "Myapp"))) ;;; have fun ;;; ------------------------------ ;;; ;;; |S1 S2| ;;; ;;; | -------------- ----- [a]| ;;; ;;; | |E1 E2| [b]| ;;; ;;; | | | [c]| ;;; ;;; | | | [d]| ;;; ;;; | |E3 E4| [e]| ;;; ;;; | -------------------- [f]| ;;; ;;; |S3 S4| ;;; ;;; ------------------------------ ;;; ;;; (count_calcula) : run time values for viewsize / viewcenter etc ;;; values are effected by resize window : vc , vs , ss , x+ , x- , y+ , y- , P1-P4 ;;; screen corner points : S1 = (x- y+) , S2 (x+ y+) , S3 (x- y-) , S4 (x+ y-) ;;; extents corner points : E1 - E5 extmin / extmax ;;; viewsize : vs - height current viewport (drawing units) (i.e. 300 / 386 after resize) ;;; screen size : ss (1187 532) (pixels) after max acad window : vs = 386 , ss = (1840 685) ;;; - 12 rows, 1-10 for user , 11 for config , 12 for exit ;;; - height each row = viewsize / 12, row width = 2 x row height ;;; cell-ip = (list (- (fix x+) cell-size) (fix y+)) ;;; vector draw cell-ip -> cell-size<0, (* cell-size 12)<270 , cell-size<180 , (* cell-size 12)<90 (defun draw_menu ( / ip-x ip-y cell-h cell-w cell-ul cell-ll cell-ur cell-lr y-list ctr-x app-list app gr-loop tblc tbtc tbbc start-viewsize) (setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare" "Config" "Quit")) ;;; toolbar line color / toolbar text color / toolbar background color (setq gr-loop T tblc 7 tbtc 7 tbbc 8) ;;; when zooming in/out it messes up back ground fill so have to compensate for that (setq start-viewsize (getvar "viewsize")) (redraw_menu) ;;; launch app (if app (RlxGrMenu_Start_App app)) ) (defun redraw_menu () (redraw) ;;; get live screen data (count_calcula) (setq cell-h (/ (- y+ y-) 12) cell-w (* cell-h 2)) ;;; corner points (setq cell-ul (list (- x+ cell-w) y+) cell-ur (list x+ y+) cell-ll (list (- x+ cell-w) y-) cell-lr (list x+ y-)) ;;; get y values for all horizontal separators (setq x-list (list (car cell-ll) (car cell-lr)) y-list (gnl- (- (fix y+) cell-h) 11 cell-h)) ;;; fill the backgrounds (setq yy y-) (while (< yy y+) (grdraw (list (car cell-ll) yy) (list (car cell-lr) yy) tbbc) ;;; next y depends on zoom factor (viewsize) , 0.25 is emperical, bigger means bigger linespacing (setq yy (+ yy (* 0.25 (/ (getvar "viewsize") start-viewsize)))) ) ;;; draw the outlines (grdraw cell-ll cell-ul tblc)(grdraw cell-ul cell-ur tblc)(grdraw cell-ur cell-lr tblc)(grdraw cell-lr cell-ll tblc) ;;; drawn separators (foreach y y-list (grdraw (list (car cell-ll) y) (list (car cell-lr) y) tblc)) ;;; label the cell (setq ctr-x (+ (car cell-ll) (* cell-w 0.5))) (mapcar '(lambda (s y)(grtxt (strcase s) (list ctr-x (+ y (* cell-h 0.5))) tbtc 0 "M")) app-list (append y-list (list (- (last y-list) cell-h)))) (if gr-loop (RlxGrMenu_Get_Cell_ID x-list y-list)) ) ;;; fill cell with cell background color , use offset of 0.5 unit so outlines remain visible (defun fill_cell (x y w h / x2 y2 w2 h2 x3) (setq x2 (+ x 0.5) y2 (+ y 0.5) w2 (- w 1) h2 (- h 1) x3 (+ x2 w2)) ;(repeat (* (fix h2) 2) (grdraw (list x2 y2) (list x3 y2) tbbc)(setq y2 (+ y2 0.5))) (while (< y2 (cadr cell-ul)) (grdraw (list x2 y2) (list x3 y2) tbbc)(setq y2 (+ y2 0.5))) ) ;;; (re) calculate display parameters (count_calcula) (defun count_calcula () (setq vc (getvar "VIEWCTR") vs (getvar "VIEWSIZE") ss (getvar "SCREENSIZE") dx (* vs (/ (car ss) (cadr ss)) 0.5) dy (* vs 0.5) x- (- (car vc) dx) y- (- (cadr vc) dy) x+ (+ (car vc) dx) y+ (+ (cadr vc) dy) ip (getvar "viewctr") vc-x (car ip) vc-y (cadr ip) txt-h (/ (getvar "VIEWSIZE") 100.0))) ;;; (getvar "extmin") (getvar "extmax") (setq dvx (- x+ x-) dvy (- y+ y-)) (defun screen_res (/ s i is) (setq s (vlax-invoke (vlax-create-object "WbemScripting.SWbemLocator") 'ConnectServer nil nil nil nil nil nil nil) is (vlax-invoke s 'ExecQuery "SELECT CurrentHorizontalResolution, CurrentVerticalResolution FROM Win32_VideoController")) (vlax-for i is (vlax-get i 'CurrentHorizontalResolution))) ;;; generate number (gnum 1 5) -> '(1 2 3 4 5) (defun gnum (s e / i l) (and (numberp s)(numberp e)(setq i s)(while (<= i e)(setq l (cons i l) i (1+ i)))) (reverse l)) ;;; i = startnumber n = number of numbers , d = difference (gnl- 100 6 12) -> (100 88 76 64 52 40) (defun gnl- (i n d / l) (setq l (list i))(repeat (1- n)(setq l (cons (setq i (- i d)) l)))(reverse l)) ;;; found this old lisp (grtxt.lsp) , don't know author but all credits are for this human from earth ;;; text string / coordinate point / color / angle justificationz ;;; *** UPPER CASE ONLY *** (grtxt (STRCASE "Rob") (getvar "viewctr") 1 0 "M") (defun grtxt (ts cp cl a j / vp ltb i xp z c p1 p2 lp ld n al) ;;; vertex points (setq vp '(( 1 ( 0.50 0.25))( 2 ( 0.50 0.55))( 3 ( 0.50 0.85))( 4 ( 0.50 1.00))( 5 ( 0.25 1.00)) ( 6 ( 0.00 1.00))( 7 (-0.25 1.00))( 8 (-0.50 1.00))( 9 (-0.50 0.85))(10 (-0.50 0.55)) (11 (-0.50 0.25))(12 (-0.50 0.10))(13 (-0.25 0.10))(14 ( 0.00 0.10))(15 ( 0.25 0.10)) (16 ( 0.50 0.10))(17 ( 0.50 -0.05))(18 ( 0.50 -0.45))(19 ( 0.50 -0.85))(20 ( 0.50 -1.00)) (21 ( 0.25 -1.00))(22 ( 0.00 -1.00))(23 (-0.25 -1.00))(24 (-0.50 -1.00))(25 (-0.50 -0.85)) (26 (-0.50 -0.40))(27 (-0.50 -0.05))(30 ( 0.35 0.85))(31 (-0.35 0.85))(32 (-0.35 -0.85)) (33 ( 0.35 -0.85))(40 ( 0.25 0.35))(41 (-0.25 0.35))(42 ( 0.25 -0.15))(43 (-0.25 -0.15)) (44 ( 0.00 0.45))(45 ( 0.00 -0.25))(50 ( 0.30 0.20))(51 ( 0.30 0.35))(52 ( 0.20 0.35)) (53 ( 0.20 0.20))(54 ( 0.30 0.10))(55 ( 0.30 -0.10))(56 ( 0.20 -0.10))(57 ( 0.20 0.10)) (60 (-0.30 0.20))(61 (-0.30 0.35))(62 (-0.20 0.35))(63 (-0.20 0.20))(64 (-0.30 0.10)) (65 (-0.30 -0.10))(66 (-0.20 -0.10))(67 (-0.20 0.10)))) ;;; letter table (setq ltb '(("A" 24 9 7 5 3 20 16 12) ("B" 12 15 1 3 5 8 24 21 19 17 15) ("C" 3 5 7 9 25 23 21 19) ("D" 3 5 8 24 21 19 3) ("E" 4 8 12 15 12 24 20) ("F" 4 8 12 15 12 24) ("G" 3 5 7 9 25 23 21 19 16 14) ("H" 20 -4 8 -24 16 12) ("I" 7 5 6 22 23 21) ("J" 4 19 21 23 25) ("K" 8 24 12 13 4 13 20) ("L" 8 24 20) ("M" 24 8 14 4 20) ("N" 24 8 20 4) ("O" 3 5 7 9 25 23 21 19 3) ("P" 12 15 1 3 5 8 24) ("Q" 3 5 7 9 25 23 21 19 3 -19 20 45) ("R" 20 14 12 15 1 3 5 8 24) ("S" 3 5 7 9 11 13 15 17 19 21 23 25) ("T" 4 8 6 22) ("U" 8 25 23 21 19 4 20) ("V" 8 22 4) ("W" 8 23 14 21 4) ("X" 4 -24 8 20) ("Y" 8 14 22 14 4) ("Z" 8 4 24 20) ("0" 3 5 7 9 25 23 21 19 -3 4 24) ("1" 31 7 6 22 21 23) ("2" 9 7 5 3 1 15 13 27 24 20) ("3" 9 7 5 3 1 15 13 15 17 19 21 23 25) ("4" 8 12 16 15 5 21) ("5" 4 8 12 15 17 19 21 23 25) ("6" 3 5 7 9 25 23 21 19 17 15 12) ("7" 8 4 22) ("8" 3 5 7 9 11 13 27 25 23 21 19 17 15 13 15 1 3) ("9" 25 23 21 19 3 5 7 9 11 13 16) ("<" 4 12 20) (">" 8 16 24) ("," 33 21) ("." 19 20 21 33 19) ("\'" 4 30) ("\"" 4 -30 7 31) (";" 50 51 52 53 -50 54 55 56 57 55 45) (":" 50 51 52 53 -50 54 55 56 57 55) ("\\" 8 20) ("/" 4 24) ("?" 11 10 7 5 2 1 45 22) ("|" 6 -44 45 22) ("+" 44 -45 13 15) ("=" 40 -41 43 42) ("-" 13 15) ("_" 20 24) (")" 6 2 18 22) ("(" 6 10 26 22) ("*" 40 -43 41 -42 45 44) ("&" 21 31 7 6 26 25 23 16) ("^" 10 6 2) ("%" 57 54 55 56 -57 63 60 61 62 -63 5 24) ("$" 3 5 7 9 11 13 15 17 19 21 23 25 -26 22 6) ("#" 24 -6 22 -4 1 -11 17 27) ("@" 42 15 40 44 41 13 43 45 42 17 3 5 7 9 25 23 21 19) ("!" 6 -45 22 22) ("~" 9 31 44 40 2) ("`" 8 31) ("[" 6 8 24 22) ("]" 6 4 20 22) ("{" 6 7 41 12 43 23 22) ("}" 6 5 40 16 42 21 22) (""))) ;;; text height (setq z (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")) 0.2)) (cond ;;; left justification ((eq (strcase (substr j 1 1)) "L") (setq xp (list (+ (car cp) z) (cadr cp)) i 1)) ;;; middle justification ((eq (strcase (substr j 1 1)) "M") (setq xp (list (- (car cp) (* z (strlen ts) 0.5)) (cadr cp)) i 1)) ;;; right justification ((eq (strcase (substr j 1 1)) "R") (setq xp (list (- (car cp) (* z (strlen ts) 1.5)) (cadr cp)) i 1)) ) (repeat (strlen ts) ;;; each charachter / line point list / letter point def (setq c (substr ts i 1) lp '() ld (cdr (assoc c ltb))) (while (> (length ld) 1) (setq p1 (cadr (assoc (abs (nth 0 ld)) vp)) p2 (cadr (assoc (abs (nth 1 ld)) vp)) p1 (mapcar '* (list z z) p1) p2 (mapcar '* (list z z) p2) p1 (mapcar '+ xp p1) p2 (mapcar '+ xp p2) lp (append lp (list (if (minusp (nth 0 ld)) 0 cl) p1 p2)) ld (cdr ld)) ) ;;; add rotation angle (setq n 0 al nil) (repeat (/ (length lp) 3) (setq al (cons (nth n lp) al) al (cons (polar cp (+ a (angle cp (nth (+ n 1) lp))) (distance cp (nth (+ n 1) lp))) al) al (cons (polar cp (+ a (angle cp (nth (+ n 2) lp))) (distance cp (nth (+ n 2) lp))) al)) (setq n (+ n 3)) ) (and al (grvecs (reverse al))) (setq xp (list (+ (car xp) (* z 1.5)) (cadr xp)) i (1+ i)) ) (prin1) ) ;;; probably won't need tracking mode (cut-copy-paste you know...) (defun RlxGrMenu_Get_Cell_ID (xl yl / inp dev tpt prev-tpt mark-current-tracking-point cell-id prev-cell-id prev-view-size cur-view-size rtn) (princ "\nEsc/Q/Rmouse to cancel, zoom with E(extend), Z(oom) or + / -") (setq prev-view-size (getvar "viewsize")) (while gr-loop (setq cur-view-size (getvar "viewsize")) (setq inp (vl-catch-all-apply 'grread (list T 8 1))) (if (vl-catch-all-error-p inp) (progn (setq gr-loop nil inp nil)(redraw)) (progn (setq dev (car inp) tpt (cadr inp)) (cond ;;; space , q or Q (Quit) ((and (= dev 2) (member (last inp) '(32 113 81))) (redraw)(setq gr-loop nil) ) ;;; point selection (3 (221.882 173.853 0.0)) ((= dev 3) (if (setq rtn (find_cell tpt xl yl)) (progn ;(alert (setq app (nth (1- (atoi rtn)) app-list))) (princ (strcat "\nLaunching : " (setq app (nth (1- (atoi rtn)) app-list)))) (setq gr-loop nil) ) ) ) ;;; device tracking point (probably don't need tracking mode) ((= dev 5) ;;; if mouse moved (if (or (/= (car prev-tpt)(car tpt)) (/= (cadr prev-tpt)(cadr tpt))) (progn (setq prev-tpt tpt ))) (if (not (equal cur-view-size prev-view-size)) (progn (setq prev-view-size cur-view-size) (redraw_menu) ) ) ) ; user pressed E of e ((member inp '((2 69)(2 101))) (command "zoom" "e")) ; user clicked R-mouse button, pressed enter or space (done selecting) ((or (equal (car inp) 25)(member inp '((2 13)(2 32)))) (setq gr-loop nil)) ; user pressed + ((equal inp '(2 43)) (vl-cmdf "zoom" "2x")) ; user pressed - ((equal inp '(2 45)) (vl-cmdf "zoom" ".5x")) ; user pressed z or Z ((member inp '((2 122)(2 90))) (vl-cmdf "'zoom" "")) ) ) ) ) (princ) ) ;;; pt = point , xl = x-list , yl = y-list ;;; scribble : (< 1 2 3) , (> 3 2 1) , (cdr (vl-sort '(1 2 3 4 5) '>)) -> '(4 3 2 1) (defun find_cell ( pt xl yl / ptx pty y-lst l n hit) (setq n nil hit nil ptx (car pt) pty (cadr pt) y-list (vl-sort (append yl (list 0)) '>)) (if (< (car xl) ptx (cadr xl)) (mapcar '(lambda (y)(if (and (not hit) (> pty y)) (setq hit T n (vl-position y y-list)))) y-list)) (if n (itoa (1+ n))) ) ;;; program assumes no self starting routines and start command is "C:" + app name (defun RlxGrMenu_Start_App (app / fn) (cond ((setq fn (findfile (strcat app ".lsp"))) (redraw)(load fn)(eval (read (strcat "(C:" app ")")))) ((wcmatch (strcase app) "QUIT")(princ "\nBye bye")(redraw)) ((wcmatch (strcase app) "CONFIG")(princ "\nUnder construction")(redraw)) (t (redraw)(princ (strcat "\nUnable to load " (vl-princ-to-string app) " ...bye"))) ) ) ;;; future... ;;; RlxGrMenu - Rlx Jul/25 (defun RlxGrMenu_future ( / ;;; global variables scr-res cell-rows cell-cols cell-col cell-id app-list ;;; display parameters like viewctr/viewsize/screensize (count_calcula) vc vs ss dx dy x- x+ y- y+ ip vc-x vc-y txt-h ;;; registry variables RlxGrMenu-nof-cell-rows RlxGrMenu-nof-cell-cols RlxGrMenu-app-list ) ;;; mostly not used because for now I just just one column with 10 rows (setq scr-res (screen_res) rows 3 cols 3 cell-col 141 cell-id 1) (count_calcula) (setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare")) (RlxGrMenu_Init) (RlxGrMenu_Doit) (RlxGrMenu_Exit) (princ) ) (defun RlxGrMenu_Init ()(princ "\nUnder construction - RlxGrMenu_Init ")) (defun RlxGrMenu_Doit ()(princ "\nUnder construction - RlxGrMenu_Doit ")) (defun RlxGrMenu_Exit ()(princ "\nUnder construction - RlxGrMenu_Exit ")) (defun c:RlxGrMenu ()(draw_menu)) (defun c:t1 ()(draw_menu)) (defun t1 ()(draw_menu))

however... quite aggressive asking for the credit here today. Nicer ways to go "Hey, this was originally my code, can you credit me" and perhaps if possible the link to the original code to help the OP out. Code gets shared, the links and credits lost. Always good practice to add links to the sources and credits in case there are thing you want to go back and understand more from any discussions. Having said that though, upload code, you have no control of it's use and I am not sure I'd want credited with a base code that is mine and then heavily modified, or just a snippet of my code included in something larger without me doing checks and testing.

; slope - 2024.05.28 exceed (defun c:SLOPE ( / acdoc mspace fuzz ssp sspl i ptlist ent entlist pt ss ssl obj coordlist coordlistlen p1 p2 xydist midpt parameter totallen midlen j p1z p2z flag1 flag2 pt2 sloperatio slopeblock blkang slopetextpt slopetext lengthtextpt lengthtext midparam prevparam nextparam) (setq acdoc (vla-get-activedocument (vlax-get-acad-object))) (setq mspace (vla-get-modelspace acdoc)) (setq fuzz 0.005) (setq ssp (ssget "X" '((0 . "POINT")))) (setq sspl (sslength ssp)) (setq i 0) (setq ptlist '()) (repeat sspl (setq ent (ssname ssp i)) (setq entlist (entget ent)) (setq pt (cdr (assoc 10 entlist))) (setq ptlist (cons pt ptlist)) (setq i (+ i 1)) ) ;(princ "\n pt list - ") ;(princ ptlist) (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "-Polyline-")))) (setq ssl (sslength ss)) (setq i 0) (repeat ssl (setq ent (ssname ss i)) (setq obj (vlax-ename->vla-object ent)) (setq coordlist (vlax-safearray->list (vlax-variant-value (vlax-get-property obj 'coordinates)))) (setq coordlistlen (length coordlist)) (setq p1 (list (car coordlist) (cadr coordlist) 0)) (setq p2 (list (nth (- coordlistlen 2) coordlist) (nth (- coordlistlen 1) coordlist) 0)) (setq xydist (distance p1 p2)) (setq midpt '()) (setq param (vlax-curve-getEndParam obj)) (setq totallen (vlax-curve-getDistAtParam obj param)) (setq midlen (* 0.5 totallen)) (setq midpt (vlax-curve-getPointAtDist obj midlen)) ;(setq midparam (vlax-curve-getParamAtPoint obj (vlax-curve-getClosestPointTo obj midpt))) ;(setq prevparam (vlax-curve-getPointAtParam obj (fix midparam))) (setq prevparam (vlax-curve-getpointatdist obj (* 0.499999 totallen))) ;(setq nextparam (vlax-curve-getPointAtParam obj (+ (fix midparam) 1))) (setq nextparam (vlax-curve-getpointatdist obj (* 0.500001 totallen))) ;(princ midpt) (setq j 0) (setq p1z 0) (setq p2z 0) (setq flag1 0) (setq flag2 0) (repeat sspl (setq pt2 (nth j ptlist)) (if (and (and (< (- (car p1) fuzz) (car pt2)) (< (car pt2) (+ (car p1) fuzz))) (and (< (- (car p1) fuzz) (car pt2)) (< (cadr pt2) (+ (cadr p1) fuzz))) (= flag1 0) ) (progn (setq p1z (caddr pt2)) ;(princ "\n p1z = ") ;(princ p1z) (setq flag1 1) ) ) (if (and (and (< (- (car p2) fuzz) (car pt2)) (< (car pt2) (+ (car p2) fuzz))) (and (< (- (car p2) fuzz) (car pt2)) (< (cadr pt2) (+ (cadr p2) fuzz))) (= flag2 0) (= flag1 1) ) (progn (setq p2z (caddr pt2)) ;(princ "\n p2z = ") ;(princ p2z) (setq flag2 1) ) ) (setq j (+ j 1)) ) (if (and (= flag1 1) (= flag2 1)) (progn (setq p1 (list (car p1) (cadr p1) p1z)) (setq p2 (list (car p2) (cadr p2) p2z)) (setq sloperatio (* 100 (/ (abs (- p1z p2z)) xydist))) ;(setq midpt (list (/ (+ (car p1) (car p2)) 2) (/ (+ (cadr p1) (cadr p2)) 2) (/ (+ (caddr p1) (caddr p2)) 2))) (if (> p1z p2z) ;(setq blkang (angle p1 p2)) (setq blkang (angle prevparam nextparam)) ;(setq blkang (angle p2 p1)) (setq blkang (angle nextparam prevparam)) ) ;(princ "\n sloperatio - ") ;(princ sloperatio) ;(princ "%") (setq slopeblock (vla-InsertBlock mspace (vlax-3d-point midpt) "-Slope-" 5 5 5 blkang)) (cond ((and (<= 0 blkang) (< blkang (/ pi 2))) ;(princ "a") ) ((and (<= (/ pi 2) blkang) (< blkang pi)) ;(princ "b") (setq blkang (- blkang pi)) ) ((and (<= pi blkang) (< blkang (* 1.5 pi))) ;(princ "c") (setq blkang (- blkang pi)) ) ((and (<= (* 1.5 pi) blkang) (< blkang pi)) ;(princ "d") ) ) (setq slopetextpt (polar midpt (+ blkang (* 0.5 pi)) 5)) (setq slopetext (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 "-Label Between Geometry Points") (cons 67 0) (cons 100 "AcDbText") (cons 10 slopetextpt) (cons 11 slopetextpt) (cons 40 5) (cons 1 (strcat (rtos sloperatio 2 2) "%")) (cons 50 blkang) (cons 41 1) (cons 51 0) (cons 7 "Standard") (cons 71 0) (cons 72 1) (cons 100 "AcDbText") (cons 73 0) ) ) ) (setq lengthtextpt (polar midpt (- blkang (* 0.5 pi)) 10)) (setq lengthtext (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 "-Label Between Geometry Points") (cons 67 0) (cons 62 7) (cons 100 "AcDbText") (cons 10 lengthtextpt) (cons 11 lengthtextpt) (cons 40 5) (cons 1 (strcat (rtos xydist 2 2) "m")) (cons 50 blkang) (cons 41 1) (cons 51 0) (cons 7 "-Elevation-") (cons 71 0) (cons 72 1) (cons 100 "AcDbText") (cons 73 0) ) ) ) ) (progn ;(princ "\n there's no elevation point for this polyline") ) ) (setq i (+ i 1)) ) (princ) ) If the polyline bends sharply, the angle of the arrow and text may be strange. p.s - Is it correct to use the horizontal length rather than the inclined length? edit - angle problem in the gif has been corrected some

Try something like this - change the value of the two variables at the top of the code to suit: (defun c:test ( / bln idx lst nla pat ) (setq pat "*block*" nla "NewLayer" pat (strcase pat) ) (if (setq sel (ssget '((0 . "INSERT")))) (repeat (setq idx (sslength sel)) (setq idx (1- idx) bln (cdr (assoc 2 (entget (ssname sel idx)))) ) (if (not (member bln lst)) (progn (setq lst (cons bln lst)) (processblock bln pat nla) ) ) ) ) (princ) ) (defun processblock ( bln str lay / ent ) (if (setq ent (tblobjname "block" bln)) (while (setq ent (entnext ent)) (processobject ent str lay) ) ) ) (defun processobject ( ent str lay / bln enx ) (cond ( (not (setq enx (entget ent)))) ( (/= "INSERT" (cdr (assoc 0 enx)))) ( (not (wcmatch (setq bln (strcase (cdr (assoc 2 enx)))) str)) (processblock bln str lay) ) ( (entmod (subst (cons 8 lay) (assoc 8 enx) enx)) (processblock bln str lay) ) ) ) (princ)

Assuming I've understood what you're looking to achieve, you could potentially use the sendcommand method to accomplish this, i.e.: (defun c:ctext ( / ent enx str ) (while (not (progn (setvar 'errno 0) (setq ent (car (entsel "\nSelect command text: "))) (cond ( (= 7 (getvar 'errno)) (prompt "\nMissed, try again.") ) ( (null ent)) ( (not (wcmatch (cdr (assoc 0 (setq enx (entget ent)))) "*TEXT")) (prompt "\nThe selected object is not text or mtext.") ) ( (setq str (cdr (assoc 1 enx)))) ) ) ) ) (if str (vla-sendcommand (vla-get-activedocument (vlax-get-acad-object)) (strcat str "\n"))) (princ) ) (vl-load-com) (princ)

(vl-load-com) (defun c:ARCTEST ( / ss ssl index tlist ent obj elist arclist arcrad arccenter arcalongcenter ll ur lll url midpt unitvect1 xline1 xlineobj unitvect2 ray1 tlen resultss 1text 1textcen cen2cen ray2 interpt) (setq ss (ssget '((0 . "ARC,TEXT")))) (setq ssl (sslength ss)) (setq index 0) (setq tlist '()) (repeat ssl (setq ent (ssname ss index)) (setq obj (vlax-ename->vla-object ent)) (setq elist (entget ent)) (cond ((eq (cdr (assoc 0 elist)) "ARC") (setq arclist (LM:ArcEndpoints ent)) (setq arcrad (cdr (assoc 40 elist))) (setq arccenter (cdr (assoc 10 elist))) (setq arcalongcenter (vlax-curve-getPointAtDist obj (/ (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj ) ) 2 ) ) ) ) ((eq (cdr (assoc 0 elist)) "TEXT") (vla-getboundingbox obj 'll 'ur) (setq lll (vlax-safearray->list ll)) (setq url (vlax-safearray->list ur)) (setq midpt (mapcar '* (mapcar '+ lll url) '(0.5 0.5 0.5))) (setq tlist (cons (list ent midpt) tlist)) ) ) (setq index (+ index 1)) ) (setq unitvect1 (mapcar '(lambda (x) (/ x (distance (car arclist) (cadr arclist)))) (mapcar '- (cadr arclist) (car arclist)))) (setq xline1 (entmakex (list (cons 0 "XLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbXline") (cons 10 (cadr arclist)) (cons 11 unitvect1) ) ) ) (setq xlineobj (vlax-ename->vla-object xline1)) (setq unitvect2 (mapcar '(lambda (x) (/ x (distance arcalongcenter arccenter))) (mapcar '- arccenter arcalongcenter))) (setq ray1 (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 arcalongcenter) (cons 11 unitvect2) ) ) ) (setq tlen (length tlist)) (setq index 0) (setq resultss (ssadd)) (repeat tlen (setq 1text (nth index tlist)) (setq 1textcen (cadr 1text)) (setq cen2cen (distance 1textcen arccenter)) (if (<= cen2cen arcrad) (progn (ssadd (car 1text) resultss) ) (progn (setq ray2 (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 1textcen) (cons 11 unitvect2) ) ) ) (setq interpt (LM:intersections xlineobj (vlax-ename->vla-object ray2) acextendnone)) (if (= interpt nil) (progn (ssadd (car 1text) resultss) ) (progn) ) (entdel ray2) ) ) (setq index (+ index 1)) ) (sssetfirst nil resultss) (entdel xline1) (entdel ray1) (princ) ) ;; Intersections - Lee Mac ;; Returns a list of all points of intersection between two objects ;; for the given intersection mode. ;; ob1,ob2 - [vla] VLA-Objects ;; mod - [int] acextendoption enum of intersectwith method (defun LM:intersections ( ob1 ob2 mod / lst rtn ) (if (and (vlax-method-applicable-p ob1 'intersectwith) (vlax-method-applicable-p ob2 'intersectwith) (setq lst (vlax-invoke ob1 'intersectwith ob2 mod)) ) (repeat (/ (length lst) 3) (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn) lst (cdddr lst) ) ) ) (reverse rtn) ) ;; Arc Endpoints - Lee Mac ;; Returns the endpoints of an Arc expressed in WCS (defun LM:ArcEndpoints (ent / cen nrm rad) (setq ent (entget ent) nrm (cdr (assoc 210 ent)) cen (cdr (assoc 010 ent)) rad (cdr (assoc 040 ent)) ) (mapcar (function (lambda (ang) (trans (mapcar '+ cen (list (* rad (cos ang)) (* rad (sin ang)) 0.0)) nrm 0 ) ) ) (list (cdr (assoc 50 ent)) (cdr (assoc 51 ent))) ) ) how does it works, step by step gif. (vl-load-com) (defun c:ARCTEST ( / ss ssl index tlist ent obj elist arclist arcrad arccenter arcalongcenter ll ur lll url midpt unitvect1 xline1 xlineobj unitvect2 ray1 tlen resultss 1text 1textcen cen2cen ray2 interpt circleent) (setq ss (ssget '((0 . "ARC,TEXT")))) (setq ssl (sslength ss)) (setq index 0) (setq tlist '()) (repeat ssl (setq ent (ssname ss index)) (setq obj (vlax-ename->vla-object ent)) (setq elist (entget ent)) (cond ((eq (cdr (assoc 0 elist)) "ARC") (setq arclist (LM:ArcEndpoints ent)) (setq arcrad (cdr (assoc 40 elist))) (setq arccenter (cdr (assoc 10 elist))) (setq arcalongcenter (vlax-curve-getPointAtDist obj (/ (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj ) ) 2 ) ) ) ) ((eq (cdr (assoc 0 elist)) "TEXT") (vla-getboundingbox obj 'll 'ur) (setq lll (vlax-safearray->list ll)) (setq url (vlax-safearray->list ur)) (setq midpt (mapcar '* (mapcar '+ lll url) '(0.5 0.5 0.5))) (setq tlist (cons (list ent midpt) tlist)) ) ) (setq index (+ index 1)) ) (setq unitvect1 (mapcar '(lambda (x) (/ x (distance (car arclist) (cadr arclist)))) (mapcar '- (cadr arclist) (car arclist)))) (setq xline1 (entmakex (list (cons 0 "XLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbXline") (cons 10 (cadr arclist)) (cons 11 unitvect1) ) ) ) (setq xlineobj (vlax-ename->vla-object xline1)) (setq unitvect2 (mapcar '(lambda (x) (/ x (distance arcalongcenter arccenter))) (mapcar '- arccenter arcalongcenter))) (setq ray1 (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 arcalongcenter) (cons 11 unitvect2) ) ) ) (setq circleent (entmakex (list (cons 0 "CIRCLE") (cons 10 arccenter) (cons 40 arcrad)))) (setq tlen (length tlist)) (setq index 0) (setq resultss (ssadd)) (repeat tlen (setq 1text (nth index tlist)) (setq 1textcen (cadr 1text)) (setq cen2cen (distance 1textcen arccenter)) (if (<= cen2cen arcrad) (progn (ssadd (car 1text) resultss) (vlax-put-property (vlax-ename->vla-object (car 1text)) 'textstring "Gotcha (Circle)") (vlax-put-property (vlax-ename->vla-object (car 1text)) 'color 2) ) (progn (setq ray2 (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 1textcen) (cons 11 unitvect2) ) ) ) (setq interpt (LM:intersections xlineobj (vlax-ename->vla-object ray2) acextendnone)) (if (= interpt nil) (progn (ssadd (car 1text) resultss) (vlax-put-property (vlax-ename->vla-object (car 1text)) 'textstring "Gotcha (Ray)") (vlax-put-property (vlax-ename->vla-object (car 1text)) 'color 3) ) (progn) ) (setq answer (getstring)) (entdel ray2) ) ) (setq index (+ index 1)) ) (sssetfirst nil resultss) (entdel xline1) (entdel circleent) (entdel ray1) (princ) ) ;; Intersections - Lee Mac ;; Returns a list of all points of intersection between two objects ;; for the given intersection mode. ;; ob1,ob2 - [vla] VLA-Objects ;; mod - [int] acextendoption enum of intersectwith method (defun LM:intersections ( ob1 ob2 mod / lst rtn ) (if (and (vlax-method-applicable-p ob1 'intersectwith) (vlax-method-applicable-p ob2 'intersectwith) (setq lst (vlax-invoke ob1 'intersectwith ob2 mod)) ) (repeat (/ (length lst) 3) (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn) lst (cdddr lst) ) ) ) (reverse rtn) ) ;; Arc Endpoints - Lee Mac ;; Returns the endpoints of an Arc expressed in WCS (defun LM:ArcEndpoints (ent / cen nrm rad) (setq ent (entget ent) nrm (cdr (assoc 210 ent)) cen (cdr (assoc 010 ent)) rad (cdr (assoc 040 ent)) ) (mapcar (function (lambda (ang) (trans (mapcar '+ cen (list (* rad (cos ang)) (* rad (sin ang)) 0.0)) nrm 0 ) ) ) (list (cdr (assoc 50 ent)) (cdr (assoc 51 ent))) ) )

I thought you already got an answer from another forum? Here's a quick one for fun .. prints results to the command line: (defun c:foo (/ a l n r s) (cond ((setq s (ssget '((0 . "ARC")))) ;; Add lengths to this list sorted smallest to largest (setq l (vl-sort '(1.2 1.5 2.0 2.5) '<)) (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) (setq n (vla-get-arclength (vlax-ename->vla-object e))) (if (setq n (vl-some '(lambda (x) (if (<= n x) x)) l)) (if (setq a (assoc n r)) (setq r (subst (list n (1+ (cadr a))) a r)) (setq r (cons (list n 1) r)) ) (print "NO CABLE LENGTH FOUND!") ) ) (print (vl-sort r '(lambda (r j) (< (car r) (car j))))) ) ) (princ) )

Here's another - (defun c:brace ( / ang blg di1 di2 mat rad pt1 pt2 ) (setq rad 1.0) ;; Brace radius (if (and (setq pt1 (getpoint "\nSpecify 1st point for brace: ")) (progn (while (and (setq pt2 (getpoint "\nSpecify 2nd point for brace: " pt1)) (< (distance pt1 pt2) (* 4 rad)) ) (princ "\nDistance between the two points must be greater than 4 times the radius.") ) pt2 ) ) (progn (setq di1 (distance pt1 pt2) di2 (- (/ di1 2.0) rad) ang (angle pt1 pt2) mat (list (list (cos ang) (- (sin ang))) (list (sin ang) (cos ang))) blg (1- (sqrt 2.0)) ) (entmake (append '( (000 . "LWPOLYLINE") (100 . "AcDbEntity") (100 . "AcDbPolyline") (090 . 7) (070 . 0) ) (apply 'append (mapcar (function (lambda ( a b ) (list (cons 010 (mapcar '+ (mapcar '(lambda ( r ) (apply '+ (mapcar '* r a))) mat) pt1)) (cons 042 b) ) ) ) (list '(0.0 0.0) (list rad (- rad)) (list di2 (- rad)) (list (+ di2 rad) (- 0 rad rad)) (list (- di1 di2) (- rad)) (list (- di1 rad) (- rad)) (list di1 0.0) ) (list blg 0.0 (- blg) (- blg) 0.0 blg 0.0) ) ) (list (cons 210 (trans '(0.0 0.0 1.0) 1 0 t))) ) ) ) ) (princ) ) To flip the brace, pick the points in the opposite direction.

The RECTANG command is already have fillet option within so you need to specify it only once then draw the rectangle required.

I think it's because people don't use this method because it's too slow. I edited the gif to save your time. ; CTEXT & PTEXT - 2022.06.30 exceed ; step 1 - use CTEXT, copy all text's handle & textstring to excel (except locked or freezed) ; step 2 - edit in excel C column. ; step 3 - place your cursor in that table, press ctrl+a > ctrl+c ; step 4 - in CAD, press PTEXT to put your new text strings in there (vl-load-com) (defun c:CTEXT ( / *error* ss ssl index textlist obj hand textlayer textlayerobj layerlocked layerfreezed tstring indexr textlista indexc putstring xlcolumns ) (defun *error* ( msg ) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (ex:RELEASEEXCELforctcs) (princ) ) (setq ss (ssget "X" '((0 . "*text")))) (setq ssl (sslength ss)) (setq index 0) (setq textlist '()) (repeat ssl (setq obj (vlax-ename->vla-object (ssname ss index))) (setq hand (vlax-get-property obj 'handle)) (setq textlayer (vlax-get-property obj 'layer)) (setq textlayerobj (vlax-ename->vla-object (tblobjname "layer" textlayer))) (setq layerlocked (vlax-get-property textlayerobj 'lock)) (setq layerfreezed (vlax-get-property textlayerobj 'freeze)) (if (and (= layerlocked :vlax-false) (= layerfreezed :vlax-false)) (progn (setq tstring (vlax-get-property obj 'textstring)) (setq textlist (cons (list hand tstring) textlist)) ) (progn ;(princ "\n it's locked or freezed") ) ) (setq index (+ index 1)) ) (ex:ESMAKE) (setq indexr 0) (repeat (length textlist) (setq textlista (nth indexr textlist)) (setq indexc 0) (repeat (length textlista) (setq putstring (nth indexc textlista)) (ex:ECSELPUT (+ indexr 2) (+ indexc 1) (vl-princ-to-string putstring)) (ex:ECSELPUT (+ indexr 2) (+ indexc 2) (vl-princ-to-string putstring)) (setq indexc (+ indexc 1)) );end of repeat rows (setq indexr (+ indexr 1)) );end of repeat columns (ex:ECSELPUT 1 1 "handle") (ex:ECSELPUT 1 2 "old text") (ex:ECSELPUT 1 3 "new text") (ex:ECSELPUT 1 6 "How to Use : Fill new text cell > ctrl+a > ctrl+c > in cad run ptext") (setq xlcolumns (vlax-get-property acsheet 'Columns)) (vlax-invoke-method xlcolumns 'AutoFit) (ex:RELEASEEXCELforctcs) (princ) ) (defun c:PTEXT ( / *error* txtstring txtedit1 rowcount rowlast scstack index selectedrow selectedrowlist srllen subindex sclist ss1stacklist ss1count index2 enametoedit newtexttoedit objtoedit ) (LM:startundo (LM:acdoc)) ;error control (defun *error* ( msg ) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (princ) ) (defun mysort ( l ) (vl-sort l '(lambda ( a b ) (if (eq (car a) (car b)) (< (caddr a) (caddr b)) (< (car a) (car b)) ;(< (vl-prin1-to-string (car a)) (vl-prin1-to-string (car b))) ) ) ) ) (setq txtstring (vlax-invoke (vlax-get (vlax-get (vlax-create-object "htmlfile") 'ParentWindow) 'ClipBoardData) 'GetData "Text")) (setq txtedit1 (LM:str->lst txtstring "\r\n")) (setq rowcount (length txtedit1)) (setq rowlast (last txtedit1)) (if (= rowlast "") (setq rowcount (- rowcount 1)) (setq rowcount rowcount) ) (setq scstack '()) (setq index 0) (repeat rowcount (setq selectedrow (nth index txtedit1)) (setq selectedrowlist (LM:str->lst selectedrow "\t")) (setq srllen (length selectedrowlist)) (setq subindex 0) (repeat srllen (setq selectedcell (nth subindex selectedrowlist)) (setq sclist '()) (setq sclist (list index selectedcell subindex)) (setq scstack (cons sclist scstack)) (setq subindex (+ subindex 1)) );end of repeat (setq index (+ index 1)) ) (setq ss1stacklist (mysort scstack)) (setq ss1count (length ss1stacklist)) (setq index2 3) (repeat (- (/ ss1count 3) 1) (setq enametoedit (handent (cadr (nth index2 ss1stacklist)))) (setq newtexttoedit (cadr (nth (+ index2 2) ss1stacklist))) (setq objtoedit (vlax-ename->vla-object enametoedit)) (vlax-put-property objtoedit 'textstring newtexttoedit) (setq index2 (+ index2 3)) ) (LM:endundo (LM:acdoc)) (princ) ) (defun ex:RELEASEEXCELforctcs ( / ) (if (= AcSheet nil) (progn) (progn (vlax-release-object AcSheet) ;(princ "\n Acsheet Release for next time. Complete.") ) ) (if (= Sheets nil) (progn) (progn (vlax-release-object Sheets) ;(princ "\n Sheets Release for next time. Complete.") ) ) (if (= Workbooks nil) (progn) (progn (vlax-release-object Workbooks) ;(princ "\n Workbooks Release for next time. Complete.") ) ) (if (= ExcelApp nil) (progn) (progn (vlax-release-object ExcelApp) ;(princ "\n ExcelApp Release for next time. Complete.") ) ) ) (defun ex:ECSELPUT ( r c textstring / c addr c1 c2 c3 rng textstring2 ) (setq c (- c 1)) (cond ((and (> c -1) (< c 25)) (setq c1 (+ c 1)) (setq addr (strcat (chr (+ 64 c1)) (itoa r) ":" (chr (+ 64 c1)) (itoa r) )) );end of cond option 1 ((and (> c 24) (< c 702)) (setq c2 (fix (/ c 26))) (setq c1 (- c (* c2 26))) (setq c2 c2) (setq c1 (+ c1 1)) (setq addr (strcat (vl-princ-to-string (chr (+ 64 c2))) (vl-princ-to-string (chr (+ 64 c1))) (itoa r) ":" (vl-princ-to-string (chr (+ 64 c2))) (vl-princ-to-string (chr (+ 64 c1))) (itoa r))) );end of cond option 2 ((and (> c 701) (< c 18278)) (setq c3 (fix (/ c (* 26 26)) ) ) (setq c2 (fix (/ (- c (* c3 (* 26 26))) 26))) (setq c1 (- (- c (* (* c3 26) 26)) (* c2 26))) (setq c3 c3) (setq c2 c2) (setq c1 (+ c1 1)) (setq addr (strcat (vl-princ-to-string (chr (+ 64 c3))) (vl-princ-to-string (chr (+ 64 c2))) (vl-princ-to-string (chr (+ 64 c1))) (itoa r) ":" (vl-princ-to-string (chr (+ 64 c3))) (vl-princ-to-string (chr (+ 64 c2))) (vl-princ-to-string (chr (+ 64 c1))) (itoa r))) );end of cond option 3 );end of cond (setq c (+ c 1)) (setq rng (vlax-get-property acsheet 'Range addr)) (vlax-invoke rng 'Select) (setq textstring2 textstring) (vlax-put-property cell 'item r c textstring2) ) (defun ex:ESMAKE ( / ) ;from BIGAL's ah:chkexcel (setq excelapp (vlax-get-or-create-object "Excel.Application")) (vlax-invoke-method (vlax-get-property excelapp 'Workbooks) 'Add) (vlax-put Excelapp "visible" :vlax-true) (setq Workbooks (vlax-get-property ExcelApp 'Workbooks)) (setq Sheets (vlax-get-property ExcelApp 'Sheets)) (setq AcSheet (vlax-get-property ExcelApp 'ActiveSheet)) (setq accell (vlax-get-property ExcelApp 'Activecell)) (setq cell (vlax-get-property acsheet 'Cells)) ) ;; Active Document - Lee Mac ;; Returns the VLA Active Document Object (defun LM:acdoc nil (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object)))) (LM:acdoc) ) ;; Start Undo - Lee Mac ;; Opens an Undo Group. (defun LM:startundo ( doc ) (LM:endundo doc) (vla-startundomark doc) ) ;; End Undo - Lee Mac ;; Closes an Undo Group. (defun LM:endundo ( doc ) (while (= 8 (logand 8 (getvar 'undoctl))) (vla-endundomark doc) ) ) ;; String to List - Lee Mac ;; Separates a string using a given delimiter ;; str - [str] String to process ;; del - [str] Delimiter by which to separate the string ;; Returns: [lst] List of strings (defun LM:str->lst ( str del / pos ) (if (setq pos (vl-string-search del str)) (cons (substr str 1 pos) (LM:str->lst (substr str (+ pos 1 (strlen del))) del)) (list str) ) ) There are already tons of text editing Lisp. inside of CAD, outside of CAD, or batch modifications. so this is for my handent practice. export all text contents of a drawing to Excel with CTEXT command with handle. and put your edits in the 3rd column then copying the whole table, then input PTEXT in CAD the content is pasted in the same text based on the handle. In the case of overlapping or moving, handles were used instead of coordinates. It doesn't matter if you save the Excel file and use it or delete all unnecessary rows. because it use your clipboard

Kenny Ramage here. (AfraLisp) Semi retired now but would like to help out especially with the basics.

Hello friends, I recently was thinking on how to entmake an arc with 2 points and a radius, and since I couldn't find a solution without knowing the center point created this solution by using a lwpolyline, I don't know if it ever is useful for you or not, but if it ever happens to be useful to you give me a like or just credit. ;;; Program to create a curved lwpolyline with 2 points and a radius ;;; By Isaac A. 20220523 ;;; V1.1 (defun c:parc (/ bcal cw end r start) (while (= nil (setq start (getpoint "\nPick the start point"))) (setq start (getpoint "\nPick the start point")) ) (while (= nil (setq end (getpoint "\nPick the end point"))) (setq end (getpoint "\nPick the end point")) ) (setq r (getreal "\nGive me the radius: ")) (while (< r (/ (distance start end) 2.)) (setq r (getreal (strcat "\nThe radius can't be less than " (rtos (/ (distance start end) 2.) 2 2) ": "))) ) (setq bcal (ia:bulge start end r)) (initget 1 "Clockwise counterclockWise") (setq cw (getkword "\nSelect the path of the arc Clockwise/counterclockWise: ")) (if (= cw "Clockwise") (setq bcal (* -1 bcal)) ) (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(8 . "newlayer") '(62 . 5) '(38 . 0.0) (cons 90 2) '(70 . 0) (cons 10 start) (cons 42 bcal) (cons 10 end) '(42 . 0.) ) ) (princ) ) ;;; ia:bulge Obtains the bulge to be used on a curved lwpolyline ;;; based on 2 points and radius (defun ia:bulge (p1 p2 r / d d-2 d-4 n) (setq d (distance p1 p2)) (if (>= r (/ d 2)) (progn (setq n (/ d (* 2. r)) d-2 (cond ((equal n 1. 1e-9) (/ pi 2.)) ((equal n -1. 1e-9) (/ pi -2.)) ((< -1. n 1.) (atan n (sqrt (- 1 (expt n 2)))) ) ) d-4 (/ d-2 2.) ) (/ (sin d-4) (cos d-4)) ) (princ "\nThe radius is incorrect") ) ) Hoping it ever gets useful to anyone. Happy coding.

; BMP, BMP1, BMP2, BMP3 - 2022.05.18 exceed ; insert bmp file into dwg. ; https://www.cadtutor.net/forum/topic/75162-bmp-file-to-polyline-mosaic/ ; Command list ; BMP - Line (1 width horizontal polyline) ; BMP1 - Line with Grayscale (1 width horizontal polyline) ; BMP2 - Dot (1 length x 1 width polyline mosaic) ; BMP3 - Hatch (not completed function*, clean up the vertices of polylines and make them hatches.) ; since this lisp converts the r, g and b values of every pixel into a list, ; for a 100x100 image it creates a list with at least 30000 members. ; therefore, it is recommended to execute after reducing the size to 300x300 or less. ; when converting in the ms paint, select a 24-bit bitmap. ; version 2 updated ; - edit skipper variable calculation - more bmp files supported without errors. ; - support 32-bit bmp file also, but alpha channel is not used for polyline expression. ; - add option for grayscale (BMP1), dotted outline (BMP3) ; version 3 updated ; - add option for hatches (BMP3), ; the number of hatches is reduced to close to the number of colors used ; but I don't know if it will be useful because the hatch itself is slower than the lwpolyline. this is just for my study. ; Because "command" is used, it may not work depending on the type of CAD. Tested at zwcad2022. ; Background removal doesn't work. Only aci colors are available.) (vl-load-com) (defun c:BMP ( / bitmapbit useskipper blockpt blocknumber blockname compactrow compactlist compactcell compactlen pxsrow pxsrowlen pxscell pxslen exrmin exrmax exgmin exgmax exbmin exbmax path file lst listlen bitmapfileheader b c bitmapinfoheader widtha widthb widthc widthd biwidth heighta heightb heightc heightd biheight bitmapdata basept baseptx xreturn basepty ss exceptionyn exceptionr exceptiong exceptionb exceptionpixel 1rowdata pblue pgreen pred pixel skipper pixellist pixelcounter pixelrowstack oldpixel pixelstack psl indexr indexc row collen cell exceptionrange exceptionmin exceptionmax aciyn) (setq pixelstack (ex:BMPSTEP1)) (setq pxslen (length pixelstack)) ;(princ pixelstack) (if (= (strcase aciyn) "Y") (setq oldpixel 16777400) ; different with exception color (setq oldpixel 888) ; different with exception color ) (setq compactlist '()) (repeat pxslen (setq pxsrow (car pixelstack)) (setq pxsrowlen (length pxsrow)) (setq pixelcounter 1) (setq compactrow '()) (repeat (- pxsrowlen 1) (setq pxscell (car pxsrow)) (if (= oldpixel pxscell) (progn (setq pixelcounter (+ pixelcounter 1)) ) (progn (setq compactcell (list oldpixel pixelcounter)) (setq compactrow (cons compactcell compactrow)) (setq pixelcounter 1) ) );end of if (setq oldpixel pxscell) (setq pxsrow (cdr pxsrow)) );end of repeat (setq pxscell (car pxsrow)) (if (= oldpixel pxscell) (progn (setq pixelcounter (+ pixelcounter 1)) (setq compactcell (list pxscell pixelcounter)) (setq compactrow (cons compactcell compactrow)) ) (progn (setq compactcell (list oldpixel pixelcounter)) (setq compactrow (cons compactcell compactrow)) (setq pixelcounter 1) (setq compactcell (list pxscell pixelcounter)) (setq compactrow (cons compactcell compactrow)) ) );end of if (setq pixelcounter 1) (if (= (strcase aciyn) "Y") (setq oldpixel 16777400) ; different with exception color (setq oldpixel 888) ; different with exception color ) (setq compactlist (cons (cdr (reverse compactrow)) compactlist)) (setq pixelstack (cdr pixelstack)) );end of repeat (setq compactlist (reverse compactlist)) ;(princ compactlist) (setq compactlen (length compactlist)) (setq indexr 0) (repeat compactlen (setq row (nth indexr compactlist)) (setq collen (length row)) (setq indexc 0) (repeat collen (setq cell (nth indexc row)) (cond ((= (strcase aciyn) "Y") (if (/= (car cell) 16777300) (progn (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 (car cell)) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 1) (cons 38 0) (cons 39 0) (cons 10 (list baseptx basepty)) (cons 40 1) (cons 41 1) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx (cadr cell)) basepty)) (cons 40 1) (cons 41 1) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ) ) ((/= (strcase aciyn) "Y") (if (/= (car cell) 999) (progn (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 (car cell)) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 1) (cons 38 0) (cons 39 0) (cons 10 (list baseptx basepty)) (cons 40 1) (cons 41 1) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx (cadr cell)) basepty)) (cons 40 1) (cons 41 1) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ) ) );end of cond (setq baseptx (+ baseptx (cadr cell))) (setq indexc (+ indexc 1)) );end of repeat column (setq baseptx xreturn) (setq basepty (+ basepty 1)) (setq indexr (+ indexr 1)) );end of repeat row (if (= (sslength ss) 0) (progn (princ "\n BMP - nothing to make, edit exception range") ) (progn (princ "\n BMP - process complete, result = ") (princ (sslength ss)) (princ " lines.") ;;; Tharwat 11. May. 2012 ;; (setq blocknumber 1) (setq blockname (strcat "BMP" (itoa blocknumber))) (while (tblsearch "BLOCK" blockname) (setq blockname (strcat "BMP" (itoa (setq blocknumber (+ blocknumber 1))))) ) (setq blockpt (list (car basept) (- (cadr basept) 0.5) (caddr basept))) (setvar 'cmdecho 0) (command "_.-block" blockname blockpt ss "") (command "_.-insert" blockname blockpt "" "" "") (setvar 'cmdecho 1) ) ) (princ) ) (defun c:BMP1 ( / pgray bitmapbit useskipper blockpt blocknumber blockname compactrow compactlist compactcell compactlen pxsrow pxsrowlen pxscell pxslen exrmin exrmax exgmin exgmax exbmin exbmax path file lst listlen bitmapfileheader b c bitmapinfoheader widtha widthb widthc widthd biwidth heighta heightb heightc heightd biheight bitmapdata basept baseptx xreturn basepty ss exceptionyn exceptionr exceptiong exceptionb exceptionpixel 1rowdata pblue pgreen pred pixel skipper pixellist pixelcounter pixelrowstack oldpixel pixelstack psl indexr indexc row collen cell exceptionrange exceptionmin exceptionmax aciyn) (setq pixelstack (ex:BMPSTEP1GRAY)) (setq pxslen (length pixelstack)) ;(princ pixelstack) (setq oldpixel 888) ; different with exception color (setq compactlist '()) (repeat pxslen (setq pxsrow (car pixelstack)) (setq pxsrowlen (length pxsrow)) (setq pixelcounter 1) (setq compactrow '()) (repeat (- pxsrowlen 1) (setq pxscell (car pxsrow)) (if (= oldpixel pxscell) (progn (setq pixelcounter (+ pixelcounter 1)) ) (progn (setq compactcell (list oldpixel pixelcounter)) (setq compactrow (cons compactcell compactrow)) (setq pixelcounter 1) ) );end of if (setq oldpixel pxscell) (setq pxsrow (cdr pxsrow)) );end of repeat (setq pxscell (car pxsrow)) (if (= oldpixel pxscell) (progn (setq pixelcounter (+ pixelcounter 1)) (setq compactcell (list pxscell pixelcounter)) (setq compactrow (cons compactcell compactrow)) ) (progn (setq compactcell (list oldpixel pixelcounter)) (setq compactrow (cons compactcell compactrow)) (setq pixelcounter 1) (setq compactcell (list pxscell pixelcounter)) (setq compactrow (cons compactcell compactrow)) ) );end of if (setq pixelcounter 1) (setq oldpixel 888) ; different with exception color (setq compactlist (cons (cdr (reverse compactrow)) compactlist)) (setq pixelstack (cdr pixelstack)) );end of repeat (setq compactlist (reverse compactlist)) ;(princ compactlist) (setq compactlen (length compactlist)) (setq indexr 0) (repeat compactlen (setq row (nth indexr compactlist)) (setq collen (length row)) (setq indexc 0) (repeat collen (setq cell (nth indexc row)) (cond ((= (strcase aciyn) "Y") (if (/= (car cell) 16777300) (progn (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 (car cell)) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 1) (cons 38 0) (cons 39 0) (cons 10 (list baseptx basepty)) (cons 40 1) (cons 41 1) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx (cadr cell)) basepty)) (cons 40 1) (cons 41 1) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ) ) ((/= (strcase aciyn) "Y") (if (/= (car cell) 999) (progn (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 (car cell)) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 1) (cons 38 0) (cons 39 0) (cons 10 (list baseptx basepty)) (cons 40 1) (cons 41 1) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx (cadr cell)) basepty)) (cons 40 1) (cons 41 1) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ) ) );end of cond (setq baseptx (+ baseptx (cadr cell))) (setq indexc (+ indexc 1)) );end of repeat column (setq baseptx xreturn) (setq basepty (+ basepty 1)) (setq indexr (+ indexr 1)) );end of repeat row (if (= (sslength ss) 0) (progn (princ "\n BMP - nothing to make, edit exception range") ) (progn (princ "\n BMP - process complete, result = ") (princ (sslength ss)) (princ " lines.") ;;; Tharwat 11. May. 2012 ;; (setq blocknumber 1) (setq blockname (strcat "BMP" (itoa blocknumber))) (while (tblsearch "BLOCK" blockname) (setq blockname (strcat "BMP" (itoa (setq blocknumber (+ blocknumber 1))))) ) (setq blockpt (list (car basept) (- (cadr basept) 0.5) (caddr basept))) (setvar 'cmdecho 0) (command "_.-block" blockname blockpt ss "") (command "_.-insert" blockname blockpt "" "" "") (setvar 'cmdecho 1) ) ) (princ) ) (defun c:BMP2 ( / bitmapbit useskipper blockpt blocknumber blockname pxsrow pxsrowlen pxscell pxslen exrmin exrmax exgmin exgmax exbmin exbmax path file lst listlen bitmapfileheader b c bitmapinfoheader widtha widthb widthc widthd biwidth heighta heightb heightc heightd biheight bitmapdata basept baseptx xreturn basepty ss exceptionyn exceptionr exceptiong exceptionb exceptionpixel 1rowdata pblue pgreen pred pixel skipper exceptionrange exceptionmin exceptionmax aciyn acicolor) (setq pixelstack (ex:BMPSTEP1)) (setq pxslen (length pixelstack)) ;(princ pixelstack) (repeat pxslen (setq pxsrow (car pixelstack)) (setq pxsrowlen (length pxsrow)) (repeat pxsrowlen (setq pxscell (car pxsrow)) (if (= (strcase aciyn) "Y") (progn (if (/= pxscell 16777300) (progn (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscell) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 1) (cons 38 0) (cons 39 0) (cons 10 (list baseptx basepty)) (cons 40 1) (cons 41 1) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) basepty)) (cons 40 1) (cons 41 1) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ) );end of progn (progn (if (/= pxscell 999) (progn (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscell) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 1) (cons 38 0) (cons 39 0) (cons 10 (list baseptx basepty)) (cons 40 1) (cons 41 1) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) basepty)) (cons 40 1) (cons 41 1) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ) );end of progn );end of if (setq baseptx (+ baseptx 1)) (setq pxsrow (cdr pxsrow)) );end of repeat (setq baseptx xreturn) (setq basepty (+ basepty 1)) (setq pixelstack (cdr pixelstack)) );end of repeat (if (= (sslength ss) 0) (progn (princ "\n BMP - nothing to make, edit exception range") ) (progn (princ "\n BMP - process complete, result = ") (princ (sslength ss)) (princ " lines.") ;;; Tharwat 11. May. 2012 ;; (setq blocknumber 1) (setq blockname (strcat "BMP" (itoa blocknumber))) (while (tblsearch "BLOCK" blockname) (setq blockname (strcat "BMP" (itoa (setq blocknumber (+ blocknumber 1))))) ) (setq blockpt (list (car basept) (- (cadr basept) 0.5) (caddr basept))) (setvar 'cmdecho 0) (command "_.-block" blockname blockpt ss "") (command "_.-insert" blockname blockpt "" "" "") (setvar 'cmdecho 1) ) ) (princ) ) (defun c:BMP3 ( / acdoc sshatch2len sshatch2index obj objcoord objcol2 objcoordlen obj1st obj2nd newobjcoord objcoordindex objcoordx1 objcoordy1 objcoordx2 objcoordy2 objcoordx3 objcoordy3 sshatch4 ssindex hatchcolorlist2 hatchcolorlistlen hatchcolorlist sshatch3 sshatch2 sshatch sscol pixelstackcell2 pxscellcolor pxscellborder border bitmapbit useskipper blockpt blocknumber blockname pxsrow pxsrowlen pxscell pxslen exrmin exrmax exgmin exgmax exbmin exbmax path file lst listlen bitmapfileheader b c bitmapinfoheader widtha widthb widthc widthd biwidth heighta heightb heightc heightd biheight bitmapdata basept baseptx xreturn basepty ss exceptionyn exceptionr exceptiong exceptionb exceptionpixel 1rowdata pblue pgreen pred pixel skipper exceptionrange exceptionmin exceptionmax aciyn acicolor) (setq pixelstack (ex:BMPSTEP1)) (if (= (strcase aciyn) "Y") (setq pixelstackcell1 16777300) (setq pixelstackcell1 999) ) (setq pixelstack (ex:MakeFrameForMatrix pixelstack pixelstackcell1)) (setq pxslen (length pixelstack)) ;(princ pixelstack) (setq indexh2 1) (setq pixelstack2 '()) (repeat (- pxslen 2) (setq pixel1strow (nth indexh2 pixelstack)) (setq pixelrowlen (length pixel1strow)) (setq indexh3 1) (setq pixelstackrow2 '()) (repeat (- pixelrowlen 2) (setq pixelstackcell1 (nth indexh3 pixel1strow)) (setq border 0) (if (/= pixelstackcell1 (nth (+ indexh3 1) pixel1strow)) (setq border (+ border 1)) ) (if (/= pixelstackcell1 (nth (- indexh3 1) pixel1strow)) (setq border (+ border 2)) ) (if (/= pixelstackcell1 (nth indexh3 (nth (- indexh2 1) pixelstack)) ) (setq border (+ border 4)) ) (if (/= pixelstackcell1 (nth indexh3 (nth (+ indexh2 1) pixelstack)) ) (setq border (+ border 8)) ) (setq pixelstackcell2 (list pixelstackcell1 border)) (setq pixelstackrow2 (cons pixelstackcell2 pixelstackrow2)) (setq indexh3 (+ indexh3 1)) ) (setq pixelstack2 (cons (reverse pixelstackrow2) pixelstack2)) (setq indexh2 (+ indexh2 1)) ) (setq pixelstack2 (reverse pixelstack2)) ;(princ pixelstack2) (setq pixelstack pixelstack2) ;(princ pixelstack) (repeat (- pxslen 2) (setq pxsrow (car pixelstack)) (setq pxsrowlen (length pxsrow)) (setq baseptx xreturn) (repeat pxsrowlen (setq pxscell (car pxsrow)) (setq pxscellcolor (car pxscell)) (setq pxscellborder (cadr pxscell)) (if (= (strcase aciyn) "Y") (progn (if (/= pxscell 16777300) (progn (cond ((= pxscellborder 0)) ((= pxscellborder 1) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 2) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 3) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 4) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 5) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 6) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 7) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 8) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 9) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 10) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 11) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 12) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 13) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 14) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 15) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 420 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) );end of cond ) ) );end of progn (progn (if (/= pxscell 999) (progn (cond ((= pxscellborder 0)) ((= pxscellborder 1) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 2) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 3) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 4) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 5) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 6) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 7) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 8) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 9) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 10) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 11) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 12) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 13) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 14) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) ((= pxscellborder 15) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (- basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 pxscellcolor) (cons 67 0) (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 0) (cons 43 0) (cons 38 0) (cons 39 0) (cons 10 (list baseptx (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0) (cons 10 (list (+ baseptx 1) (+ basepty 0.5))) (cons 40 0) (cons 41 0) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss) ) );end of cond ) ) );end of progn );end of if (setq baseptx (+ baseptx 1)) (setq pxsrow (cdr pxsrow)) );end of repeat (setq basepty (+ basepty 1)) (setq pixelstack (cdr pixelstack)) );end of repeat (if (= (sslength ss) 0) (progn (princ "\n BMP - nothing to make, edit exception range") ) (progn (princ "\n BMP - process complete, result = ") (princ (sslength ss)) (princ " lines.") (if (= (strcase aciyn) "Y") (exit) ) (setq ssindex 0) (setq hatchcolorlist '()) (repeat (sslength ss) (setq sscol (cdr (assoc 62 (entget (ssname ss ssindex))))) (setq hatchcolorlist (cons sscol hatchcolorlist)) (setq ssindex (+ ssindex 1)) ) (setq hatchcolorlist (LM:unique hatchcolorlist)) (princ "\n used colors - ") (princ hatchcolorlist) (setq hatchcolorlist2 hatchcolorlist) (setq hatchcolorlistlen (length hatchcolorlist)) (setvar 'cmdecho 0) (repeat hatchcolorlistlen (setq hatchcolorset (car hatchcolorlist)) (setq sshatch (ssget "c" (list (- xreturn 0.5) (- yreturn 0.5) 0) (list baseptx (+ basepty 0.5) 0) (list (cons 0 "lwpolyline") (cons 62 hatchcolorset)) )) (command "_.mpedit" sshatch "" "_j" "0.0" "") (setq hatchcolorlist (cdr hatchcolorlist)) ) (setq sshatch2 (ssget "c" (list (- xreturn 0.5) (- yreturn 0.5) 0) (list baseptx (+ basepty 0.5) 0) (list (cons 0 "lwpolyline")) )) (setq sshatch2len (sslength sshatch2)) (setq sshatch2index 0) (setq AcDoc (vla-get-activedocument (vlax-get-Acad-Object))) (cond ((= (vla-get-activespace AcDoc) 1) (setq AcSpace (vla-get-modelspace AcDoc))) ((= (vla-get-activespace AcDoc) 0) (setq AcSpace (vla-get-paperspace AcDoc))) ) (defun safefill ( PtList ) (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length PtList)))) PtList ) ) (defun LWPoly (lst cls col) ; LM's entmake functions (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 62 col) (cons 90 (length lst)) (cons 70 cls) ) (mapcar (function (lambda (p) (cons 10 p))) lst) ) ) ) (repeat sshatch2len (setq obj (vlax-ename->vla-object (ssname sshatch2 sshatch2index))) (setq objcoord '()) (setq objcoord (vlax-safearray->list (vlax-variant-value (vlax-get-property obj 'coordinates)))) (setq objcol2 (vlax-get-property obj 'color)) (setq objcoordlen 0) (setq objcoordlen (length objcoord)) (if (> objcoordlen 8) (progn (princ "\n objcoordlen - ") (princ objcoordlen) (setq obj1st (car objcoord)) (setq obj2nd (cadr objcoord)) (setq objcoord (reverse objcoord)) (setq objcoord (append (list obj2nd obj1st) objcoord)) (setq objcoord (reverse objcoord)) (setq objcoordlen 0) (setq objcoordlen (length objcoord)) (setq newobjcoord '()) (setq newobjcoord (list (list (car objcoord) (cadr objcoord)))) (setq objcoordindex 0) (repeat (- (/ objcoordlen 2) 2) (setq objcoordx1 (nth objcoordindex objcoord)) (setq objcoordy1 (nth (+ objcoordindex 1) objcoord)) (setq objcoordx2 (nth (+ objcoordindex 2) objcoord)) (setq objcoordy2 (nth (+ objcoordindex 3) objcoord)) (setq objcoordx3 (nth (+ objcoordindex 4) objcoord)) (setq objcoordy3 (nth (+ objcoordindex 5) objcoord)) (if (or (= objcoordx1 objcoordx2 objcoordx3) (= objcoordy1 objcoordy2 objcoordy3)) (progn) (progn (setq newobjcoord (cons (list objcoordx2 objcoordy2) newobjcoord)) ) ) (setq objcoordindex (+ objcoordindex 2)) ) (setq newobjcoord (reverse newobjcoord)) (vla-delete obj) (LWPoly newobjcoord 1 objcol2) );end of progn (progn (setq newobjcoord objcoord) ) );end of if (setq sshatch2index (+ sshatch2index 1)) ) (command "_.-hatch" "_p" "SOLID" "_a" "i" "y" "s" "n" "" "") (repeat hatchcolorlistlen (setq hatchcolorset (car hatchcolorlist2)) (setq sshatch3 (ssget "c" (list (- xreturn 0.5) (- yreturn 0.5) 0) (list baseptx (+ basepty 0.5) 0) (list (cons 0 "lwpolyline") (cons 62 hatchcolorset)) )) (command "_.-hatch" "_s" sshatch3 "" "_co" hatchcolorset "" "") (setq hatchcolorlist2 (cdr hatchcolorlist2)) ) (setq sshatch4 (ssget "c" (list (- xreturn 0.5) (- yreturn 0.5) 0) (list baseptx (+ basepty 0.5) 0) (list (cons 0 "lwpolyline")) )) (command "_.erase" sshatch4 "") (setvar 'cmdecho 1) ) ) (princ) ) (defun ex:BMPSTEP1 ( / ) (princ "\n BMP Convert to Polyline - Place the bmp file in the same folder as this dwg file and run it.") (setq path (getvar 'dwgprefix)) (setq file (getfiled "Select BMP File" path "bmp" 16)) (setq lst (vlax-safearray->list (vlax-variant-value (LM:readbinarystream file 0)))) ;(princ "\n bitmap file - ") ;(princ file) (setq listlen (length lst)) ;(princ lst) (setq bitmapfileheader '()) (repeat 14 (setq b (car lst)) (setq bitmapfileheader (cons b bitmapfileheader)) (setq lst (cdr lst)) ) (setq bitmapfileheader (reverse bitmapfileheader)) ;(princ "\n bitmap file header - ") ;(princ bitmapfileheader) (setq bitmapinfoheader '()) (repeat 40 (setq c (car lst)) (setq bitmapinfoheader (cons c bitmapinfoheader)) (setq lst (cdr lst)) ) (setq bitmapinfoheader (reverse bitmapinfoheader)) ;(princ "\n bitmap info header - ") ;(princ bitmapinfoheader) ;(princ "\n bitmap data - ") ;(princ lst) (setq widtha (nth 4 bitmapinfoheader)) (setq widthb (* (nth 5 bitmapinfoheader) 256)) (setq widthc (* (nth 6 bitmapinfoheader) (* 256 256))) (setq widthd (* (nth 7 bitmapinfoheader) (* (* 256 256) 256))) (setq biwidth (+ (+ (+ widtha widthb) widthc) widthd)) (princ "\n bitmap width - ") (princ biwidth) (setq heighta (nth 8 bitmapinfoheader)) (setq heightb (* (nth 9 bitmapinfoheader) 256)) (setq heightc (* (nth 10 bitmapinfoheader) (* 256 256))) (setq heightd (* (nth 11 bitmapinfoheader) (* (* 256 256) 256))) (setq biheight (+ (+ (+ heighta heightb) heightc) heightd)) (princ " / height - ") (princ biheight) (setq bitmapbit (nth 14 bitmapinfoheader)) (cond ((= bitmapbit 24) (princ "\n it's 24 bit bmp file ")) ((= bitmapbit 32) (princ "\n it's 32 bit bmp file ")) ) (setq bitmapdata '()) (setq basept (getpoint "\n pick point for bmp (Lower Left Point) - ")) (setq baseptx (car basept)) (setq xreturn baseptx) (setq basepty (cadr basept)) (setq yreturn basepty) (setq ss (ssadd)) (setq exceptionyn (getstring "\n you want to except background color? [Y - yes / SpaceBar - no]")) (if (= (strcase exceptionyn) "Y") (progn (setq exceptionr (getint "\n input background's Red value : ")) (setq exceptiong (getint "\n input background's Green value : ")) (setq exceptionb (getint "\n input background's Blue value : ")) (setq exceptionrange (getint "\n input background's range (0~100%) : ")) (setq exceptionrange (/ (* exceptionrange 256) 100)) (setq exrmin (- exceptionr exceptionrange)) (if (< exrmin 0) (setq exrmin 0)) (setq exrmax (+ exceptionr exceptionrange)) (if (> exrmax 255) (setq exrmax 255)) (setq exgmin (- exceptiong exceptionrange)) (if (< exgmin 0) (setq exgmin 0)) (setq exgmax (+ exceptiong exceptionrange)) (if (> exgmax 255) (setq exgmax 255)) (setq exbmin (- exceptionb exceptionrange)) (if (< exbmin 0) (setq exbmin 0)) (setq exbmax (+ exceptionb exceptionrange)) (if (> exbmax 255) (setq exbmax 255)) ) ) (setq aciyn (getstring "\n Do you want to keep true color? [Y - yes / SpaceBar - no] : \n If you keep true color, the color is correct, but you need to modify the plot ctb settings.")) (cond ((= bitmapbit 24) (setq skipper (/ (- (length lst) (* (* biwidth 3) biheight)) biheight)) ) ((= bitmapbit 32) (setq skipper (/ (- (length lst) (* (* biwidth 4) biheight)) biheight)) ) ) ;(setq skipper (/ (- (length lst) (* (* biwidth 3) biheight)) biheight)) (if (> skipper 0) (progn (princ "\n If a bug that distorts the image occurs, try adjusting the skipper variable (Range 0 ~ ") (princ skipper) (princ "), default = 0 : ") (setq userskipper (getint)) (if (= userskipper nil) (setq userskipper 0)) (setq skipper (- skipper userskipper)) ) ) (princ "\n skipper - ") (princ skipper) (setq pixelstack '()) (repeat biheight (setq pixellist '()) (setq pixelrowstack '()) (repeat biwidth (setq pblue (car lst)) (setq pgreen (cadr lst)) (setq pred (caddr lst)) (if (= (strcase exceptionyn) "Y") (progn (if (<= exrmin pred) (progn (if (>= exrmax pred) (progn (if (<= exgmin pgreen) (progn (if (>= exgmax pgreen) (progn (if (<= exbmin pblue) (progn (if (>= exbmax pblue) (progn (if (= (strcase aciyn) "Y") (setq pixel 16777300) (setq pixel 999) ) ) (progn (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pred pgreen pblue)) (setq pixel (LM:RGB->ACI pred pgreen pblue)) ) ) );end of if pblue );end of progn (progn (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pred pgreen pblue)) (setq pixel (LM:RGB->ACI pred pgreen pblue)) ) ) );end of if pblue );end of progn (progn (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pred pgreen pblue)) (setq pixel (LM:RGB->ACI pred pgreen pblue)) ) ) );end of if pgreen );end of progn (progn (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pred pgreen pblue)) (setq pixel (LM:RGB->ACI pred pgreen pblue)) ) ) );end of if pgreen );end of progn (progn (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pred pgreen pblue)) (setq pixel (LM:RGB->ACI pred pgreen pblue)) ) ) );end of if pred );end of progn (progn (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pred pgreen pblue)) (setq pixel (LM:RGB->ACI pred pgreen pblue)) ) ) );end of if pred );end of progn (progn (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pred pgreen pblue)) (setq pixel (LM:RGB->ACI pred pgreen pblue)) ) ) );end of if (setq pixelrowstack (cons pixel pixelrowstack)) (cond ((= bitmapbit 24) (setq lst (cdddr lst)) ) ((= bitmapbit 32) (setq lst (cddddr lst)) ) ) ); end of repeat (setq pixelstack (cons (reverse pixelrowstack) pixelstack)) (repeat skipper (setq lst (cdr lst)) ) ) (setq pixelstack (reverse pixelstack)) ;(princ pixelstack) pixelstack ) (defun ex:BMPSTEP1GRAY ( / ) (princ "\n BMP Convert to Polyline - Place the bmp file in the same folder as this dwg file and run it.") (setq path (getvar 'dwgprefix)) (setq file (getfiled "Select BMP File" path "bmp" 16)) (setq lst (vlax-safearray->list (vlax-variant-value (LM:readbinarystream file 0)))) ;(princ "\n bitmap file - ") ;(princ file) (setq listlen (length lst)) ;(princ lst) (setq bitmapfileheader '()) (repeat 14 (setq b (car lst)) (setq bitmapfileheader (cons b bitmapfileheader)) (setq lst (cdr lst)) ) (setq bitmapfileheader (reverse bitmapfileheader)) ;(princ "\n bitmap file header - ") ;(princ bitmapfileheader) (setq bitmapinfoheader '()) (repeat 40 (setq c (car lst)) (setq bitmapinfoheader (cons c bitmapinfoheader)) (setq lst (cdr lst)) ) (setq bitmapinfoheader (reverse bitmapinfoheader)) ;(princ "\n bitmap info header - ") ;(princ bitmapinfoheader) ;(princ "\n bitmap data - ") ;(princ lst) (setq widtha (nth 4 bitmapinfoheader)) (setq widthb (* (nth 5 bitmapinfoheader) 256)) (setq widthc (* (nth 6 bitmapinfoheader) (* 256 256))) (setq widthd (* (nth 7 bitmapinfoheader) (* (* 256 256) 256))) (setq biwidth (+ (+ (+ widtha widthb) widthc) widthd)) (princ "\n bitmap width - ") (princ biwidth) (setq heighta (nth 8 bitmapinfoheader)) (setq heightb (* (nth 9 bitmapinfoheader) 256)) (setq heightc (* (nth 10 bitmapinfoheader) (* 256 256))) (setq heightd (* (nth 11 bitmapinfoheader) (* (* 256 256) 256))) (setq biheight (+ (+ (+ heighta heightb) heightc) heightd)) (princ " / height - ") (princ biheight) (setq bitmapbit (nth 14 bitmapinfoheader)) (cond ((= bitmapbit 24) (princ "\n it's 24 bit bmp file ")) ((= bitmapbit 32) (princ "\n it's 32 bit bmp file ")) ) (setq bitmapdata '()) (setq basept (getpoint "\n pick point for bmp (Lower Left Point) - ")) (setq baseptx (car basept)) (setq xreturn baseptx) (setq basepty (cadr basept)) (setq ss (ssadd)) (setq exceptionyn (getstring "\n you want to except background color? [Y - yes / SpaceBar - no]")) (if (= (strcase exceptionyn) "Y") (progn (setq exceptionr (getint "\n input background's Red value : ")) (setq exceptiong (getint "\n input background's Green value : ")) (setq exceptionb (getint "\n input background's Blue value : ")) (setq exceptionrange (getint "\n input background's range (0~100%) : ")) (setq exceptionrange (/ (* exceptionrange 256) 100)) (setq exrmin (- exceptionr exceptionrange)) (if (< exrmin 0) (setq exrmin 0)) (setq exrmax (+ exceptionr exceptionrange)) (if (> exrmax 255) (setq exrmax 255)) (setq exgmin (- exceptiong exceptionrange)) (if (< exgmin 0) (setq exgmin 0)) (setq exgmax (+ exceptiong exceptionrange)) (if (> exgmax 255) (setq exgmax 255)) (setq exbmin (- exceptionb exceptionrange)) (if (< exbmin 0) (setq exbmin 0)) (setq exbmax (+ exceptionb exceptionrange)) (if (> exbmax 255) (setq exbmax 255)) ) ) (setq aciyn (getstring "\n Do you want to keep true color? [Y - yes / SpaceBar - no] : \n If you keep true color, the color is correct, but you need to modify the plot ctb settings.")) (cond ((= bitmapbit 24) (setq skipper (/ (- (length lst) (* (* biwidth 3) biheight)) biheight)) ) ((= bitmapbit 32) (setq skipper (/ (- (length lst) (* (* biwidth 4) biheight)) biheight)) ) ) ;(setq skipper (/ (- (length lst) (* (* biwidth 3) biheight)) biheight)) (if (> skipper 0) (progn (princ "\n If a bug that distorts the image occurs, try adjusting the skipper variable (Range 0 ~ ") (princ skipper) (princ "), default = 0 : ") (setq userskipper (getint)) (if (= userskipper nil) (setq userskipper 0)) (setq skipper (- skipper userskipper)) ) ) (princ "\n skipper - ") (princ skipper) (setq pixelstack '()) (repeat biheight (setq pixellist '()) (setq pixelrowstack '()) (repeat biwidth (setq pblue (car lst)) (setq pgreen (cadr lst)) (setq pred (caddr lst)) (if (= (strcase exceptionyn) "Y") (progn (if (<= exrmin pred) (progn (if (>= exrmax pred) (progn (if (<= exgmin pgreen) (progn (if (>= exgmax pgreen) (progn (if (<= exbmin pblue) (progn (if (>= exbmax pblue) (progn (if (= (strcase aciyn) "Y") (setq pixel 16777300) (setq pixel 999) ) ) (progn (setq pgray (+ (+ (* pred 0.299) (* pgreen 0.587)) (* pblue 0.114))) (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pgray pgray pgray)) (setq pixel (LM:RGB->ACI pgray pgray pgray)) ) ) );end of if pblue );end of progn (progn (setq pgray (+ (+ (* pred 0.299) (* pgreen 0.587)) (* pblue 0.114))) (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pgray pgray pgray)) (setq pixel (LM:RGB->ACI pgray pgray pgray)) ) ) );end of if pblue );end of progn (progn (setq pgray (+ (+ (* pred 0.299) (* pgreen 0.587)) (* pblue 0.114))) (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pgray pgray pgray)) (setq pixel (LM:RGB->ACI pgray pgray pgray)) ) ) );end of if pgreen );end of progn (progn (setq pgray (+ (+ (* pred 0.299) (* pgreen 0.587)) (* pblue 0.114))) (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pgray pgray pgray)) (setq pixel (LM:RGB->ACI pgray pgray pgray)) ) ) );end of if pgreen );end of progn (progn (setq pgray (+ (+ (* pred 0.299) (* pgreen 0.587)) (* pblue 0.114))) (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pgray pgray pgray)) (setq pixel (LM:RGB->ACI pgray pgray pgray)) ) ) );end of if pred );end of progn (progn (setq pgray (+ (+ (* pred 0.299) (* pgreen 0.587)) (* pblue 0.114))) (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pgray pgray pgray)) (setq pixel (LM:RGB->ACI pgray pgray pgray)) ) ) );end of if pred );end of progn (progn (setq pgray (+ (+ (* pred 0.299) (* pgreen 0.587)) (* pblue 0.114))) (if (= (strcase aciyn) "Y") (setq pixel (LM:RGB->True pgray pgray pgray)) (setq pixel (LM:RGB->ACI pgray pgray pgray)) ) ) );end of if (setq pixelrowstack (cons pixel pixelrowstack)) (cond ((= bitmapbit 24) (setq lst (cdddr lst)) ) ((= bitmapbit 32) (setq lst (cddddr lst)) ) ) ); end of repeat (setq pixelstack (cons (reverse pixelrowstack) pixelstack)) (repeat skipper (setq lst (cdr lst)) ) ) (setq pixelstack (reverse pixelstack)) ;(princ pixelstack) pixelstack ) (defun c:mffm ( / ) (setq a (list (list 1 2 3 4) (list 5 6 7 8))) (setq no 0) (setq b (ex:MakeFrameForMatrix a no)) (princ b) (princ) ) (defun ex:MakeFrameForMatrix ( lst frameno / verticallen horizontallen 1row index original1row ) (setq verticallen (length lst)) (setq horizontallen (length (car lst))) (setq newmatrix '()) (setq 1row '()) (repeat horizontallen (setq 1row (cons frameno 1row)) ) (setq newmatrix (cons 1row newmatrix)) (setq index 0) (repeat verticallen (setq original1row (nth index lst)) (setq original1row (cons frameno original1row)) (setq original1row (cons frameno (reverse original1row))) (setq original1row (reverse original1row)) (setq newmatrix (cons original1row newmatrix)) (setq index (+ index 1)) ) (setq newmatrix (cons 1row newmatrix)) (setq newmatrix (reverse newmatrix)) newmatrix ) ;; RGB -> ACI - Lee Mac ;; Args: r,g,b - [int] Red, Green, Blue values (defun LM:RGB->ACI ( r g b / c o ) (if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2)))) (progn (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o)))) (vlax-release-object o) (if (vl-catch-all-error-p c) (prompt (strcat "\nError: " (vl-catch-all-error-message c))) c ) ) ) ) ;; RGB -> True - Lee Mac ;; Args: r,g,b - [int] Red, Green, Blue values (defun LM:RGB->True ( r g b ) (logior (lsh (fix r) 16) (lsh (fix g) 8) (fix b)) ) ;; True -> RGB - Lee Mac ;; Args: c - [int] True Colour (defun LM:True->RGB ( c ) (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24)) ) ;; True -> ACI - Lee Mac ;; Args: c - [int] True Colour (defun LM:True->ACI ( c / o r ) (apply 'LM:RGB->ACI (LM:True->RGB c)) ) ;; Application Object - Lee Mac ;; Returns the VLA Application Object (defun LM:acapp nil (eval (list 'defun 'LM:acapp 'nil (vlax-get-acad-object))) (LM:acapp) ) ;;-----------------=={ Read Binary Stream }==-----------------;; ;; ;; ;; Uses the ADO Stream Object to read a supplied file and ;; ;; returns a variant of bytes. ;; ;;------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; filename - filename of file to read. ;; ;; len - number of bytes to read ;; ;; (if non-numerical, less than 1, or greater than the size ;; ;; of the file, everything is returned). ;; ;;------------------------------------------------------------;; ;; Returns: ;; ;; Variant of Binary data which may be converted to a list ;; ;; bytes using the relevant VL Variant functions or used ;; ;; with LM:WriteBinaryStream. ;; ;;------------------------------------------------------------;; (defun LM:ReadBinaryStream ( filename len / ADOStream result ) (setq result (vl-catch-all-apply (function (lambda ( / size ) (setq ADOStream (vlax-create-object "ADODB.Stream")) (vlax-invoke ADOStream 'Open) (vlax-put-property ADOStream 'type 1) (vlax-invoke-method ADOStream 'loadfromfile filename) (vlax-put-property ADOStream 'position 0) (setq size (vlax-get ADOStream 'size)) (vlax-invoke-method ADOStream 'read (if (and (numberp len) (< 0 len size)) (fix len) -1)) ) ) ) ) (if ADOStream (vlax-release-object ADOStream)) (if (not (vl-catch-all-error-p result)) result ) ) command : BMP, BMP2 Placing the bmp file in the same folder as the drawing is easier to avoid errors. - BMP updated version of BMP2, make 1 line horizontal if pixel has same color. this will compress the capacity. - BMP2 old version, 1 length x 1 width polyline mosaic. when to use - when you do not want to IMAGEATTACH - when you do not want to use a convenient site that converts dxf or dwg - when you want to increase the drawing capacity more than necessary - when it is not possible to use the convenient raster tool of AutoCAD because it is an alternative cad this lisp creates a polyline of 1 length and 1 width like a mosaic or 1 width horizontal polyline. It can be convenient when you put a simple signature of 300x300 or less. you can remove 1 background color by entering red, green, and blue numbers. ex) 255,255,255 = white and now can set range of exception (0~100%) top : 255, 255, 255, 0% (aci color, 2533 lines) middle : 255, 255, 255, 10% (aci color, 1945 lines) bottom : 255, 255, 255, 30% (aci color, 761 lines) note - If a bug that distorts the image occurs, try adjusting the skipper variable - Because true color is used, the same rules as monochrome may not apply when plotting with ctb. to change plot style you need to use stb or change to similar indexed color. -> (latest update) add option for true color or aci color top : aci color, 2387 lines bottom : true color, 5052 lines Although I said under 300x300 is recommended However, it is not impossible to exceed that size. This is a 1920x1080 size windows XP wallpaper created with 460,000 lines over 30 minutes (by aci color) update 2022.05.12 - fix exception range % the speed decreased because r, g, b 3 values were compared. If I compare this sequentially in r, g, b order with 3 ifs. the colors that fall out first will appear, so the speed may increase. I think. -> updated in latest code update 2022.05.17 - edit skipper variable calculation - more bmp files supported without errors. except for the first 54 member headers in the bmp binary, the rest have values of r, g, and b, at the end of each line, a dummy value other than the r, g, and b values may or may not be included, it is different for each bmp file. skipper variable remove this. (It may be a carriage return or line feed of a text file. i guess) I initially mistakenly thought that this value would also 3 pairs, like r, g, and b., But it wasn't. So I edit it. - support 32-bit bmp file also, but alpha channel is not used for polyline expression. this option may be good to use in many cases, because almost of image editing programs or sites, or capture programs often use 32-bit bmp files. - add BMP1 command - grayscale calculation automatically input every r, g, b value as red * 0.299 + green * 0.587 + blue * 0.114. Calculate based on rgb values. Some colors may become non-grey during conversion to aci. - add BMP3 command - temporary step for making hatches In the case of hatches, I found that creating borders with dot-by-dot like now would be slower than polylines. For a line it is a start and end point of 2 points, but for a hatch there should be 4 points. Therefore, we need a way to make it a little simpler. And like the current outline method, if all four directions are the same color, if I delete it from the list, I will not know where to fill in the donut problem. I have to find a new way. It may be better to settle for the polyline method. So I'm going to pause this in version 2 for a while. haha update 2022.05.18 - edit BMP3 command - this will make hatch with simple vertex. but it is not completed routine.

Another: (defun c:foo (/ n p s) (if (setq s (ssget '((0 . "LWPOLYLINE")))) (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) (setq n 0) (while (setq p (vlax-curve-getpointatparam e n)) (entmakex (list '(0 . "POINT") (cons 10 p))) (setq n (+ n 0.5)) ) ) ) (princ) )

I wasn't aware there were any others. I must get out more!

Ditto !

Totally inappropriate response Jamin. Good luck with your next CAD problem. The members who have posted in this thread include 2 forum moderators and collectively have a total of about 65,000 posts.

Having a bit of spare time, I thought I would make a hatch pattern similar to the OS marsh block marsh1.pat

I made something. See if it can be useful to you. - It will copy "Layout1" multiple times, and name them "Paper1", "Paper2", ... So prepare the pagesetup of Layout1. Remove the viewport (new viewports will be created), but you can add a cartouche (or whatever you need there) Command ALS (for Automatic Layout Setup) - user set the length, height and overlap (for example 800 500 50). - user selects a polyline. -> Along the polyline rectangles (polylines) are created. -> Paper spaces are created, each with a viewport the same size as the rectangles. -> Each viewport pans/zooms (scale is set to 1.00) to a next rectangle Try it on my dwg first (vl-load-com) ;; https://www.cadtutor.net/forum/topic/18257-entmake-functions/ (defun LWPoly (lst cls) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst))) ) ;; based on @see http://www.lee-mac.com/totallengthandarea.html (defun totalLengthPolyline ( s / i) (setq l 0.0) (repeat (setq i (sslength s)) (setq e (ssname s (setq i (1- i))) l (+ l (vlax-curve-getdistatparam e (vlax-curve-getendparam e))) ) ) l ) ;;;;;;;;;;;;;;;;;;;;;; (defun vat (viewport_length viewport_height overlap / obj pline total_length needle mp1 mp2 ang1 rec1 rec2 rec3 rec4) ;; settings ;;(setq viewport_length 700.0) ;;(setq viewport_height 400.0) ;;(setq overlap 50.0) ;; (princ "\nSelect Polytine") (setq pline (ssget (list (cons 0 "LWPOLYLINE,POLYLINE")) )) (setq obj (vlax-ename->vla-object (ssname pline 0))) (princ (setq total_length (totalLengthPolyline pline)) ) (setq needle 0.0) (while (< needle total_length) ;; (+ total_length viewport_length) (setq mp1 (vlax-curve-getPointAtDist obj needle)) (setq needle (+ needle viewport_length)) (setq mp2 (vlax-curve-getPointAtDist obj needle)) ;; last point, take the end of the polyline (if (= mp2 nil) (setq mp2 (vlax-curve-getPointAtDist obj total_length)) ) (setq ang1 (angle mp1 mp2)) (setq rec1 (polar mp2 (+ ang1 (/ pi 2)) (/ viewport_height 2))) (setq rec2 (polar rec1 (+ ang1 pi) viewport_length)) (setq rec3 (polar rec2 (+ ang1 (* pi 1.5)) viewport_height)) (setq rec4 (polar rec3 ang1 viewport_length)) ;; fill in the globals (setq LWPolylines_data (append LWPolylines_data (list (list rec1 rec2 rec3 rec4) ))) (setq LWPolylines (append LWPolylines (list (LWPoly (list rec1 rec2 rec3 rec4) 1) ))) (setq pointpairs (append pointpairs (list (list mp1 mp2) ))) (setq needle (- needle overlap)) ) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; c:copying-lay-out ;; It will name the layouts "Paper1", "Paper2", ... (defun clo (pointpairs / i n layoutname ) (if (and (setq layoutname "Layout1") (setq n (length pointpairs)) ;; number of new layouts (setq i (+ n 1)) (member layoutname (layoutlist)) ) (repeat n (command "layout" "Copy" layoutname (strcat "Paper" (rtos (setq i (- i 1)))) ) );; repeat );; if (princ) );; demo (defun AlignView (p1 p2 / ang) ;;(command "ucs" "world" "\\") (and ;;(setq p1 (getpoint "\nFirst alignment point: ")) ;;(setq p2 (getpoint p1 "\nSecond alignment point: ")) (setq ang (- (angle (trans p1 1 0) (trans p2 1 0)))) (command "_.dview" "" "_twist" (angtos ang (getvar 'aunits) 16) "") ) (command "ucs" "view" "\\") (princ) ) ;; rotate view (defun rv (1point 2point / ) (command "_ucs" "_w") (if (and 1point 2point) (progn (command "_zoom" "_c" 1point "") (if (= (getvar "angdir") 0) (command "_dview" "" "_tw" (angtos (+ (* -1 (angle 1point 2point)) (getvar "angbase"))(getvar "aunits") 10) "") (command "_dview" "" "_tw" (angtos (+ (angle 1point 2point) (getvar "angbase")) (getvar "aunits") 10) "") ) (setvar "snapang" (angle 1point 2point)) );progn (progn (command "_dview" "" "_tw" "0" "") (setvar "snapang" 0.0) );progn ) (command "_ucs" "_w") (princ) );end defun ;; globals (setq pointpairs (list)) (setq LWPolylines (list)) (setq LWPolylines_data (list)) (defun ALS (viewport_length viewport_height overlap / i pair pt1 pt2) ;; settings ;;(setq viewport_length 800.0) ;;(setq viewport_height 500.0) ;;(setq overlap 50.0) ;; (re) initiate globals (setq LWPolylines (list)) (setq LWPolylines_data (list)) (setq pointpairs (list)) (vat viewport_length viewport_height overlap) (clo pointpairs) (princ LWPolylines_data) (setq i 0) (foreach pair pointpairs (setvar "ctab" (strcat "Paper" (itoa (+ i 1) ))) ;; This example creates a paper space viewport and makes it active. (setq acadObj (vlax-get-acad-object)) (setq doc (vla-get-ActiveDocument acadObj)) (setq centerPoint (vlax-3d-point (/ viewport_length 2.0) (/ viewport_height 2.0) 0) height viewport_height width viewport_length) ;; Create a paper space Viewport object (vla-put-ActiveSpace doc acPaperSpace) (setq newPViewport (vla-AddPViewport (vla-get-PaperSpace doc) centerPoint width height)) (vla-ZoomAll acadObj) (vla-Display newPViewport :vlax-true) ;; Before making a pViewport active, ;; the mspace property needs to be True (vla-put-MSpace doc :vlax-true) (vla-put-ActivePViewport doc newPViewport) (rv (nth 0 pair) (nth 1 pair)) ;; pt1 pt2 ;zoom window (setq pt1 (nth 2 (nth i LWPolylines_data))) (setq pt2 (nth 0 (nth i LWPolylines_data))) (command "zoom" "_o" (nth i LWPolylines) "") (vla-put-MSpace doc :vlax-false) (vla-put-customscale newPViewport 1.0) ;;(command "_.PSPACE") ;;(command "ucs" "world" "\\") (setq i (+ i 1)) ) ) ;; Automatic layout setup (defun c:ALS2 ( / viewport_length viewport_height overlap ) ;; settings (setq viewport_length 800.0) (setq viewport_height 500.0) (setq overlap 50.0) (ALS viewport_length viewport_height overlap ) ) ;; Automatic layout setup (defun c:ALS ( / ) (ALS (getreal "\nViewport length: ") (getreal "\nViewport height: ") (getreal "\noverlap: ") ) ) viewports_along_track.dwg

For primary entities only, use a combination of tblobjname & entnext: (defun blockcomponents ( blk / ent lst ) (if (setq ent (tblobjname "block" blk)) (while (setq ent (entnext ent)) (setq lst (cons ent lst)) ) ) (reverse lst) ) Call the above with a block name argument, e.g.: _$ (blockcomponents "YourBlockName") (<Entity name: 7ffff706950> <Entity name: 7ffff706960> <Entity name: 7ffff706970>) To include nested objects, check for the presence of a block reference (INSERT) entity and include a recursive call, e.g.: (defun blockcomponents ( blk / ent enx lst ) (if (setq ent (tblobjname "block" blk)) (while (setq ent (entnext ent)) (if (= "INSERT" (cdr (assoc 0 (setq enx (entget ent))))) (setq lst (vl-list* (blockcomponents (cdr (assoc 2 enx))) ent lst)) (setq lst (cons ent lst)) ) ) ) (reverse lst) ) The above will return a list of entity names with sublists containing the entity names corresponding to the components of nested block references, e.g.: _$ (blockcomponents "block1") (<Entity name: 7ffff7069f0> <Entity name: 7ffff706a00>) _$ (blockcomponents "block2") (<Entity name: 7ffff706a50> (<Entity name: 7ffff7069f0> <Entity name: 7ffff706a00>) <Entity name: 7ffff706a60> <Entity name: 7ffff706a70>) _$ (blockcomponents "block3") (<Entity name: 7ffff706ad0> (<Entity name: 7ffff706a50> (<Entity name: 7ffff7069f0> <Entity name: 7ffff706a00>) <Entity name: 7ffff706a60> <Entity name: 7ffff706a70>) <Entity name: 7ffff706ae0> <Entity name: 7ffff706af0>) Here, Block1 is nested within Block2 is nested within Block3. If you don't want the nested list structure, use append in place of vl-list*, e.g.: (defun blockcomponents ( blk / ent enx lst ) (if (setq ent (tblobjname "block" blk)) (while (setq ent (entnext ent)) (if (= "INSERT" (cdr (assoc 0 (setq enx (entget ent))))) (setq lst (append (blockcomponents (cdr (assoc 2 enx))) (cons ent lst))) (setq lst (cons ent lst)) ) ) ) (reverse lst) ) This now returns a flat list: _$ (blockcomponents "block1") (<Entity name: 7ffff7069f0> <Entity name: 7ffff706a00>) _$ (blockcomponents "block2") (<Entity name: 7ffff706a50> <Entity name: 7ffff706a00> <Entity name: 7ffff7069f0> <Entity name: 7ffff706a60> <Entity name: 7ffff706a70>) _$ (blockcomponents "block3") (<Entity name: 7ffff706ad0> <Entity name: 7ffff706a70> <Entity name: 7ffff706a60> <Entity name: 7ffff7069f0> <Entity name: 7ffff706a00> <Entity name: 7ffff706a50> <Entity name: 7ffff706ae0> <Entity name: 7ffff706af0>)

Just posted this over at theSwamp, thought I'd share it with you fine people also. I was inspired to write a few functions that will generate entities using the minimum possible data requirements - hence all other values are taken as default. This is handy for those who want to quickly generate entities without having to look up what codes are necessary, and which are surplus to requirement. Also, it helps beginners to use the entmake function in their codes, without too much effort. These, of course, are the quickest way to generate entities in AutoCAD - quicker than VL, and much quicker than a command call. Also, they are not affected by OSnap (so no need to turn it off). Example of usage, to create a line from (0,0,0) to (1,0,0): (Line '(0 0 0) '(1 0 0)) Yes, its as easy as that. The functions will also return the entity name of the newly created entity (if successful), and so, no need to be using 'entlast'... If you have any queries as to how to use them, just ask. (defun 3DFace (p1 p2 p3 p4) (entmakex (list (cons 0 "3DFACE") (cons 10 p1) (cons 11 p2) (cons 12 p3) (cons 13 p4)))) (defun Arc (cen rad sAng eAng) (entmakex (list (cons 0 "ARC") (cons 10 cen) (cons 40 rad) (cons 50 sAng) (cons 51 eAng)))) (defun AttDef (tag prmpt def pt hgt flag) (entmakex (list (cons 0 "ATTDEF") (cons 10 pt) (cons 40 hgt) (cons 1 def) (cons 3 prmpt) (cons 2 tag) (cons 70 flag)))) (defun Circle (cen rad) (entmakex (list (cons 0 "CIRCLE") (cons 10 cen) (cons 40 rad)))) (defun Ellipse (cen maj ratio) (entmakex (list (cons 0 "ELLIPSE") (cons 100 "AcDbEntity") (cons 100 "AcDbEllipse") (cons 10 cen) (cons 11 maj) (cons 40 ratio) (cons 41 0) (cons 42 (* 2 pi))))) (defun Insert (pt Nme) (entmakex (list (cons 0 "INSERT") (cons 2 Nme) (cons 10 pt)))) (defun Line (p1 p2) (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))) (defun LWPoly (lst cls) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst)))) (defun M-Text (pt str) (entmakex (list (cons 0 "MTEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbMText") (cons 10 pt) (cons 1 str)))) (defun Point (pt) (entmakex (list (cons 0 "POINT") (cons 10 pt)))) (defun Polyline (lst) (entmakex (list (cons 0 "POLYLINE") (cons 10 '(0 0 0)))) (mapcar (function (lambda (p) (entmake (list (cons 0 "VERTEX") (cons 10 p))))) lst) (entmakex (list (cons 0 "SEQEND")))) (defun Solid (p1 p2 p3 p4) (entmakex (list (cons 0 "SOLID") (cons 10 p1) (cons 11 p2) (cons 12 p3) (cons 13 p4)))) (defun Text (pt hgt str) (entmakex (list (cons 0 "TEXT") (cons 10 pt) (cons 40 hgt) (cons 1 str)))) (defun Trce (p1 p2 p3 p4) (entmakex (list (cons 0 "TRACE") (cons 10 p1) (cons 11 p2) (cons 12 p3) (cons 13 p4)))) (defun xLine (pt vec) (entmakex (list (cons 0 "XLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbXline") (cons 10 pt) (cons 11 vec)))) (defun Layer (Nme) (entmake (list (cons 0 "LAYER") (cons 100 "AcDbSymbolTableRecord") (cons 100 "AcDbLayerTableRecord") (cons 2 Nme) (cons 70 0)))) (defun Layer (Nme Col Ltyp LWgt Plt) (entmake (list (cons 0 "LAYER") (cons 100 "AcDbSymbolTableRecord") (cons 100 "AcDbLayerTableRecord") (cons 2 Nme) (cons 70 0) (cons 62 Col) (cons 6 Ltyp) (cons 290 Plt) (cons 370 LWgt)))) The list is a working progress of course, but this is what I have so far. Also, if the argument names aren't too clear, a reference as to what they mean can be found here. Lee

I end up posting these all over the forum, so I might as well post a lot of them in one place for those who are interested. _________________________________________________________ Explanation of the Apostrophe: http://www.cadtutor.net/forum/showpost.php?p=258390&postcount=20 Explanation of Logand/Logior: http://www.cadtutor.net/forum/showpost.php?p=298061&postcount=8 Working with Attributes: http://www.cadtutor.net/forum/showpost.php?p=330778&postcount=2 Explanation of Conditionals (CAB/Lee Mac) http://www.cadtutor.net/forum/showpost.php?p=173196&postcount=10 http://www.cadtutor.net/forum/showpost.php?p=240943&postcount=2 http://www.cadtutor.net/forum/showpost.php?p=273108&postcount=12 Selection Set to List http://www.cadtutor.net/forum/showpost.php?p=248285&postcount=2 Block rename: http://www.cadtutor.net/forum/showpost.php?p=242147&postcount=24 VL Method Differences: http://www.cadtutor.net/forum/showpost.php?p=258403&postcount=9 Starting LISP: http://www.afralisp.net/ http://www.jefferypsanders.com/autolisptut.html http://ronleigh.info/autolisp/index.htm More Advanced LISP Tutorials/Help: http://augiru.augi.com/content/library/au07/data/paper/CP311-4.pdf http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-4.html http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node1.html DCL Tutorials: http://www.jefferypsanders.com/autolisp_DCL.html http://www.afralisp.net/ Visual LISP Editor: http://www.afralisp.net/vl/vlisp.htm http://www.afralisp.net/vl/vl-edit.htm http://midpointcad.com/au/docs/lakose_The_Visual_LISP_Developers_Bible.pdf Error Handlers: http://www.afralisp.net/lispa/lisp6.htm http://www.cadtutor.net/forum/showthread.php?t=33966 http://www.cadtutor.net/forum/showpost.php?p=261049&postcount=3 -4 SelectionSets: http://www.afralisp.net/lisp/filter.htm http://www.theswamp.org/index.php?topic=28672.0 Layer Renaming: http://www.cadtutor.net/forum/showthread.php?t=38810 Attributes in VL: http://www.cadtutor.net/forum/showpost.php?p=259620&postcount=9 PaperSpace/ModelSpace Objects: http://www.cadtutor.net/forum/showpost.php?p=259934&postcount=13 Vla-File-Systime: http://www.cadtutor.net/forum/showthread.php?t=38331 Linking Objects with XData: http://www.cadtutor.net/forum/showpost.php?p=251211&postcount=12 Explanation of a LISP function (Text replacement): http://www.cadtutor.net/forum/showpost.php?p=264546&postcount=15 Explanation of a LISP function (Text Height Change): http://www.cadtutor.net/forum/showpost.php?p=306576&postcount=14 Explanation of a LISP function (Reinsert all blocks @ 0,0,0): http://www.cadtutor.net/forum/showpost.php?p=309366&postcount=15 SSGet Available Options: http://www.theswamp.org/index.php?topic=29972 Localising Variables: http://www.cadtutor.net/forum/showpost.php?p=265649&postcount=4 Express Tools Functions: http://www.afralisp.net/lisp/acet-utils.htm http://www.theswamp.org/index.php?action=dlattach;topic=28777.0;attach=12477 http://www.theswamp.org/index.php?topic=13719.0 http://www.theswamp.org/index.php?topic=19505.0 Entmake: http://www.theswamp.org/index.php?topic=4814.0 Undocumented LISP Functions: http://www.manusoft.com/cgi-bin/NoFrames.pl?referer=http://www.manusoft.com/resources/AcadExposed/Index.stm&header=Header.stm&toc=TOC.stm&main=Main.stm#AutoLISP Auto-Loading LISP (ACADDOC.lsp etc): http://www.theswamp.org/index.php?topic=9211.0 http://www.theswamp.org/index.php?topic=20492.0 http://www.cadtutor.net/faq/questions/53/How+do+I+automatically+load+variables%3F AutoCAD Command Prefixes: http://www.cadforum.cz/cadforum_en/qaID.asp?tip=2425 Deleting DWS Associations: http://www.cadtutor.net/forum/showthread.php?t=43380 Car/Cadr/Caddr Explained: http://ronleigh.info/autolisp/afude09.htm http://www.theswamp.org/index.php?topic=31473.0 Default Options: http://www.cadtutor.net/forum/showthread.php?t=39634 Script Writer: http://www.cadtutor.net/forum/showpost.php?p=295487&postcount=23 Demise of VBA: http://www.cadtutor.net/forum/showthread.php?t=32857 Command Vs Entmake Vs VL: http://rkmcswain.blogspot.com/2007/12/command-vs-entmake-vs-vla-add.html Explanation of Boole Function: http://www.cadtutor.net/forum/showpost.php?p=306339&postcount=9 Varying ways to Change Text Height: http://www.cadtutor.net/forum/showpost.php?p=296877&postcount=4 What are vl*,vlax* etc?: http://www.cadtutor.net/forum/showpost.php?p=318549&postcount=2 Setq Vs. Set: http://www.theswamp.org/index.php?topic=27226.msg328322#msg328322 AutoCAD Animation: http://www.cadtutor.net/forum/showthread.php?t=45146 http://www.cadtutor.net/forum/showthread.php?t=1202 http://www.cadtutor.net/forum/showthread.php?t=883 Safearrays/Variants: http://www.theswamp.org/index.php?topic=31674.0 http://www.theswamp.org/index.php?topic=29248.0 DDAtte2 (with visibility toggles): http://www.cadtutor.net/forum/showpost.php?p=308469&postcount=5 _________________________________________________________ Enjoy! Lee

One lisp file is better than two : a lisp file and a dcl file. But I have tons of dcl files so just for fun (Grrr knows all about fun) decided to make a tiny lisp in my lunch break to make this just a little bit more easier for me, myself and I. Probably not the first with this idea , haven't checked it (maybe I should have...) , also haven't tested it much (also should have done this) but hey , almost weekend... so go check youself! ; RLX - 25 Jan 2019 - just another luchtime fun (defun RLX_Convert_Dcl ( / dcl-fn dcl-fp lsp-fn lsp-fp dir base inp) (if (and (setq dcl-fn (getfiled "Select DCL file" "" "dcl" 0)) (setq dcl-fp (open dcl-fn "r")) (setq lsp-fn (strcat (setq dir (car (fnsplitl dcl-fn))) (setq base (cadr (fnsplitl dcl-fn))) "_dcl.lsp")) (setq lsp-fp (open lsp-fn "w"))) (progn (princ (strcat "(defun " base "_Write_Dialog ( )\n (if (and (setq " base "-fn " "(vl-filename-mktemp ") lsp-fp) (prin1 (strcat base ".dcl") lsp-fp) (princ (strcat ")) (setq " base "-fp (open " base "-fn \"w\")))\n") lsp-fp) (princ (strcat " (mapcar \n '(lambda (x)(write-line x " base "-fp))\n (list\n") lsp-fp) (while (setq inp (read-line dcl-fp)) (princ " " lsp-fp)(prin1 inp lsp-fp)(princ "\n" lsp-fp)) (princ (strcat " )\n )\n )\n (if " base "-fp (close " base "-fp))\n)") lsp-fp) (close dcl-fp)(close lsp-fp)(gc) ) ) (if (and lsp-fn (findfile lsp-fn))(startapp "notepad" lsp-fn)) (princ) ) ; (RLX_Convert_Dcl) ; original dcl file name : rlx.dcl ; rlx : dialog ; { label = "RLX (RLX Jan'19)"; ; : list_box { key = "lb"; } ; ok_cancel; ; } ; converted to rlx_dcl.lsp: ;(defun rlx_Write_Dialog ( ) ; (if (and (setq rlx-fn (vl-filename-mktemp "rlx.dcl")) (setq rlx-fp (open rlx-fn "w"))) ; (mapcar ; '(lambda (x)(write-line x rlx-fp)) ; (list ; "rlx : dialog" ; " { label = \"RLX (RLX Jan'19)\";" ; " : list_box { key = \"lb\"; }" ; " ok_cancel;" ; " }" ; ) ; ) ; ) ; (if rlx-fp (close rlx-fp)) ; )

I wanted more buttons but ran out of space so just created an alternative reallity for myself. It's very basic / simple and still a work in progress but as usual time is not on my side especially now my boss in away for 4 weeks and he probably was afraid I would get bored and start to play with myself so he left me with a load of work. Update : because this routine uses grread you can't run any other (transparent) commands. Thats why I added 'hot' keys for zoom. E for extents, Z for zoom , + & - for zooming in & out. Maybe it's useful , maybe it's not...bite me. ;;; RlxGrMenu - 2025-07-09 - Just a funny / very basic little 'toolbar' ;;; It draws a column with 12 rows. Config is not working yet, quit by click or by typing Q or q. ;;; I've run a little out of button-space so wanted an out of the box solution to this problem. ;;; this is just a way to run my 10 most used lisp routines, nothing more , nothing less. ;;; Substitute the names in app-list (setq app-list '("LC" "VT" ...) with names from your own favorite apps ;;; apps have to be in search path so (findfile (strcat "MyApp" ".lsp") should work'. ;;; Also app should not be self executing and the start command should be same as app name ;;; If your app is named "MyApp" this routine loads app if found and starts it with (eval (read (strcat "C:" "Myapp"))) ;;; have fun ;;; ------------------------------ ;;; ;;; |S1 S2| ;;; ;;; | -------------- ----- [a]| ;;; ;;; | |E1 E2| [b]| ;;; ;;; | | | [c]| ;;; ;;; | | | [d]| ;;; ;;; | |E3 E4| [e]| ;;; ;;; | -------------------- [f]| ;;; ;;; |S3 S4| ;;; ;;; ------------------------------ ;;; ;;; (count_calcula) : ;;; values are effected by resize window : vc , vs , ss , x+ , x- , y+ , y- , P1-P4 ;;; screen corner points : S1 = (x- y+) , S2 (x+ y+) , S3 (x- y-) , S4 (x+ y-) ;;; extents corner points : E1 - E5 extmin / extmax ;;; viewsize : vs - height current viewport (drawing units) (i.e. 300 / 386 after resize) ;;; screen size : ss (1187 532) (pixels) after max acad window : vs = 386 , ss = (1840 685) ;;; - 12 rows, 1-10 for user , 11 for confid , 12 for exit ;;; - height each row = (fix (/ (- y+ y-) 12)) , for example 25 ;;; - row width = row height , lets call it cell-size ;;; cell-ip = (list (- (fix x+) cell-size) (fix y+)) ;;; vector draw cell-ip -> cell-size<0, (* cell-size 12)<270 , cell-size<180 , (* cell-size 12)<90 (defun draw_menu ( / ip-x ip-y cell-h cell-w cell-ul cell-ll cell-ur cell-lr y-list ctr-x app-list app gr-loop tblc tbtc) (setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare" "Config" "Quit")) (setq gr-loop T tblc 7 tbtc 7) ;;; toolbar line color / toolbar text colot (redraw_menu) ;;; launch app (if app (RlxGrMenu_Start_App app)) ) (defun redraw_menu () (redraw) ;;; get live screen data (count_calcula) ;(setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare" "Config" "Quit")) ;(setq cell-h (fix (/ (- y+ y-) 12)) cell-w (* cell-h 2)) ;;;; corner points ;(setq cell-ul (list (- (fix x+) cell-w) (fix y+)) cell-ur (list (fix x+) (fix y+)) ; cell-ll (list (- (fix x+) cell-w) (fix y-)) cell-lr (list (fix x+) (fix y-))) (setq cell-h (/ (- y+ y-) 12) cell-w (* cell-h 2)) ;;; corner points (setq cell-ul (list (- x+ cell-w) y+) cell-ur (list x+ y+) cell-ll (list (- x+ cell-w) y-) cell-lr (list x+ y-)) ;;; draw the outlines (grdraw cell-ll cell-ul tblc)(grdraw cell-ul cell-ur tblc)(grdraw cell-ur cell-lr tblc)(grdraw cell-lr cell-ll tblc) ;;; get y values for all horizontal separators (setq x-list (list (car cell-ll) (car cell-lr)) y-list (gnl- (- (fix y+) cell-h) 11 cell-h)) (foreach y y-list (grdraw (list (car cell-ll) y) (list (car cell-lr) y) tblc)) ;;; label the cell (setq ctr-x (+ (car cell-ll) (* cell-w 0.5))) (mapcar '(lambda (s y) (grtxt (strcase s) (list ctr-x (+ y (* cell-h 0.5))) tbtc 0 "M")) app-list (append y-list (list (- (last y-list) cell-h)))) (if gr-loop (RlxGrMenu_Get_Cell_ID x-list y-list)) (princ) ) ;;; (re) calculate display parameters (count_calcula) (defun count_calcula () (setq vc (getvar "VIEWCTR") vs (getvar "VIEWSIZE") ss (getvar "SCREENSIZE") dx (* vs (/ (car ss) (cadr ss)) 0.5) dy (* vs 0.5) x- (- (car vc) dx) y- (- (cadr vc) dy) x+ (+ (car vc) dx) y+ (+ (cadr vc) dy) ip (getvar "viewctr") vc-x (car ip) vc-y (cadr ip) txt-h (/ (getvar "VIEWSIZE") 100.0))) ;;; (getvar "extmin") (getvar "extmax") (setq dvx (- x+ x-) dvy (- y+ y-)) (defun screen_res (/ s i is) (setq s (vlax-invoke (vlax-create-object "WbemScripting.SWbemLocator") 'ConnectServer nil nil nil nil nil nil nil) is (vlax-invoke s 'ExecQuery "SELECT CurrentHorizontalResolution, CurrentVerticalResolution FROM Win32_VideoController")) (vlax-for i is (vlax-get i 'CurrentHorizontalResolution))) ;;; get aspect ratio current screen (defun asp_rat () (rtos (* 1.5 (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))))) ;;; determine status caps lock for when typing filter (even though filter uses strcase) (defun case (s) (cond ((null s) "") ((not (eq (type s) 'STR)) "") ((null capslock) s) (t (if (= (acet-sys-keystate 20) 0) (strcase s t) (strcase s))))) ;;; generate number (gnum 1 5) -> '(1 2 3 4 5) (defun gnum (s e / i l) (and (numberp s)(numberp e)(setq i s)(while (<= i e)(setq l (cons i l) i (1+ i)))) (reverse l)) ;;; i = startnumber n = number of numbers , d = difference (gnl- 100 6 12) -> (100 88 76 64 52 40) (defun gnl- (i n d / l) (setq l (list i))(repeat (1- n)(setq l (cons (setq i (- i d)) l)))(reverse l)) ;;; found this old lisp (grtxt.lsp) , don't know author but all credits are for this human from earth ;;; text string / coordinate point / color / angle justificationz ;;; *** UPPER CASE ONLY *** (grtxt (STRCASE "Rob") (getvar "viewctr") 1 0 "M") (defun grtxt (ts cp cl a j / vp ltb i xp z c p1 p2 lp ld n al) ;;; vertex points (setq vp '(( 1 ( 0.50 0.25))( 2 ( 0.50 0.55))( 3 ( 0.50 0.85))( 4 ( 0.50 1.00))( 5 ( 0.25 1.00)) ( 6 ( 0.00 1.00))( 7 (-0.25 1.00))( 8 (-0.50 1.00))( 9 (-0.50 0.85))(10 (-0.50 0.55)) (11 (-0.50 0.25))(12 (-0.50 0.10))(13 (-0.25 0.10))(14 ( 0.00 0.10))(15 ( 0.25 0.10)) (16 ( 0.50 0.10))(17 ( 0.50 -0.05))(18 ( 0.50 -0.45))(19 ( 0.50 -0.85))(20 ( 0.50 -1.00)) (21 ( 0.25 -1.00))(22 ( 0.00 -1.00))(23 (-0.25 -1.00))(24 (-0.50 -1.00))(25 (-0.50 -0.85)) (26 (-0.50 -0.40))(27 (-0.50 -0.05))(30 ( 0.35 0.85))(31 (-0.35 0.85))(32 (-0.35 -0.85)) (33 ( 0.35 -0.85))(40 ( 0.25 0.35))(41 (-0.25 0.35))(42 ( 0.25 -0.15))(43 (-0.25 -0.15)) (44 ( 0.00 0.45))(45 ( 0.00 -0.25))(50 ( 0.30 0.20))(51 ( 0.30 0.35))(52 ( 0.20 0.35)) (53 ( 0.20 0.20))(54 ( 0.30 0.10))(55 ( 0.30 -0.10))(56 ( 0.20 -0.10))(57 ( 0.20 0.10)) (60 (-0.30 0.20))(61 (-0.30 0.35))(62 (-0.20 0.35))(63 (-0.20 0.20))(64 (-0.30 0.10)) (65 (-0.30 -0.10))(66 (-0.20 -0.10))(67 (-0.20 0.10)))) ;;; letter table (setq ltb '(("A" 24 9 7 5 3 20 16 12) ("B" 12 15 1 3 5 8 24 21 19 17 15) ("C" 3 5 7 9 25 23 21 19) ("D" 3 5 8 24 21 19 3) ("E" 4 8 12 15 12 24 20) ("F" 4 8 12 15 12 24) ("G" 3 5 7 9 25 23 21 19 16 14) ("H" 20 -4 8 -24 16 12) ("I" 7 5 6 22 23 21) ("J" 4 19 21 23 25) ("K" 8 24 12 13 4 13 20) ("L" 8 24 20) ("M" 24 8 14 4 20) ("N" 24 8 20 4) ("O" 3 5 7 9 25 23 21 19 3) ("P" 12 15 1 3 5 8 24) ("Q" 3 5 7 9 25 23 21 19 3 -19 20 45) ("R" 20 14 12 15 1 3 5 8 24) ("S" 3 5 7 9 11 13 15 17 19 21 23 25) ("T" 4 8 6 22) ("U" 8 25 23 21 19 4 20) ("V" 8 22 4) ("W" 8 23 14 21 4) ("X" 4 -24 8 20) ("Y" 8 14 22 14 4) ("Z" 8 4 24 20) ("0" 3 5 7 9 25 23 21 19 -3 4 24) ("1" 31 7 6 22 21 23) ("2" 9 7 5 3 1 15 13 27 24 20) ("3" 9 7 5 3 1 15 13 15 17 19 21 23 25) ("4" 8 12 16 15 5 21) ("5" 4 8 12 15 17 19 21 23 25) ("6" 3 5 7 9 25 23 21 19 17 15 12) ("7" 8 4 22) ("8" 3 5 7 9 11 13 27 25 23 21 19 17 15 13 15 1 3) ("9" 25 23 21 19 3 5 7 9 11 13 16) ("<" 4 12 20) (">" 8 16 24) ("," 33 21) ("." 19 20 21 33 19) ("\'" 4 30) ("\"" 4 -30 7 31) (";" 50 51 52 53 -50 54 55 56 57 55 45) (":" 50 51 52 53 -50 54 55 56 57 55) ("\\" 8 20) ("/" 4 24) ("?" 11 10 7 5 2 1 45 22) ("|" 6 -44 45 22) ("+" 44 -45 13 15) ("=" 40 -41 43 42) ("-" 13 15) ("_" 20 24) (")" 6 2 18 22) ("(" 6 10 26 22) ("*" 40 -43 41 -42 45 44) ("&" 21 31 7 6 26 25 23 16) ("^" 10 6 2) ("%" 57 54 55 56 -57 63 60 61 62 -63 5 24) ("$" 3 5 7 9 11 13 15 17 19 21 23 25 -26 22 6) ("#" 24 -6 22 -4 1 -11 17 27) ("@" 42 15 40 44 41 13 43 45 42 17 3 5 7 9 25 23 21 19) ("!" 6 -45 22 22) ("~" 9 31 44 40 2) ("`" 8 31) ("[" 6 8 24 22) ("]" 6 4 20 22) ("{" 6 7 41 12 43 23 22) ("}" 6 5 40 16 42 21 22) (""))) ;;; text height (setq z (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")) 0.2)) (cond ;;; left justification ((eq (strcase (substr j 1 1)) "L") (setq xp (list (+ (car cp) z) (cadr cp)) i 1)) ;;; middle justification ((eq (strcase (substr j 1 1)) "M") (setq xp (list (- (car cp) (* z (strlen ts) 0.5)) (cadr cp)) i 1)) ;;; right justification ((eq (strcase (substr j 1 1)) "R") (setq xp (list (- (car cp) (* z (strlen ts) 1.5)) (cadr cp)) i 1)) ) (repeat (strlen ts) ;;; each charachter / line point list / letter point def (setq c (substr ts i 1) lp '() ld (cdr (assoc c ltb))) (while (> (length ld) 1) (setq p1 (cadr (assoc (abs (nth 0 ld)) vp)) p2 (cadr (assoc (abs (nth 1 ld)) vp)) p1 (mapcar '* (list z z) p1) p2 (mapcar '* (list z z) p2) p1 (mapcar '+ xp p1) p2 (mapcar '+ xp p2) lp (append lp (list (if (minusp (nth 0 ld)) 0 cl) p1 p2)) ld (cdr ld)) ) ;;; add rotation angle (setq n 0 al nil) (repeat (/ (length lp) 3) (setq al (cons (nth n lp) al) al (cons (polar cp (+ a (angle cp (nth (+ n 1) lp))) (distance cp (nth (+ n 1) lp))) al) al (cons (polar cp (+ a (angle cp (nth (+ n 2) lp))) (distance cp (nth (+ n 2) lp))) al)) (setq n (+ n 3)) ) (and al (grvecs (reverse al))) (setq xp (list (+ (car xp) (* z 1.5)) (cadr xp)) i (1+ i)) ) (prin1) ) ;;; probably won't need tracking mode (cut-copy-paste you know...) (defun RlxGrMenu_Get_Cell_ID (xl yl / inp dev tpt prev-tpt mark-current-tracking-point cell-id prev-cell-id prev-view-size cur-view-size rtn) (princ "\rEsc/Q/Rmouse to cancel, zoom with E(extend), Z(oom) or + / -") (setq prev-view-size (getvar "viewsize")) (while gr-loop (setq cur-view-size (getvar "viewsize")) (setq inp (vl-catch-all-apply 'grread (list T 8 1))) (if (vl-catch-all-error-p inp) (progn (setq gr-loop nil inp nil)(redraw)) (progn (setq dev (car inp) tpt (cadr inp)) (cond ;;; space , q or Q (Quit) ((and (= dev 2) (member (last inp) '(32 113 81))) (redraw)(setq gr-loop nil) ) ;;; point selection (3 (221.882 173.853 0.0)) ((= dev 3) (if (setq rtn (find_cell tpt xl yl)) (progn ;(alert (setq app (nth (1- (atoi rtn)) app-list))) (princ (strcat "\nLaunching : " (setq app (nth (1- (atoi rtn)) app-list)))) (setq gr-loop nil) ) ) ) ;;; device tracking point (probably don't need tracking mode) ((= dev 5) ;;; if mouse moved (if (or (/= (car prev-tpt)(car tpt)) (/= (cadr prev-tpt)(cadr tpt))) (progn (setq prev-tpt tpt ))) (if (not (equal cur-view-size prev-view-size)) (progn (setq prev-view-size cur-view-size) (redraw_menu) ) ) ) ; user pressed E of e ((member inp '((2 69)(2 101))) (command "zoom" "e")) ; user clicked R-mouse button, pressed enter or space (done selecting) ((or (equal (car inp) 25)(member inp '((2 13)(2 32)))) (redraw)(setq gr-loop nil app "Quit")) ; user pressed + ((equal inp '(2 43)) (vl-cmdf "zoom" "2x")) ; user pressed - ((equal inp '(2 45)) (vl-cmdf "zoom" ".5x")) ; user pressed z or Z ((member inp '((2 122)(2 90))) (vl-cmdf "'zoom" "")) ) ) ) ) (princ) ) ;;; pt = point , xl = x-list , yl = y-list ;;; scribble : (< 1 2 3) , (> 3 2 1) , (cdr (vl-sort '(1 2 3 4 5) '>)) -> '(4 3 2 1) (defun find_cell ( pt xl yl / ptx pty y-lst l n hit) (setq n nil hit nil ptx (car pt) pty (cadr pt) y-list (vl-sort (append yl (list 0)) '>)) (if (< (car xl) ptx (cadr xl)) (mapcar '(lambda (y)(if (and (not hit) (> pty y)) (setq hit T n (vl-position y y-list)))) y-list)) (if n (itoa (1+ n))) ) ;;; program assumes no self starting routines and start command is "C:" + app name (defun RlxGrMenu_Start_App (app / fn) (cond ((setq fn (findfile (strcat app ".lsp"))) (redraw)(load fn)(eval (read (strcat "(C:" app ")")))) ((wcmatch (strcase app) "QUIT")(princ "\nBye bye")(redraw)) ((wcmatch (strcase app) "CONFIG")(princ "\nUnder construction")(redraw)) (t (redraw)(princ (strcat "\nUnable to load " (vl-princ-to-string app) " ...bye"))) ) (princ) ) ;;; future... ;;; RlxGrMenu - Rlx Jul/25 (defun RlxGrMenu_future ( / ;;; global variables scr-res cell-rows cell-cols cell-col cell-id app-list ;;; display parameters like viewctr/viewsize/screensize (count_calcula) vc vs ss dx dy x- x+ y- y+ ip vc-x vc-y txt-h ;;; registry variables RlxGrMenu-nof-cell-rows RlxGrMenu-nof-cell-cols RlxGrMenu-app-list ) ;;; mostly not used because for now I just just one column with 10 rows (setq scr-res (screen_res) rows 3 cols 3 cell-col 141 cell-id 1) (count_calcula) (setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare")) (RlxGrMenu_Init) (RlxGrMenu_Doit) (RlxGrMenu_Exit) (princ) ) (defun RlxGrMenu_Init ()(princ "\nUnder construction - RlxGrMenu_Init ")) (defun RlxGrMenu_Doit ()(princ "\nUnder construction - RlxGrMenu_Doit ")) (defun RlxGrMenu_Exit ()(princ "\nUnder construction - RlxGrMenu_Exit ")) (defun c:RlxGrMenu ()(draw_menu)) (defun c:t1 ()(draw_menu)) (defun t1 ()(draw_menu))

The following offers another method using a temporary saved view - the advantage being that the user can adjust the view plane in addition to zooming & panning: (defun c:test ( / *error* doc idx obj vpo vwc vwn ) (defun *error* ( msg ) (if (and (= 'vla-object (type obj)) (vlax-write-enabled-p obj)) (vla-delete obj) ) (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))) (princ (strcat "\nError: " msg)) ) (princ) ) (setq doc (vla-get-activedocument (vlax-get-acad-object)) vwc (vla-get-views doc) idx 0 ) (while (itemp vwc (setq vwn (strcat "$temp" (itoa (setq idx (1+ idx))))))) (setq obj (vla-add vwc vwn) vpo (vla-get-activeviewport doc) ) (foreach prp '(center direction height target width) (vlax-put-property obj prp (vlax-get-property vpo prp)) ) (getpoint "\nPan & zoom around...") (vla-setview vpo obj) (vla-put-activeviewport doc vpo) (*error* nil) (princ) ) (defun itemp ( col key ) (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list col key)))) ) (vl-load-com) (princ)

The upgrade has now completed successfully, and we are now running the most recent version of Invision Community. The most obvious change is that the Rank system, which has been a part of this forum for many years, is replaced with a new system called Achievements. The new system is much more flexible. Ranks were based purely on the number of posts that members made. Achievements are based on the number of points acrued. Points are awarded for lots of different things, not just content posting. For example, points are earned for having followers, getting positive reactions etc. In addition to the ranks awarded through achievements, members can also earn badges for passing significant milestones and for excellent work. All of this means that your profile looks a little different than it did before. There are also some changes under the hood, but those shouldn't make any significant difference to your experience. As usual, if you spot anything that doesn't look right, post in this thread to let me know.