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!

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!

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

@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

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) )

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

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

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 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

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

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)) ; )

(vl-load-com) (defun c:wrap ( / acdoc *error* oldcmdecho ss0 ssl0 index ent bb ss ssl ptlist elist pt1 ptlist chlist chent textflag obj box lll url ) (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))) (setq oldcmdecho (getvar 'cmdecho)) (defun *error* ( msg ) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (vla-EndUndoMark acdoc) (setvar 'cmdecho oldcmdecho) (princ) ) (defun LWPolybylist (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) ) ) ) (vla-StartUndoMark acdoc) (setvar 'cmdecho 0) (setq ss0 (ssget)) (setq ssl0 (sslength ss0)) (setq index 0) (setq textflag 0) (setq ptlist '()) (repeat ssl0 (setq ent (ssname ss0 index)) (setq elist (entget ent)) (if (or (eq (cdr (assoc 0 elist)) "TEXT") (eq (cdr (assoc 0 elist)) "MTEXT") (eq (cdr (assoc 0 elist)) "INSERT")) (progn (setq textflag 1) (setq obj (vlax-ename->vla-object ent)) (setq box (vla-getboundingbox obj 'll 'ur)) (setq lll (vlax-safearray->list ll)) ; lower left point (setq url (vlax-safearray->list ur)) ; upper right point (setq ent (LWPolybylist (list lll (list (car url) (cadr lll)) url (list (car lll) (cadr url))) 1)) ) (progn ) ) (setq ptlist (append (LM:ent->pts ent 100) ptlist)) ;(command "_.DIVIDE" ent 100 "") (if (= textflag 1) (entdel ent) ) (setq textflag 0) (setq index (+ index 1)) ) (setvar 'cmdecho oldcmdecho) (setq bb (LM:ssboundingbox ss0)) ;(if (setq ss (ssget "_C" (car bb) (cadr bb) '((0 . "POINT")))) ; (progn ; (setq ssl (sslength ss)) ; (setq index 0) ; (repeat ssl ; (setq ent (ssname ss index)) ; (setq elist (entget ent)) ; (setq pt1 (cdr (assoc 10 elist))) ; (setq ptlist (cons pt1 ptlist)) ; (entdel ent) ; (setq index (+ index 1)) ; ) ; ) ;) ;(princ ptlist) (setq chlist (LM:ConvexHull ptlist)) (setq chent (entmakex (append (list '(000 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length chlist)) '(070 . 1) ) (mapcar '(lambda ( x ) (cons 10 x)) chlist) ) ) ) (vla-EndUndoMark acdoc) (princ) ) ;; Convex Hull - Lee Mac ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points. (defun LM:ConvexHull ( lst / ch p0 ) (cond ( (< (length lst) 4) lst) ( (setq p0 (car lst)) (foreach p1 (cdr lst) (if (or (< (cadr p1) (cadr p0)) (and (equal (cadr p1) (cadr p0) 1e-8) (< (car p1) (car p0))) ) (setq p0 p1) ) ) (setq lst (vl-sort lst (function (lambda ( a b / c d ) (if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (< (distance p0 a) (distance p0 b)) (< c d) ) ) ) ) ) (setq ch (list (caddr lst) (cadr lst) (car lst))) (foreach pt (cdddr lst) (setq ch (cons pt ch)) (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt)) (setq ch (cons pt (cddr ch))) ) ) ch ) ) ) ;; Clockwise-p - Lee Mac ;; Returns T if p1,p2,p3 are clockwise oriented or collinear (defun LM:Clockwise-p ( p1 p2 p3 ) (< (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1))) (* (- (cadr p2) (cadr p1)) (- (car p3) (car p1))) ) 1e-8 ) ) ;; Selection Set Bounding Box - Lee Mac ;; Returns a list of the lower-left and upper-right WCS coordinates of a ;; rectangular frame bounding all objects in a supplied selection set. ;; sel - [sel] Selection set for which to return bounding box (defun LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp ) (repeat (setq idx (sslength sel)) (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))) (if (and (vlax-method-applicable-p obj 'getboundingbox) (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp)))) ) (setq ls1 (cons (vlax-safearray->list llp) ls1) ls2 (cons (vlax-safearray->list urp) ls2) ) ) ) (if (and ls1 ls2) (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2)) ) ) ;; Entity to Point List - Lee Mac ;; Returns a list of WCS points describing or approximating the supplied entity, else nil if the entity is not supported. ;; ent - [ent] Entity name to be described by point list (POINT/LINE/ARC/CIRCLE/LWPOLYLINE/POLYLINE/ELLIPSE/SPLINE) ;; acc - [num] Positive number determining the point density for non-linear objects (defun LM:ent->pts (ent acc / ang bul cen cls di1 di2 enx inc itm lst num ocs rad tot typ vt1 vt2 vtl ) (setq enx (entget ent) typ (cdr (assoc 0 enx)) ) (cond ((= "POINT" typ) (list (cdr (assoc 10 enx))) ) ((= "LINE" typ) (mapcar '(lambda (x) (cdr (assoc x enx))) '(10 11)) ) ((or (= "ARC" typ) (= "CIRCLE" typ)) (if (= "ARC" typ) (setq ang (cdr (assoc 50 enx)) tot (rem (+ pi pi (- (cdr (assoc 51 enx)) ang)) (+ pi pi)) num (fix (+ 1.0 1e-8 (* acc (/ tot (+ pi pi))))) inc (/ tot (float num)) num (1+ num) ) (setq ang 0.0 tot (+ pi pi) num (fix (+ 1e-8 acc)) inc (/ tot (float num)) ) ) (setq cen (cdr (assoc 010 enx)) rad (cdr (assoc 040 enx)) ocs (cdr (assoc 210 enx)) ) (repeat num (setq lst (cons (trans (polar cen ang rad) ocs 0) lst) ang (+ ang inc) ) ) (reverse lst) ) ((or (= "LWPOLYLINE" typ) (and (= "POLYLINE" typ) (zerop (logand (logior 16 64) (cdr (assoc 70 enx)))) ) ) (if (= "LWPOLYLINE" typ) (setq vtl (LM:ent->pts:lwpolyvertices enx)) (setq vtl (LM:ent->pts:polyvertices ent)) ) (if (setq ocs (cdr (assoc 210 enx)) cls (= 1 (logand 1 (cdr (assoc 70 enx)))) ) (setq vtl (append vtl (list (cons (caar vtl) 0.0)))) ) (while (setq itm (car vtl)) (setq vtl (cdr vtl) vt1 (car itm) bul (cdr itm) lst (cons (trans vt1 ocs 0) lst) ) (if (and (not (equal 0.0 bul 1e-8)) (setq vt2 (caar vtl))) (progn (setq rad (/ (* (distance vt1 vt2) (1+ (* bul bul))) 4.0 bul) cen (polar vt1 (+ (angle vt1 vt2) (- (/ pi 2.0) (* 2.0 (atan bul)))) rad ) rad (abs rad) tot (* 4.0 (atan bul)) num (fix (+ 1.0 1e-8 (* acc (/ (abs tot) (+ pi pi))))) inc (/ tot (float num)) ang (+ (angle cen vt1) inc) ) (repeat (1- num) (setq lst (cons (trans (polar cen ang rad) ocs 0) lst) ang (+ ang inc) ) ) ) ) ) (reverse (if cls (cdr lst) lst)) ) ((= "ELLIPSE" typ) (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent)) di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) di2 (- di2 1e-8) ) (while (< di1 di2) (setq lst (cons (vlax-curve-getpointatdist ent di1) lst) rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent (vlax-curve-getparamatdist ent di1 ) ) ) di1 (+ di1 (/ di2 (1+ (fix (* acc (/ di2 rad (+ pi pi))))))) ) ) (reverse (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst)) ) ) ((= "SPLINE" typ) (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent)) di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) lst (list (vlax-curve-getstartpoint ent)) inc (/ (- di2 di1) (float acc)) di1 (+ di1 inc) ) (repeat (1- (fix (+ 1e-8 acc))) (setq lst (cons (vlax-curve-getpointatdist ent di1) lst) di1 (+ di1 inc) ) ) (reverse (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst)) ) ) ) ) (defun LM:ent->pts:lwpolyvertices (enx / elv lst vtx) (setq elv (list (cdr (assoc 38 enx)))) (while (setq vtx (assoc 10 enx)) (setq enx (cdr (member vtx enx)) lst (cons (cons (append (cdr vtx) elv) (cdr (assoc 42 enx))) lst) ) ) (reverse lst) ) (defun LM:ent->pts:polyvertices (ent / lst vte vtx) (setq vte (entnext ent) vtx (entget vte) ) (while (= "VERTEX" (cdr (assoc 0 vtx))) (setq lst (cons (cons (cdr (assoc 10 vtx)) (cdr (assoc 42 vtx))) lst) vte (entnext vte) vtx (entget vte) ) ) (reverse lst) ) this routine wraps edges together rather than connecting right angle extension lines, so it may not suit your purpose..... so this is just for reference. I personally used this when I wanted to combine separate areas while using UNION for REVCLOUD command.

Thanx for reminding me again to this program Bigal but I can't install anything on work computer. PC (laptop) is scanned continuously, it sounds like a vacuum cleaner because of all the scanning going on. AutoCad (cloud based) crashes a few times a day , I suspect due to this scanning because most cpu time is used up by this process. I only find comfort in the fact all my colleagues suffer with me haha

I've created a tool to assist me with a mammoth job I'm working on right now. I have to dig through an enormous amount of folders and data to catalog everything and search for lost and relevant data , in all sorts of format , dwg , doc , excell etc. Purpose of app I gave birth to this time is to present data in whatever form that's best for daddy (or mommy? ... nah dragons don't have this problem) Anyways , I'm on a quota so have to deliver certain amount of data in a certain amount of time and have to put in spare time when behind schedule so no time to explain everything so I hope interface explains itself. Also can't say for certain I've killed all bugs because ink is still wet. So short version : start app , type h for help , s for setup in Main dialog. In setup dialog you can create some test drawings or variables. Files can be represented as button , image_button , edit_box, list_box or toggle. App can also work in data mode. In main dialog you select folder (with drawings or doc's etc) , next extention (dwg, doc, xls ext) , action type (insert , open ...) and dcl type (button, edit_box etc) and ok. New dialog is created : Run dialog. here you can also type h for help. You can type r to rotate dialog , 4 = smaller , 6 is wider , 8 = higher , 2 = less higher and if dcl type is image_tile you can also use + & - keys to resize slides. Oh , thinks save button doesn't work yet. What else to tell... well , haven't done enough testing probably , and time will tell if this is gonna help me to achieve my goals or if its just another useless stupid program. I don't expect I will have much time for chitchat so have fun or trashcan... RlxIndexer.lsp

Consider something like the following: (while (not (or (= "" (setq nodwg (getstring "\nEnter the number <exit>: "))) (wcmatch nodwg "###") ) ) (princ "\nNumber must be in the range 001-999.") ) (if (/= "" nodwg) (progn ;; do stuff ) )

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.

@rlx made this useful lisp to convert stand alone dcl files into lisp. so things have the proper " " and slashes. -Edit

That is a little more involved. (defun C:FOO (/ SS layers lay x lst SS1) (setq SS (ssadd)) ;emty selecton set to add entity's to (setq layers (Table "layer")) (foreach lay layers (setq x (entget (tblobjname "layer" lay))) (if (eq (cdr (assoc 62 x)) 7) (setq lst (cons lay lst)) ;add each layer that has color white to a new list ) ) (foreach lay lst (if (setq SS1 (ssget "_X" (list '(0 . "*POLYLINE") (cons 8 lay) '(62 . 256) (cons 410 (getvar 'ctab))))) ;process that 2nd list of layers to see if any (setq SS (acet-ss-union (list SS SS1))) ;polylines are bylayer and add them to ss ) (setq SS1 nil) ; reset so things arn't added twice ) (if (setq SS1 (ssget "_X" (list '(0 . "LWPOLYLINE") '(62 . 7) (cons 410 (getvar 'ctab))))) ;alos find any polylines that are white (setq SS (acet-ss-union (list SS SS1))) ;and add them to SS ) (sssetfirst nil SS) ) ;Written By Michael Puckett (defun Table (s / d r) (while (setq d (tblnext s (null d))) (setq r (cons (cdr (assoc 2 d)) r)) ) )

Since the string to be found is already being passed an argument to your function, you can 'hardcode' it by simply defining another function which evaluates your function with a hardcoded string, e.g.: (defun c:test ( ) (chkmtxtstr "MyTextString") ) Though, if you're happy with a case-sensitive match and assuming the MText content has no formatting and does not straddle multiple DXF group 3 entries, the code can become much simpler - consider the following: (defun find ( str ) (ssget "_X" (list '(0 . "MTEXT") (cons 1 (strcat "*" str "*")))) ) Since the above will return a selection set, you can call it in the following way: (defun c:test ( / sel ) (if (setq sel (find "YourString")) (command "_.change" sel "" "_p" "_la" "0" "_c" "ByLayer" "") ) (princ) )

updated the lisp with the following - entmake for point and text (faster) - got rid of nth its slower then then car cadr caddr last - updated while to combined lines of code Also I don't think the easting and northing are in the right order but left it like the lisp had it. so if your points are in the wrong spot maybe update to below (setq POINT (list (cadr POINT_LINE) ;Get x (caddr POINT_LINE) ;Get y (last POINT_LINE) ;Get z ) ) ; POINTPLT is a simple AutoLSIP program that will plot a coordinate points file ; in AutoCAD. To run POINTPLT, load POINTPLT.LSP as you would any normal ; AutoLISP file (see AutoCAD Reference Manual), type "POINTPLT" and press ; [Enter]. POINTPLT will first prompt you for an input coordinate filename. ; You must enter a vaild DOS filename at this point. The input coordinate file ; must be in the following format: ; ; POINT NO. NORTHING(y) EASTING(x) ELEVATION(z) ; ; A sample input coordinate file (SAMPLE.DAT) is included with POINTPLT. ; ; POINTPLT uses the default (current) text style and layer. However, the ; current text style must have a defined height (height must not be "0"). ; ; If you have any questions or comments concerning POINTS, I may be reached ; via THE SPECTRUM BBS þ (501) 521-5639 ; ;------------------------------------------------------------------------------- ; * ERROR Trapping * ; (defun *ERROR* () (eop) ) ;------------------------------------------------------------------------------- ; * End of program * ; (defun EOP () (setvar "CMDECHO" POINTSPLT_CE) (princ) ) ;------------------------------------------------------------------------------- ; * Main Program * (defun C:POINTPLT (/ IN_FILE POINT_LINE POINT_NO POINT) (setq POINTSPLT_CE (getvar "CMDECHO")) (setvar "CMDECHO" 0) ;Turn "Command Echo" off (prompt "\n\nP O I N T P L T v1.0 -- Copyright (c) 1992 by Kurtis J. Jones / -Mate Software\n\n") (setq IN_FILE (open (getfiled "\nEnter points filename: " (getvar 'DWGPREFIX) "txt" 16) "r")) (while (setq POINT_LINE (read (strcat "(" (read-line IN_FILE) ")"))) ;Read POINT_LINE from input file (setq POINT_NO (car POINT_LINE)) ;Get the point number (prompt (strcat "\nPlotting point no. " (itoa POINT_NO))) (setq POINT (list (caddr POINT_LINE) ;Get easting (cadr POINT_LINE) ;Get northing (last POINT_LINE) ;Get elevation ) ) (entmake (list '(0 . "POINT") (cons 10 POINT))) (entmake (list '(0 . "TEXT") (cons 10 POINT) '(40 . 1) (cons 1 (itoa POINT_NO)))) ) (close IN_FILE) (prompt "\nPOINTPLT finished") (prompt "\n ") (eop) )

You can create as many layer states as you need. If you have two viewports in your layout, you can create a layer state for each one to display different layers in each viewport. But, if you go into model space and start freezing layers, as tombu mentioned, that will affect your viewport display when you go back to your layout and those layers that you froze in model space will no longer be visible in your viewports. I believe this is the problem you are describing. Once you create your layer states, it's best to leave model space alone. Just work inside your viewports.

Try this ... does not check for locked layers. (defun c:foo (/ a i o s) (if (setq s (ssget "_X" '((0 . "TEXT") (1 . "* .#,* .##,* .###")))) (foreach e (mapcar 'cadr (ssnamex s)) (setq a (vla-get-textstring (setq o (vlax-ename->vla-object e)))) (setq i (vl-string-position 32 a 0 t)) (vla-put-textstring o (substr a 1 i)) ) ) (princ) )

OK So it you might have made something like this if you got it to work: (defun c:testthis ( / spt1 spt2 roomname a b c d scpt1 mywidth myheight) ;; after the '/' are local variable names (setq ;;setq: Tells LISP you are setting a variable spt1 (getpoint "\nPick the first point") ;;should be obvious what this does spt3 (getcorner "\nPick the next corner" spt1) ;;should be obvious what this does roomname (getstring "\nEnter Room Name: " T) ;;T allows spaces, else space acts as a return a (if (< (car spt1)(car spt3))(car spt1)(car spt3)) ;;Lower Left X coord car gives first item in a list, here x coord b (if (> (car spt1)(car spt3))(car spt1)(car spt3)) ;;Upper Right X coord c (if (< (cadr spt1)(cadr spt3))(cadr spt1)(cadr spt3)) ;;Lower Left y Coord cadr gives second item in a list, here y coord d (if (> (cadr spt1)(cadr spt3))(cadr spt1)(cadr spt3)) ;;Upper Right Y Coord ) (setq mywidth (abs (- a b))) ;;abs for absolute value (witohut = or -), (- is subtract (setq myheight (abs (- c d))) ;;center points (setq scpt1 (list (/ (+ a b) 2) (/ (+ c d) 2)) ) ;;create a coordinate which is a list (/ for divide (+ for add (command "mtext" scpt1 "J" "MC" scpt1 (strcat roomname "\n" (rtos mywidth 2 2) " x " (rtos myheight 2 2 )) "") ;;Command echos what you'd type in command line, anything in "" is a fixed value in else it is calculated ) Put a few notes in if you want to learn how it does what it does

; 2048 game by autolisp - 2022.05.02 exceed ; https://www.cadtutor.net/forum/topic/75110-2048-by-autolisp/ ; command : ; - 2048 (graphic mode) ; - 2048t (command prompt text only mode) ; key : W = up, A = left, S = down, D = right, P = end game ; key2 : 8 = up, 4 = left, 5 = down, 6 = right (for numpad with numlock on), P = end game ; this lisp use your dwg's 15 x 8 space. so you have to run this in new drawing not working dwg. (vl-load-com) (defun c:2048t ( / playlist start newnum *error* graphicmode starttime timer score ) (setvar 'cmdecho 0) (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)) ) (setvar 'cmdecho 1) (princ) ) (setq timer 0) (setq starttime (getvar "date")) (setq score 0) (setq playlist (list (list 0 0 0 0) (list 0 0 0 0) (list 0 0 0 0) (list 0 0 0 0) )) (setq graphicmode 0) (output2048txt playlist) (setq start (getstring "\n 2048 Start (SpaceBar - Yes / N - No)")) (if (= (strcase start) "N") (exit) ) (play playlist basept) (LM:endundo (LM:acdoc)) (setvar 'cmdecho 1) (princ) ) (defun c:2048 ( / playlist start newnum *error* graphicmode starttime timer score) (setvar 'cmdecho 0) (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)) ) (setvar 'cmdecho 1) (princ) ) (setq timer 0) (setq starttime (getvar "date")) (setq score 0) (setq basept (getpoint "\n pick point for 2048 ")) (setq playlist (list (list 0 0 0 0) (list 0 0 0 0) (list 0 0 0 0) (list 0 0 0 0) )) (setq graphicmode 1) (output2048 playlist basept) (output2048txt playlist) (setq baseptx (car basept)) (setq basepty (cadr basept)) (setq zoompt (list (+ baseptx 15) (+ basepty 8))) (command "_.zoom" "w" basept zoompt) (setq start (getstring "\n 2048 Start (SpaceBar - Yes / N - No)")) (if (= (strcase start) "N") (exit) ) (play playlist basept) (LM:endundo (LM:acdoc)) (setvar 'cmdecho 1) (princ) ) (defun play ( playlist basept / movement input newplaylist rowlen indexr row collen indexc nonezerolist cell calcindex a b c d nonezerolist2 nowtime ) (setq playlist (makenewnum playlist)) (if (= graphicmode 1) (output2048 playlist basept) ) (output2048txt playlist) (setq input (grread2048)) (cond ((= input "W") (setq playlist (list (list (nth 3 (nth 0 playlist)) (nth 3 (nth 1 playlist)) (nth 3 (nth 2 playlist)) (nth 3 (nth 3 playlist))) (list (nth 2 (nth 0 playlist)) (nth 2 (nth 1 playlist)) (nth 2 (nth 2 playlist)) (nth 2 (nth 3 playlist))) (list (nth 1 (nth 0 playlist)) (nth 1 (nth 1 playlist)) (nth 1 (nth 2 playlist)) (nth 1 (nth 3 playlist))) (list (nth 0 (nth 0 playlist)) (nth 0 (nth 1 playlist)) (nth 0 (nth 2 playlist)) (nth 0 (nth 3 playlist))))) (setq newplaylist '()) (setq rowlen (length playlist)) (setq indexr 0) (repeat rowlen (setq row (nth indexr playlist)) (setq collen (length row)) (setq indexc 0) (setq nonezerolist '()) (repeat collen (setq cell (nth indexc row)) (if (/= cell 0) (setq nonezerolist (cons cell nonezerolist)) ) (setq indexc (+ indexc 1)) ) (repeat (- collen (length nonezerolist)) (setq nonezerolist (cons 0 nonezerolist)) ) (setq calcindex 0) (setq nonezerolist (reverse nonezerolist)) (setq a (nth 0 nonezerolist)) (setq b (nth 1 nonezerolist)) (setq c (nth 2 nonezerolist)) (setq d (nth 3 nonezerolist)) (if (and (= a b) (/= a 0) (/= b 0)) (progn (setq a (+ a b)) (setq b c) (setq c d) (setq d 0) (if (and (= b c) (/= b 0) (/= c 0)) (progn (setq b (+ b c)) (setq c 0) );end of progn );end of if );end of progn (progn (if (and (= b c) (/= b 0) (/= c 0)) (progn (setq a a) (setq b (+ b c)) (setq c d) (setq d 0) ) (progn (if (and (= c d) (/= c 0) (/= d 0)) (progn (setq c (+ c d)) (setq d 0) ) ) );end of progn );end of if );end of progn );end of if (setq nonezerolist (list a b c d)) (setq nonezerolist2 '()) (setq indexc 0) (repeat collen (setq cell (nth indexc nonezerolist)) (if (/= cell 0) (setq nonezerolist2 (cons cell nonezerolist2)) ) (setq indexc (+ indexc 1)) ) (repeat (- collen (length nonezerolist2)) (setq nonezerolist2 (cons 0 nonezerolist2)) ) (setq newplaylist (cons (reverse nonezerolist2) newplaylist)) (setq indexr (+ indexr 1)) );end of repeat (setq playlist (reverse newplaylist)) (setq playlist (list (list (nth 0 (nth 3 playlist)) (nth 0 (nth 2 playlist)) (nth 0 (nth 1 playlist)) (nth 0 (nth 0 playlist))) (list (nth 1 (nth 3 playlist)) (nth 1 (nth 2 playlist)) (nth 1 (nth 1 playlist)) (nth 1 (nth 0 playlist))) (list (nth 2 (nth 3 playlist)) (nth 2 (nth 2 playlist)) (nth 2 (nth 1 playlist)) (nth 2 (nth 0 playlist))) (list (nth 3 (nth 3 playlist)) (nth 3 (nth 2 playlist)) (nth 3 (nth 1 playlist)) (nth 3 (nth 0 playlist))))) ;(princ "\n input W") (setq nowtime (getvar "date")) (setq timer (* (- nowtime starttime) 86400.0)) (princ "\n timer - ") (princ timer) (princ " / score - ") (princ score) (play playlist basept) ) ((= input "A") ;(princ "\n input A") (setq newplaylist '()) (setq rowlen (length playlist)) (setq indexr 0) (repeat rowlen (setq row (nth indexr playlist)) (setq collen (length row)) (setq indexc 0) (setq nonezerolist '()) (repeat collen (setq cell (nth indexc row)) (if (/= cell 0) (setq nonezerolist (cons cell nonezerolist)) ) (setq indexc (+ indexc 1)) ) (repeat (- collen (length nonezerolist)) (setq nonezerolist (cons 0 nonezerolist)) ) (setq calcindex 0) (setq nonezerolist (reverse nonezerolist)) (setq a (nth 0 nonezerolist)) (setq b (nth 1 nonezerolist)) (setq c (nth 2 nonezerolist)) (setq d (nth 3 nonezerolist)) (if (and (= a b) (/= a 0) (/= b 0)) (progn (setq a (+ a b)) (setq b c) (setq c d) (setq d 0) (if (and (= b c) (/= b 0) (/= c 0)) (progn (setq b (+ b c)) (setq c 0) );end of progn );end of if );end of progn (progn (if (and (= b c) (/= b 0) (/= c 0)) (progn (setq a a) (setq b (+ b c)) (setq c d) (setq d 0) ) (progn (if (and (= c d) (/= c 0) (/= d 0)) (progn (setq c (+ c d)) (setq d 0) ) ) );end of progn );end of if );end of progn );end of if (setq nonezerolist (list a b c d)) (setq nonezerolist2 '()) (setq indexc 0) (repeat collen (setq cell (nth indexc nonezerolist)) (if (/= cell 0) (setq nonezerolist2 (cons cell nonezerolist2)) ) (setq indexc (+ indexc 1)) ) (repeat (- collen (length nonezerolist2)) (setq nonezerolist2 (cons 0 nonezerolist2)) ) (setq newplaylist (cons (reverse nonezerolist2) newplaylist)) (setq indexr (+ indexr 1)) );end of repeat (setq playlist (reverse newplaylist)) (setq nowtime (getvar "date")) (setq timer (* (- nowtime starttime) 86400.0)) (princ "\n timer - ") (princ timer) (princ " / score - ") (princ score) (play playlist basept) ) ((= input "S") ;(princ "\n input S") (setq playlist (list (list (nth 0 (nth 3 playlist)) (nth 0 (nth 2 playlist)) (nth 0 (nth 1 playlist)) (nth 0 (nth 0 playlist))) (list (nth 1 (nth 3 playlist)) (nth 1 (nth 2 playlist)) (nth 1 (nth 1 playlist)) (nth 1 (nth 0 playlist))) (list (nth 2 (nth 3 playlist)) (nth 2 (nth 2 playlist)) (nth 2 (nth 1 playlist)) (nth 2 (nth 0 playlist))) (list (nth 3 (nth 3 playlist)) (nth 3 (nth 2 playlist)) (nth 3 (nth 1 playlist)) (nth 3 (nth 0 playlist))))) (setq newplaylist '()) (setq rowlen (length playlist)) (setq indexr 0) (repeat rowlen (setq row (nth indexr playlist)) (setq collen (length row)) (setq indexc 0) (setq nonezerolist '()) (repeat collen (setq cell (nth indexc row)) (if (/= cell 0) (setq nonezerolist (cons cell nonezerolist)) ) (setq indexc (+ indexc 1)) ) (repeat (- collen (length nonezerolist)) (setq nonezerolist (cons 0 nonezerolist)) ) (setq calcindex 0) (setq nonezerolist (reverse nonezerolist)) (setq a (nth 0 nonezerolist)) (setq b (nth 1 nonezerolist)) (setq c (nth 2 nonezerolist)) (setq d (nth 3 nonezerolist)) (if (and (= a b) (/= a 0) (/= b 0)) (progn (setq a (+ a b)) (setq b c) (setq c d) (setq d 0) (if (and (= b c) (/= b 0) (/= c 0)) (progn (setq b (+ b c)) (setq c 0) );end of progn );end of if );end of progn (progn (if (and (= b c) (/= b 0) (/= c 0)) (progn (setq a a) (setq b (+ b c)) (setq c d) (setq d 0) ) (progn (if (and (= c d) (/= c 0) (/= d 0)) (progn (setq c (+ c d)) (setq d 0) ) ) );end of progn );end of if );end of progn );end of if (setq nonezerolist (list a b c d)) (setq nonezerolist2 '()) (setq indexc 0) (repeat collen (setq cell (nth indexc nonezerolist)) (if (/= cell 0) (setq nonezerolist2 (cons cell nonezerolist2)) ) (setq indexc (+ indexc 1)) ) (repeat (- collen (length nonezerolist2)) (setq nonezerolist2 (cons 0 nonezerolist2)) ) (setq newplaylist (cons (reverse nonezerolist2) newplaylist)) (setq indexr (+ indexr 1)) );end of repeat (setq playlist (reverse newplaylist)) (setq playlist (list (list (nth 3 (nth 0 playlist)) (nth 3 (nth 1 playlist)) (nth 3 (nth 2 playlist)) (nth 3 (nth 3 playlist))) (list (nth 2 (nth 0 playlist)) (nth 2 (nth 1 playlist)) (nth 2 (nth 2 playlist)) (nth 2 (nth 3 playlist))) (list (nth 1 (nth 0 playlist)) (nth 1 (nth 1 playlist)) (nth 1 (nth 2 playlist)) (nth 1 (nth 3 playlist))) (list (nth 0 (nth 0 playlist)) (nth 0 (nth 1 playlist)) (nth 0 (nth 2 playlist)) (nth 0 (nth 3 playlist))))) (setq nowtime (getvar "date")) (setq timer (* (- nowtime starttime) 86400.0)) (princ "\n timer - ") (princ timer) (princ " / score - ") (princ score) (play playlist basept) ) ((= input "D") ;(princ "\n input D") (setq playlist (list (list (nth 3 (nth 0 playlist)) (nth 2 (nth 0 playlist)) (nth 1 (nth 0 playlist)) (nth 0 (nth 0 playlist))) (list (nth 3 (nth 1 playlist)) (nth 2 (nth 1 playlist)) (nth 1 (nth 1 playlist)) (nth 0 (nth 1 playlist))) (list (nth 3 (nth 2 playlist)) (nth 2 (nth 2 playlist)) (nth 1 (nth 2 playlist)) (nth 0 (nth 2 playlist))) (list (nth 3 (nth 3 playlist)) (nth 2 (nth 3 playlist)) (nth 1 (nth 3 playlist)) (nth 0 (nth 3 playlist))))) (setq newplaylist '()) (setq rowlen (length playlist)) (setq indexr 0) (repeat rowlen (setq row (nth indexr playlist)) (setq collen (length row)) (setq indexc 0) (setq nonezerolist '()) (repeat collen (setq cell (nth indexc row)) (if (/= cell 0) (setq nonezerolist (cons cell nonezerolist)) ) (setq indexc (+ indexc 1)) ) (repeat (- collen (length nonezerolist)) (setq nonezerolist (cons 0 nonezerolist)) ) (setq calcindex 0) (setq nonezerolist (reverse nonezerolist)) (setq a (nth 0 nonezerolist)) (setq b (nth 1 nonezerolist)) (setq c (nth 2 nonezerolist)) (setq d (nth 3 nonezerolist)) (if (and (= a b) (/= a 0) (/= b 0)) (progn (setq a (+ a b)) (setq b c) (setq c d) (setq d 0) (if (and (= b c) (/= b 0) (/= c 0)) (progn (setq b (+ b c)) (setq c 0) );end of progn );end of if );end of progn (progn (if (and (= b c) (/= b 0) (/= c 0)) (progn (setq a a) (setq b (+ b c)) (setq c d) (setq d 0) ) (progn (if (and (= c d) (/= c 0) (/= d 0)) (progn (setq c (+ c d)) (setq d 0) ) ) );end of progn );end of if );end of progn );end of if (setq nonezerolist (list a b c d)) (setq nonezerolist2 '()) (setq indexc 0) (repeat collen (setq cell (nth indexc nonezerolist)) (if (/= cell 0) (setq nonezerolist2 (cons cell nonezerolist2)) ) (setq indexc (+ indexc 1)) ) (repeat (- collen (length nonezerolist2)) (setq nonezerolist2 (cons 0 nonezerolist2)) ) (setq newplaylist (cons (reverse nonezerolist2) newplaylist)) (setq indexr (+ indexr 1)) );end of repeat (setq playlist (reverse newplaylist)) (setq nowtime (getvar "date")) (setq timer (* (- nowtime starttime) 86400.0)) (princ "\n timer - ") (princ timer) (princ " / score - ") (princ score) (setq playlist (list (list (nth 3 (nth 0 playlist)) (nth 2 (nth 0 playlist)) (nth 1 (nth 0 playlist)) (nth 0 (nth 0 playlist))) (list (nth 3 (nth 1 playlist)) (nth 2 (nth 1 playlist)) (nth 1 (nth 1 playlist)) (nth 0 (nth 1 playlist))) (list (nth 3 (nth 2 playlist)) (nth 2 (nth 2 playlist)) (nth 1 (nth 2 playlist)) (nth 0 (nth 2 playlist))) (list (nth 3 (nth 3 playlist)) (nth 2 (nth 3 playlist)) (nth 1 (nth 3 playlist)) (nth 0 (nth 3 playlist))))) (play playlist basept) ) ((= input "P") ;(princ "\n input P") (princ "\n your time lap is ") (princ timer) (princ "\n your score is ") (princ score) (if (= graphicmode 1) (progn (setq delyn (getstring "\n you want to delete game board? (Press Anykey - Yes / N - No)")) (if (/= (strcase delyn) "N") (progn (if (/= ss2048 nil) (command "_.Erase" ss2048 "") ) (if (/= ss22048 nil) (command "_.Erase" ss22048 "") ) (if (/= ss32048 nil) (command "_.Erase" ss32048 "") ) (if (/= ss42048 nil) (command "_.Erase" ss42048 "") ) );end of progn );end of if );end of progn );end of if ); end of "p" );end of cond ) (defun output2048txt ( lst / adjust lstlen indexr row rowlen indexc cell celllen delta ) (setq adjust 10) (setq lstlen (length lst)) (setq indexr 0) (setq score 0) (repeat lstlen (princ "\n") (setq row (nth indexr lst)) (setq rowlen (length row)) (setq indexc 0) (repeat rowlen (setq cellnum (nth indexc row)) (setq score (+ score cellnum)) (setq cell (vl-princ-to-string cellnum)) (if (= cell nil) (setq cell 0)) (setq celllen (strlen cell)) (setq delta (- adjust celllen)) (repeat delta (setq cell (strcat cell " ")) ) (princ cell) (setq indexc (+ indexc 1)) );end of repeat (setq indexr (+ indexr 1)) );end of repeat (princ "\n Waiting User Input - ") );end of output2048txt (defun output2048 ( lst basept / adjust lstlen indexr row rowlen indexc cell celllen delta basept baseptx basepty ptlist ptrow ptcell ptcellx ptcelly cellnum ) (setq adjust 10) (setq lstlen (length lst)) (setq indexr 0) (if (/= ss2048 nil) (command "_.Erase" ss2048 "") ) (setq ss2048 (ssadd)) (if (/= ss22048 nil) (command "_.Erase" ss22048 "") ) (setq ss22048 (ssadd)) (if (/= ss32048 nil) (command "_.Erase" ss32048 "") ) (setq ss32048 (ssadd)) (if (/= ss42048 nil) (command "_.Erase" ss42048 "") ) (setq ss42048 (ssadd)) (setq baseptx (car basept)) (setq basepty (cadr basept)) (setq ptlist (list (list (list (+ baseptx 0) (+ basepty 6)) (list (+ baseptx 2) (+ basepty 6)) (list (+ baseptx 4) (+ basepty 6)) (list (+ baseptx 6) (+ basepty 6))) (list (list (+ baseptx 0) (+ basepty 4)) (list (+ baseptx 2) (+ basepty 4)) (list (+ baseptx 4) (+ basepty 4)) (list (+ baseptx 6) (+ basepty 4))) (list (list (+ baseptx 0) (+ basepty 2)) (list (+ baseptx 2) (+ basepty 2)) (list (+ baseptx 4) (+ basepty 2)) (list (+ baseptx 6) (+ basepty 2))) (list (list (+ baseptx 0) (+ basepty 0)) (list (+ baseptx 2) (+ basepty 0)) (list (+ baseptx 4) (+ basepty 0)) (list (+ baseptx 6) (+ basepty 0))) )) (repeat lstlen (princ "\n") (setq row (nth indexr lst)) (setq rowlen (length row)) (setq ptrow (nth indexr ptlist)) (setq indexc 0) (repeat rowlen (setq cellnum (nth indexc row)) (setq cell (vl-princ-to-string cellnum)) (setq ptcell (nth indexc ptrow)) (setq ptcellx (car ptcell)) (setq ptcelly (cadr ptcell)) (if (= cell nil) (setq cell 0)) (setq celllen (strlen cell)) (setq delta (- adjust celllen)) (repeat delta (setq cell (strcat cell " ")) ) (cond ((= cellnum 0) (setq colorcode 7) (setq cellnum " ")) ((= cellnum 2) (setq colorcode 81)) ((= cellnum 4) (setq colorcode 71)) ((= cellnum 8) (setq colorcode 61)) ((= cellnum 16) (setq colorcode 51)) ((= cellnum 32) (setq colorcode 41)) ((= cellnum 64) (setq colorcode 31)) ((= cellnum 128) (setq colorcode 21)) ((= cellnum 256) (setq colorcode 11)) ((= cellnum 512) (setq colorcode 10)) ((= cellnum 1024) (setq colorcode 12)) ((= cellnum 2048) (setq colorcode 14)) ((> cellnum 2048) (setq colorcode 6)) );end of cond (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 62 colorcode) (cons 67 0) (cons 8 "0") (cons 100 "AcDbText") (cons 40 0.5) (cons 1 (vl-princ-to-string cellnum)) (cons 50 0) (cons 41 1) (cons 51 0) (cons 7 "Standard") (cons 71 0) (cons 72 1) (cons 11 (list (+ ptcellx 1) (+ ptcelly 1) 0)) (cons 100 "AcDbText") (cons 73 2))) (ssadd (entlast) ss2048) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 62 colorcode) (cons 67 0) (cons 8 "0") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 43 0.1) (cons 38 0) (cons 39 0) (cons 10 (list (+ ptcellx 0.05) (+ ptcelly 0.05))) (cons 40 0.1) (cons 41 0.1) (cons 42 0) (cons 91 0) (cons 10 (list (+ ptcellx 1.95) (+ ptcelly 0.05))) (cons 40 0.1) (cons 41 0.1) (cons 42 0) (cons 91 0) (cons 10 (list (+ ptcellx 1.95) (+ ptcelly 1.95))) (cons 40 0.1) (cons 41 0.1) (cons 42 0) (cons 91 0) (cons 10 (list (+ ptcellx 0.05) (+ ptcelly 1.95))) (cons 40 0.1) (cons 41 0.1) (cons 42 0) (cons 91 0))) (ssadd (entlast) ss22048) (if (= timer nil) (setq timer 0)) (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 62 7) (cons 67 0) (cons 8 "0") (cons 100 "AcDbText") (cons 40 0.5) (cons 1 (strcat "Timer : " (rtos timer 2 2) " sec")) (cons 50 0) (cons 41 1) (cons 51 0) (cons 7 "Standard") (cons 71 0) (cons 72 0) (cons 10 (list (+ baseptx 9) (+ basepty 6) 0)) (cons 100 "AcDbText") (cons 73 0))) (ssadd (entlast) ss32048) (if (= score nil) (setq score 0)) (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 62 7) (cons 67 0) (cons 8 "0") (cons 100 "AcDbText") (cons 40 0.5) (cons 1 (strcat "Score : " (rtos score 2 0) )) (cons 50 0) (cons 41 1) (cons 51 0) (cons 7 "Standard") (cons 71 0) (cons 72 0) (cons 10 (list (+ baseptx 9) (+ basepty 4) 0)) (cons 100 "AcDbText") (cons 73 0))) (ssadd (entlast) ss42048) ;(princ cell) (setq indexc (+ indexc 1)) );end of repeat (setq indexr (+ indexr 1)) );end of repeat ;(princ "\n Waiting User Input - ") );end of output2048 (defun makenewnum ( lst / rowlen indexr zerolist row collen indexc cell remainzero newnum newspace replacerow replacecol newrowlist ) (setq rowlen (length lst)) (setq indexr 0) (setq zerolist '()) (repeat rowlen (setq row (nth indexr lst)) (setq collen (length row)) (setq indexc 0) (repeat collen (setq cell (nth indexc row)) (if (= cell 0) (setq zerolist (cons (list indexr indexc) zerolist)) ) (setq indexc (+ indexc 1)) );end of repeat (setq indexr (+ indexr 1)) );end of repeat ;(princ zerolist) (setq remainzero (length zerolist)) (if (= remainzero 0) (progn (princ "\n There's no space for new number") (princ "\n Game Over ") (exit) ) (progn (setq newnum (* (LM:randrange 1 2) 2)) (setq newspace (nth (- (LM:randrange 1 remainzero) 1) zerolist)) (setq replacerow (car newspace)) (setq replacecol (cadr newspace)) (setq indexr 0) (setq newlist '()) (repeat rowlen (setq row (nth indexr lst)) (setq collen (length row)) (setq indexc 0) (setq newrowlist '()) (repeat collen (if (and (= indexc replacecol) (= indexr replacerow)) (progn (setq cell newnum) (setq newrowlist (cons cell newrowlist))) (progn (setq cell (nth indexc row)) (setq newrowlist (cons cell newrowlist))) ) (setq indexc (+ indexc 1)) ); end of repeat (setq newrowlist (reverse newrowlist)) (setq newlist (cons newrowlist newlist)) (setq indexr (+ indexr 1)) ); end of repeat ); end of progn );end of if (setq newlist (reverse newlist)) newlist );end of makenewnum ; by Kent1Cooper, https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/using-arrow-keys-sending-input-without-enter-and-returning-to/m-p/5371933/highlight/true#M327188 (defun grread2048 (/ done) (setq done nil) (while (and (not done) (setq opt (grread T 12 0))) (cond ((or (equal opt '(2 87)) (equal opt '(2 119)) (equal opt '(2 56))) ; input W (setq done T) (princ "\ Input Up (W)") (setq movement "W") ) ((or (equal opt '(2 65)) (equal opt '(2 97)) (equal opt '(2 52))) ; input A (setq done T) (princ "\ Input Left (A)") (setq movement "A") ) ((or (equal opt '(2 83)) (equal opt '(2 115)) (equal opt '(2 53))) ; input S (setq done T) (princ "\ Input Down (S)") (setq movement "S") ) ((or (equal opt '(2 68)) (equal opt '(2 100)) (equal opt '(2 54))) ; input D (setq done T) (princ "\ Input Right (D)") (setq movement "D") ) ((or (equal opt '(2 80)) (equal opt '(2 112))) ; input P (setq done T) (princ "\ Input End (P)") (setq movement "P") ) ); cond ); while movement );end of defun ;; Rand - Lee Mac ;; PRNG implementing a linear congruential generator with ;; parameters derived from the book 'Numerical Recipes' (defun LM:rand ( / a c m ) (setq m 4294967296.0 a 1664525.0 c 1013904223.0 $xn (rem (+ c (* a (cond ($xn) ((getvar 'date))))) m) ) (/ $xn m) ) ;; Random in Range - Lee Mac ;; Returns a pseudo-random integral number in a given range (inclusive) (defun LM:randrange ( a b ) (+ (min a b) (fix (* (LM:rand) (1+ (abs (- a b)))))) ) ;; 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) ) ) yes this is 2048 game for fun ( https://en.wikipedia.org/wiki/2048_(video_game) ) this is my grread practice code. command : - 2048 (graphic mode - use polyline and text) - 2048t (command prompt text only mode) Key : W = up , A = left , S = down, D = right, P = end game Key2 : 8 = up, 4 = left, 5 = down, 6 = right (for numpad with numlock on), P = end game If you can no longer generate numbers, it will be game over (but there seems to be some error haha) ------------------------------------------------------------------------ At first, I was going to practice grread simply, but it seems that I studied the algorithm of moving and adding in 4 directions more and more. Create a function for one direction, rotate the 4x4 matrix in 3 directions, apply it and back again. If it was implemented universally in this process, it would have been possible to freely create 5x5, 10x10, etc. not only 4x4, but it was difficult so I hard coding that. So it only works for 4x4 sadly

I knew I had seen something this by PBE here at cadtutor 2014, copy paste code to command line you may be surprised what you get. (setq txtstring (vlax-invoke (vlax-get (vlax-get (setq 2ClipB (vlax-create-object "htmlfile")) 'ParentWindow ) 'ClipBoardData ) 'GetData "Text" ) ) The problem is the clip data may not be text. line 1 line 2 line 3 Returns ("line 1\r\nline2\r\nline 3") Just a side note if you debug a text file you will find in hex ODOA on end of line this is carriage return & line feed which looks like it matches \r\n

Use Lee Mac's Minimum Bounding Box!

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.

Thank you for all your continued work in keeping this place online David, it is tremendously appreciated - the forum feels far more responsive following the upgrade!

I beg to differ with you. CADTutor is thriving because of the perseverance, dedication and vision of David Watson who deserves our thanks. So... "Thank you" David for all that you have done.

LISP is correct in both cases: boundary is LWPOLYLINE or LINE (defun DXF (code en) (cdr (assoc code (entget en)))) ;;;========================================================================= (defun Line (p1 p2) (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))) (defun Ray (po V) (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 po) (cons 11 v) ) ) ) ;;;========================================================================= (defun sysvar-set (lst_setvar / strN var var_oldname n) (setq n 0 lstvar_thiep nil lstValue_thiep nil ) (repeat (/ (length lst_setvar) 2) (setq var (nth n lst_setvar) var_oldname (strcat "oldvar_thiep" (itoa n)) ) (setq lstvar_thiep (append lstvar_thiep (list var))) (set (read var_oldname) (getvar var)) (setq lstValue_thiep (append lstValue_thiep (list (read var_oldname)))) (setvar var (nth (+ n 1) lst_setvar)) (setq n (+ 2 n)) ) ) (defun Get-Area (lst ) (/ (apply '+ (mapcar '(lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b)))) lst (cons (last lst) lst) ) ) 2 ) ) ;;;========================================================================= (defun SYSVAR-RESTORE () (mapcar '(lambda (var value) (setvar var (eval value))) lstvar_thiep lstValue_thiep ) ) ;;;========================================================================= (defun CalcZ (Pt1 Pt2 Pt3 / v w) (setq v (mapcar '- Pt1 Pt2) w (mapcar '- Pt3 Pt2) ) (- (* (car v) (cadr w)) (* (cadr v) (car w))) ) ;;;========================================================================= (defun calcThiep (po1 po2 po3 po4 / bit dis m anpha beta h obj_top poS poE) (setq anpha_org (LM:GetInsideAngle po4 po1 po2) beta_org (LM:GetInsideAngle po1 po2 po3) ) (if (< dt 0) (setq anpha anpha_org beta beta_org ) (setq anpha (- pi anpha_org) beta (- pi beta_org) ) ) (Setq bit (CalcZ po1 po4 po2)) (setq dis (distance po1 po2) ang (angle po1 po2) ) (setq m (+ (/ (cos anpha) (sin anpha)) (/ (cos beta) (sin beta)))) (setq h (abs (/ (- dis (sqrt (abs (- (* dis dis) (* 2 m (abs dt)))))) m))) (cond ((or (and (> bit 0) (> dt 0)) (and (< bit 0) (< dt 0))) (setq po5 (polar po2 (- ang (/ pi 2)) h) po6 (polar po1 (- ang (/ pi 2)) h) ) ) ((or (and (> bit 0) (< dt 0)) (and (< bit 0) (> dt 0))) (setq po5 (polar po2 (+ ang (/ pi 2)) h) po6 (polar po1 (+ ang (/ pi 2)) h) ) ) ) (setq po_in1 (inters po5 po6 po1 po4 nil) po_in2 (inters po5 po6 po2 po3 nil) ) ) (defun makeLWPoly (lst) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) ) (mapcar (function (lambda (p) (cons 10 p))) lst) ) ) ) (defun limS (po1 po2 po3 po4 / objL1 objL2 objR iplist) (line po4 po1) (setq objL1 (vlax-ename->vla-object (entlast))) (line po3 po2) (setq objL2 (vlax-ename->vla-object (entlast))) (cond ((> dt 0) (setq iplist (vlax-safearray->list (vlax-variant-value (vla-intersectwith objL1 objL2 3)) ) ) (vla-delete objL1) (vla-delete objL2) (SETQ A (Get-Area (list po1 po2 iplist po1))) ) ((< dt 0) (ray po4 (mapcar '- po2 po1)) (setq objR (vlax-ename->vla-object (entlast))) (if (null (vlax-invoke objR 'IntersectWith objL2 acExtendNone)) (PROGN (setq iplist (vlax-invoke objR 'IntersectWith objL2 acExtendOtherEntity ) ) (SETQ A (Get-Area (list po1 po2 iplist po4 po1))) ) (PROGN (vla-delete objR) (ray po3 (mapcar '- po1 po2)) (setq objR (vlax-ename->vla-object (entlast))) (setq iplist (vlax-invoke objR 'IntersectWith objL1 acExtendOtherEntity ) ) (SETQ A (Get-Area (list po1 po2 po3 iplist po1))) ) ) (vla-delete objL1) (vla-delete objL2) (vla-delete objR) ) ) (abs A) ) ;;;========================================================================= (defun c:dht (/ ent1_lst ent1 ent2 ent3 po1 po2 po3 po4 ang1 ang2 ang3 dis m lstpo1 lstpo2 lstpo3 lstpo-int1 lstpo-int2 anpha beta pS1 pS2 pS3 pE1 pE2 pE3 h bit obj_top poS poE po_in1 po_in2 prom Alim ) (command "undo" "be") (sysvar-set '("cmdecho" 0 "osmode" 0)) (defun *error* (msg) (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **")) ) (setq dt nil) (acet-ui-status) (sysvar-restore) (command "undo" "en") (princ) ) (or dt (setq dt (getcfg "AppData/trapezoid/area")) (setq dt 1000)) (acet-ui-status (setq prom (acet-str-format "\nEnter Area given for to expand (+S) or to trim (-S) <%1> : " (if (numberp dt) (rtos dt 2 3) dt ) "LOOK AT" ) ) ) (setq olddt dt) (setq dt (getreal prom)) (if (null dt) (setq dt olddt) ) (if (not (numberp dt)) (setq dt (atof dt)) ) (acet-ui-status (setq prom "\nPick a LINE (or LWPOLYLINE) edge for to expand (or to trim) area " ) "LOOK AT" ) (while (OR (NOT (setq ent1_lst (entsel prom))) (NOT (wcmatch (DXF 0 (setq ent1 (car ent1_lst))) "LINE,LWPOLYLINE")) ) (acet-ui-status (setq prom "Pick a LINE is not right, Please pick again") "LOOK AT" ) (prompt prom) ) (acet-ui-status) (cond ((eq (DXF 0 ent1) "LINE") (acet-ui-status (setq prom "\nPick a LINE 1st edge of the trapezoid ") "LOOK AT" ) (while (OR (NOT (setq ent2 (car (entsel prom)))) (NOT (wcmatch (DXF 0 ent2) "LINE")) ) (acet-ui-status (setq prom "Pick a LINE is not right, Please pick again") "LOOK AT" ) (prompt prom) ) (acet-ui-status (setq prom "\nPick a LINE 2nd edge of the trapezoid ") "LOOK AT" ) (while (OR (NOT (setq ent3 (car (entsel prom)))) (NOT (wcmatch (DXF 0 ent3) "LINE")) ) (acet-ui-status (setq prom "Pick a LINE is not right, Please pick again") "LOOK AT" ) (prompt prom) ) (acet-ui-status) (setq po1 (vlax-curve-getStartpoint ent1) ;_bottom edge po2 (vlax-curve-getEndpoint ent1) ) (setq pS2 (vlax-curve-getStartpoint ent2) ;_ 1st side pE2 (vlax-curve-getEndpoint ent2) ) (setq pS3 (vlax-curve-getStartpoint ent3) ;_ 2nd side pE3 (vlax-curve-getEndpoint ent3) ) (cond ((Equal po1 ps3 1e-2) (setq po4 pE3) (cond ((Equal po2 ps2 1e-2) (setq po3 pE2)) ((Equal po2 pE2 1e-2) (setq po3 pS2)) ) ) ((Equal po1 pE3 1e-2) (setq po4 pS3) (cond ((Equal po2 ps2 1e-2) (setq po3 pE2)) ((Equal po2 pE2 1e-2) (setq po3 pS2)) ) ) ((Equal po1 ps2 1e-2) (setq po4 pE2) (cond ((Equal po2 ps3 1e-2) (setq po3 pE3)) ((Equal po2 pE3 1e-2) (setq po3 pS3)) ) ) ((Equal po1 pE2 1e-2) (setq po4 pS2) (cond ((Equal po2 ps3 1e-2) (setq po3 pE3)) ((Equal po2 pE3 1e-2) (setq po3 pS3)) ) ) ) ) ((eq (DXF 0 ent1) "LWPOLYLINE") (setq po_pick (cadr ent1_lst)) (setq po_closest (vlax-curve-getClosestPointTo ent1 po_pick)) (setq para1 (fix (vlax-curve-getParamatpoint ent1 po_closest))) (setq paraE (vlax-curve-getEndParam ent1)) (setq paraS (vlax-curve-getStartParam ent1)) (setq po1 (vlax-curve-getPointAtParam ent1 para1)) (cond ((= para1 0) (setq po4 (vlax-curve-getPointAtParam ent1 paraE) po2 (vlax-curve-getPointAtParam ent1 (+ para1 1)) po3 (vlax-curve-getPointAtParam ent1 (+ para1 2)) ) (if (equal po1 po4 1e-3) (setq po4 (vlax-curve-getPointAtParam ent1 (- paraE 1))) ) ) ((< (1+ para1) paraE) (setq po4 (vlax-curve-getPointAtParam ent1 (- para1 1)) po2 (vlax-curve-getPointAtParam ent1 (+ para1 1)) po3 (vlax-curve-getPointAtParam ent1 (+ para1 2)) ) ) ((= (1+ para1) paraE) (setq po4 (vlax-curve-getPointAtParam ent1 (- para1 1)) po2 (vlax-curve-getPointAtParam ent1 (+ para1 1)) po3 (vlax-curve-getPointAtParam ent1 paraS) ) (if (equal po2 po3 1e-3) (setq po3 (vlax-curve-getPointAtParam ent1 (+ paraS 1))) ) ) ) ) ) (setq Alim (limS po1 po2 po3 po4)) (calcThiep po1 po2 po3 po4) (setvar "cecolor" "1") (makeLWPoly (list po1 po2 po_in2 po_in1 po1)) (setvar "cecolor" "256") (if (> (abs dt) Alim) (cond ((> (+ anpha_org beta_org) pi) (alert (acet-str-format "area to expand is too large (max = %1), so this case results in an area error" (rtos Alim 2 3) ) ) ) ((< (+ anpha_org beta_org) pi) (alert (acet-str-format "area to trim is too large (max = %1), so this case results in an area error" (rtos Alim 2 3) ) ) ) ) ) (setcfg "AppData/trapezoid/area" (rtos dt 2 3)) (SYSVAR-RESTORE) (command "undo" "en") (princ "ok") (princ) ) (defun LM:GetInsideAngle ( p1 p2 p3 ) ( (lambda ( a ) (min a (- (+ pi pi) a))) (rem (+ pi pi (- (angle p2 p1) (angle p2 p3))) (+ pi pi)) ) ) Extend_Trim_Area(DHT).lsp

The above could alternatively be written: (defun LM:data->xdata ( x ) (cond ( (= 'str (type x)) (list (cons (if (handent x) 1005 1000) x))) ( (= 'real (type x)) (list (cons 1040 x))) ( (= 'int (type x)) (list (cons (if (< -32769 x 32768) 1070 1071) x))) ( (= 'list (type x)) (append '((1002 . "{")) (apply 'append (mapcar 'LM:data->xdata x)) '((1002 . "}")))) ( (list (cons 1000 (vl-prin1-to-string x)))) ) )

While you're waiting, consider that this isn't some magic portal where you ask for something for free and it's delivered to you with a flash of smoke.....

In fact my intention was simple, in order to clean up the [BBcodes] within the new code tags in this forum. Therefore, IMO optimized with CLIPBOARD without using 'getfiled' is much more convenient, isn't it? code updated - post#1 Copy text (from forum) -> run 'FORUM' (in ACAD) -> [Ctrl+V] Paste (in forum active editor) Done!