Leaderboard

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

You'll only be able to use Script Writer on unopened drawings, else the drawings will be rendered as read-only to the script. Since the ActiveX zoomextents method is derived from the application class, you will only be able to invoke it on the current drawing, not those which are open but inactive. Furthermore, since LISP operates within the document namespace, you won't be able to active an inactive drawing and then issue a command, since, as soon as the drawing becomes active, the LISP evaluation will cease. Aside from using the .NET (C#/F#/VB) or ARX (C++) APIs, the only way that I could see this being accomplished is using a VBA function to send the command to the appropriate document - the late great Michael Puckett (MP) demonstrates this technique here.

Because the tblobjname function returns an AcDbBlockBegin object for the Block Symbol Table so as to facilitate iterating over the block components (until an AcDbBlockEnd object is encountered); the AcDbBlockBegin class is derived from the AcDbEntity class, hence the equivalent ActiveX interface object is an IAcadEntity object. You can also observe this through the DXF data for the entities - tblobjname will return a BLOCK entity of class AcDbBlockBegin which is derived from the AcDbEntity base class: ( (-1 . <Entity name: 20458ff8900>) (0 . "BLOCK") (330 . <Entity name: 20458ff88a0>) (5 . "3C0") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockBegin") (70 . 0) (10 0.0 0.0 0.0) (-2 . <Entity name: 20458ff88b0>) (2 . "test") (1 . "") ) The parent entity is a BLOCK_RECORD entity of class AcDbBlockTableRecord which is derived from the AcDbSymbolTableRecord base class: ( (-1 . <Entity name: 20458ff88a0>) (0 . "BLOCK_RECORD") (5 . "3BA") (102 . "{ACAD_XDICTIONARY") (360 . <Entity name: 20458ff88e0>) (102 . "}") (330 . <Entity name: 20458fef810>) (100 . "AcDbSymbolTableRecord") (100 . "AcDbBlockTableRecord") (2 . "test") (360 . <Entity name: 20458ff8900>) (340 . <Entity name: 0>) (102 . "{BLKREFS") (331 . <Entity name: 20458ff8920>) (102 . "}") (70 . 4) (280 . 1) (281 . 0) )

You're welcome to use my implementation from here.

Here's one possible way - (vl-sort lst '(lambda ( a b ) (< (vl-position (atoi (cadr a)) dsd) (vl-position (atoi (cadr b)) dsd)))) Or, perhaps faster: (mapcar '(lambda ( n ) (nth n lst)) (vl-sort-i (mapcar '(lambda ( x ) (vl-position (atoi (cadr x)) dsd)) lst) '<)) Or, if you only want members that are present in dsd, you could use - (vl-remove nil (mapcar '(lambda ( x ) (car (vl-member-if '(lambda ( y ) (= x (atoi (cadr y)))) lst))) dsd))

Since you're using BricsCAD, you can use the isPropertyValid function to test whether the property is valid prior to obtaining it, e.g.: (defun c:test ( / ent ) (if (setq ent (car (entsel))) (if (ispropertyvalid ent "d1~MCAD") (print (getpropertyvalue ent "d1~MCAD")) (princ "\nProperty not valid.") ) ) (princ) )

(defun c:buildingelev ( / *error* pt ex:lwpline_by_list pt elev pt1 clr arrow1 arrow2 arrow3 arrow4 arrow5 arrow6 arrow7 arrow8 arrowPoints oldLayer layerName lay lwp textStr textPtLeft textsize textent) (vl-load-com) (defun *error* (msg) (if (/= msg "Function cancelled") (princ (strcat "\nError: " msg)) ) (setvar "CLAYER" oldLayer) (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) (princ) ) ; make lwpolyline by pointlist ; lst - point list (2d), cls - closed (0 - no, 1 - yes), clr - color (by aci, 256 - by layer, 0 - by block, 1 - red, 2 - yellow ~~ ) ; return - ename (defun ex:lwpline_by_list (lst cls clr) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 62 clr) (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst) ) ) ) (vla-startundomark (vla-get-activedocument (vlax-get-acad-object))) (setq oldLayer (getvar "CLAYER")) (setq layerName "LEVEL_NCW") (if (not (tblsearch "LAYER" layerName)) (progn (setq lay (vla-add (vla-get-layers (vla-get-ActiveDocument (vlax-get-acad-object))) layerName)) (vlax-put-property lay 'color clr) ) ) (setvar "CLAYER" layerName) (while (setq pt (getpoint "\nSelecione o ponto: (pick point - continue / space bar or esc - exit)")) (setq elev (cadr pt)) (setq pt1 (trans pt 0 1 elev)) (setq clr 2) ;temp value - yellow ;; Arrow Creation (setq arrow1 (list (- (car pt1) 0.000) (+ (cadr pt1) 0.0))) ; Position for arrow1 (setq arrow2 (list (- (car pt1) 0.075) (+ (cadr pt1) 0.175))) ; Position for arrow2 (setq arrow3 (list (- (car pt1) 0.019) (+ (cadr pt1) 0.150))) ; Position for arrow3 (setq arrow4 (list (- (car pt1) 0.038) (+ (cadr pt1) 0.235))) ; Position for arrow4 (setq arrow5 (list (+ (car pt1) 0.038) (+ (cadr pt1) 0.235))) ; Position for arrow5 (setq arrow6 (list (+ (car pt1) 0.019) (+ (cadr pt1) 0.150))) ; Position for arrow6 (setq arrow7 (list (+ (car pt1) 0.075) (+ (cadr pt1) 0.175))) ; Position for arrow7 (setq arrow8 (list (+ (car pt1) 0.000) (+ (cadr pt1) 0.000))) ; Position for arrow8 (setq arrowPoints (list arrow1 arrow2 arrow3 arrow4 arrow5 arrow6 arrow7 arrow8)) (setq lwp (ex:lwpline_by_list arrowPoints 0 256)) ;; Criação do texto (setq textStr (rtos elev 2 2)) ; Converte a elevação para string (setq textPtLeft (trans (list (- (car pt) 0.0) (+ (cadr pt) 0.3)) 0 0 elev)) ; Posicionamento do texto à esquerda (setq textsize 0.3) ;temp value, or (setq textsize (getvar 'textsize)) (setq textent (entmakex (list (cons 0 "TEXT") (cons 62 256) (cons 10 textPtLeft) (cons 40 textsize) (cons 1 textStr) (cons 50 0) (cons 41 1) (cons 51 0) (cons 71 0) (cons 72 0) (cons 73 0) ) ) ) ) (setvar "CLAYER" oldLayer) (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) (princ) ) i cannot load your image, but if below gif is what you want, try this

Bricscad pro $1740 AUD Lite even cheaper and is perpetual.

(defun c:interpol ( / ss ssl index ent obj box ll ur lll url ss2 ss2l ) (vl-load-com) (if (setq ss (ssget '((0 . "LWPOLYLINE")))) (progn (setq ssl (sslength ss)) (setq index 0) (repeat ssl (setq ent (ssname ss index)) (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 (if (setq ss2 (ssget "CP" lll url '((0 . "LWPOLYLINE")))) (progn (setq ss2l (sslength ss2)) (if (> ss2l 1) (vlax-put-property obj 'color 2) ) ) (progn ) ) (setq index (+ index 1)) ) ) (progn) ) (princ) ) try this If you change (vlax-put-property obj 'color 2) to (vlax-put-property obj 'color (+ ss2l 1)) this will can change the color depending on the number of overlaps. but It may be difficult to recognize colors after 8 on the acad color index. it's gray. The one in this link is a more advanced method, but in your example the rectangle has an elevation value so strictly speaking straight lines are not intersecting with rectangles. so, you can trans or copy this rectangle to elevation 0 then use intersectwith, then delete that temporary rectangle is also possible approach. but ssget "CP" is more simple way.

(defun 1MT (break / *error* done e objlst obj wid str strllen strlist) ; <- add these 2 variable name ....................................................... (setq str (vla-get-TextString obj)) ; Insert these lines below this line. (setq strlist (list str)) (foreach x (cdr objlst) (setq str (vla-get-TextString x)) (setq strlist (cons str strlist)) ); foreach (setq strlist (vl-sort strlist '<)) (foreach x (cdr objlst) (vla-delete x) ) (setq str (car strlist)) (setq strlist (cdr strlist)) (setq strllen (length strlist)) (repeat strllen (setq str (strcat str break (car strlist))) (setq strlist (cdr strlist)) ) ; up to this line (vla-put-TextString obj str) This is a modification of 1MT. Just add these lines in defun 1MT. ================================================================================== or You can do this by creating a new command by adding the original, ascending sort, and descending sort options. first, Add 0 one by one to the original 3 commands and add sort, reverse sort commands ; original (defun C:1MT0 (); all in one paragraph -- 1 space between, no Enter (1MT " " 0); Space for 'break' argument in 1MT (princ) ) (defun C:1MT1 (); new paragraph for each object's content -- 1 Enter (1MT "\\P" 0); Enter for 'break' argument in 1MT (princ) ) (defun C:1MT2 (); blank line & new paragraph for each object's content -- 2 Enters (1MT "\\P\\P" 0); 2 Enters for 'break' argument in 1MT (princ) ) ; sort (Ascending) (defun C:1MTS0 () (1MT " " 1) (princ)) (defun C:1MTS1 () (1MT "\\P" 1) (princ)) (defun C:1MTS2 () (1MT "\\P\\P" 1) (princ)) ; reverse sort (descending) (defun C:1MTRS0 () (1MT " " 2) (princ)) (defun C:1MTRS1 () (1MT "\\P" 2) (princ)) (defun C:1MTRS2 () (1MT "\\P\\P" 2) (princ)) then, add sortoption to argument (defun 1MT (break sortoption / *error* done e objlst obj wid str strllen strlist) then modify the above code by adding (cond) like this. (setq str (vla-get-TextString obj)) ; Insert these lines below this line. (cond ((= sortoption 0) ) ((or (= sortoption 1) (= sortoption 2)) (setq strlist (list str)) (foreach x (cdr objlst) (setq str (vla-get-TextString x)) (setq strlist (cons str strlist)) ); foreach (cond ((= sortoption 1) (setq strlist (vl-sort strlist '<)) ) ((= sortoption 2) (setq strlist (vl-sort strlist '>)) ) ) (foreach x (cdr objlst) (vla-delete x) ) (setq str (car strlist)) (setq strlist (cdr strlist)) (setq strllen (length strlist)) (repeat strllen (setq str (strcat str break (car strlist))) (setq strlist (cdr strlist)) ) ) (t ) ) ; up to this line (vla-put-TextString obj str)

Give this a try: (defun c:DC ( / curlay) (setq curlay (getvar "CLAYER")) (setvar "clayer" "S - DETAIL CUT") (vl-cmdf "._insert" "Detail Cut" "_s" 36.0 "_r" 0) (setvar "clayer" curlay) (princ) )

That is a hard shape to change, explode, fillet and erase comes to mind as 1st answer. Ok 2nd answer select pline segments in sequence, no arcs, then make a new pline from new line segments. So try this. Just pick segments press enter to stop picking it will close automatically. You must pick in order. (defun getplineseg (elst / elst ename pt param preparam postparam) (setq ename (car elst)) (setq pt (cadr elst)) (setq pt (vlax-curve-getClosestPointTo ename pt)) (print (setq param (vlax-curve-getParamAtPoint ename pt)) ) (print (setq preparam (fix param)) ) (print (setq postparam (1+ preparam)) ) (setq pt1 (vlax-curve-getPointAtParam ename preparam) pt2 (vlax-curve-getPointAtParam ename postparam)) ) (defun c:wow ( / oldsnap ent mp1 mp2 pt1 pt2 mpst) (setq oldsnap (getvar 'osmode)) (setvar 'osmode 0) (setvar 'filletrad 0.0) (setq ent (entsel "\nSelect pline segment: ")) (getplineseg ent) (command "pline" pt1 pt2 "") (setq mp1 (mapcar '* (mapcar '+ pt1 pt2) '(0.5 0.5))) (setq mpst mp1) (while (setq ent (entsel "\nSelect pline segment: ")) (getplineseg ent) (command "pline" pt1 pt2 "") (setq mp2 (mapcar '* (mapcar '+ pt1 pt2) '(0.5 0.5))) (command "fillet" mp1 mp2) (setq mp1 mp2) ) (setq obj (vlax-ename->vla-object (entlast))) (vlax-put obj 'Closed -1) (princ) )

I've uploaded 2 my programs to download section of cadtutor... I hope you'll find them useful... Here are links : Regards, Marko Ribar, d.i.a. (architect)

(defun c:test (/ xlApp xlBook xlSheet atsheet columnD Columnall row col cellValue ) (vl-load-com) (setq xlApp (vlax-get-or-create-object "Excel.Application")) (setq xlBook (vlax-get-property xlApp 'Sheets) xlSheet (vlax-get-property xlBook 'Item "Sheet1") atsheet (vlax-invoke-method xlSheet 'Activate) ) (setq ColumnD (vlax-get-property xlSheet 'Range "D:D")) (setq lastCell (vlax-invoke ColumnD 'Find "*" nil -4163 1 2 2) ; 'Fine what after lookin lookat SearchOrder SearchDirection ) ; xlfindlookin > xlComments = -4144, xlCommentsThreaded = -4184, xlFormulas = -4123, xlValues = -4163 ; xlLookAt > xlWhole = 1, xlPart = 2 ; XlSearchOrder > xlByRows = 1, xlByColumns = 2 ; XlSearchDirection > xlNext = 1, xlPrevious = 2 (if lastCell (progn (setq row (vlax-get lastCell 'Row)) (setq col (vlax-get lastCell 'Column)) (setq cellValue (vlax-get lastCell 'Value)) (if (numberp cellValue) (setq cellValue (rtos cellValue 2 2)) ) (princ (strcat "Last non-empty cell in column D is in row " (itoa row) ", column " (itoa col) ", with value: " "\"" cellValue "\"" ) ) ) (princ "No non-empty cell found in column D") ) (vlax-release-object columnD) (vlax-release-object lastCell) (vlax-release-object xlApp) (gc) (gc) (princ) ) 1. If you want to use this, you must change all values starting with xl~ to constants. Because that is a value known to excel only. not a value known to autolisp. Just think of it like this. (setq xlValue -4163) (setq xlWhole 1) ..... etc excel vba has this values in those variables already you can find it in microsoft pages. like this link https://learn.microsoft.com/en-us/office/vba/api/excel.xlfindlookin 2. there are two ways to find the last cell. forward way as you mentioned, if the middle of the list is empty, trapping this requires knowing the total row count, If there are cells with values in the remaining cells performing it again, loop this It's not reasonable. and need to find empty cell "" instead of "*". but you cannot enter the value nil or "" as the "what" argument of the excel find function. can't put (strcat (chr 34) (chr 34)) or "\"\"" or :vlax-false also. by vba can find "" but by autolisp cannot. as far as i know Therefore, if you implement this, you have to search for the cell value with "*" and collect more data, so it is inefficient. reverse way changes the search direction. it's the universal way to find the last cell. (setq lastCell (vlax-invoke ColumnD 'Find "*" nil -4163 1 2 2) ; 'Find what after lookin lookat SearchOrder SearchDirection

So you could use ssget (see http://lee-mac.com/ssget.html ) to select block 1: This will select all blocks. (setq ss (ssget "_X" ' ((0. "INSERT") (2. "Block Name"))) ) Then loop through the selection set with a while, repeat foreach or however loop Using the selected block you can get it's insert point: (setq MyBlock (ssname ss count)) ; where count is the item number in the selection set (set pt (cdr (assoc 10 (entget Myblock)))) ; gets the insertion point of the block And then back to selection set, select all block 2 that lie within an area of this insertion point: (setq pt1 (mapcar '+ (-5 -5 0) pt)) ; 4 corners of a rectabgle round the block (setq pt2 (mapcar '+ (-5 +5 0) pt)) (setq pt3 (mapcar '+ (+5 +5 0) pt)) (setq pt4 (mapcar '+ (+5 -5 0) pt)) (setq ss2 (ssget "_CP" (list pt1 pt2 pt3 pt4) '((2 . "Block Name 2")) )) and work out if ss2 is nil or a list - if it is a list then count it. Might work (CAD is off for today so the above is untested but might point you near to what you want) As Dan above, post your LISP if you can and it might be a simple change in that to make it work - keeping the work you did

(apply 'append (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (list x y)) list2)) list1))

Steven P's Hatch2Poly works fine on my 2022 AutoCAD. Both exceed and Steven P did a great job, y'all have left me in the dust.

1. Create a dwg file containing new blocks. 2. Select blocks to be modified using QSELECT or layer filter in the drawing to be modified. 3. Copy with CopyBase (Ctrl+Shift+C) 0,0 4. ERASE and PURGE for Delete Blocks. 5. Insert the DWG file containing the new block into the drawing using XREF. 6. in XREF window INSERT(not BIND) that for merging this will make the new blocks into the original drawing. 7. Paste the CopyBase block from the clipboard with Ctrl+V 0,0 Since the copybased inform contains only the block name, it is pasted as a new block. 8. Delete the inserted XREF. or try this routine ; REPLACEBLOCKS - 2023.09.04 exceed ; Replace existing blocks with duplicate names with copied blocks. (defun c:REPLACEBLOCKS (/ *error* answer ss thisdrawing mspace entl myline ent ssl index bnamelist entp objp objtype bname bnlen recoverlist bnold bntemp rcl 1blk fromname toname ssb n e1 edata ) (vl-load-com) (defun *error* (msg) (if (/= msg "Function cancelled") (princ (strcat "\nError: " msg)) ) (vla-EndUndoMark thisdrawing) (princ) ) (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object))) (setq mspace (vla-get-modelspace thisdrawing)) (vla-startundomark thisdrawing) (princ "\n Replace existing blocks with duplicate names with copied blocks.") (princ "\n you need to copy the block from another drawing and then run this command.") (setq answer (getstring "\n If you already copied, press the space bar / If not, press ESC.")) (setq ss (ssadd)) (if (setq entl (entlast)) (progn) (progn (setq myline (vla-addline mspace (vlax-3d-point (list 0 0 0))(vlax-3d-point (list 1 1 1)))) (setq entl (entlast)) (ssadd entl ss) ) ) (setvar 'cmdecho 0) (command "pasteclip" "0,0") (while (setq ent (entnext entl)) (ssadd ent ss) (setq entl ent) ) (setq ssl (sslength ss)) (setq index 0) (setq bnamelist '()) (repeat ssl (setq entp (ssname ss index)) (setq objp (vlax-ename->vla-object entp)) (setq objtype (vlax-get-property objp 'EntityName)) ;(princ objtype) (if (= objtype "AcDbBlockReference") (progn (setq bname (vlax-get-property objp 'effectivename)) (setq bnamelist (cons bname bnamelist)) ) ) (setq index (+ index 1)) ) (setq bnamelist (vl-sort bnamelist '<)) ;(princ bnamelist) (repeat ssl (setq entp (ssname ss 0)) (entdel entp) (ssdel entp ss) ) ;; Unique - Lee Mac ;; Returns a list with duplicate elements removed. (defun LM:Unique ( l ) (if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l))))) ) (setq bnamelist (LM:Unique bnamelist)) ;(princ bnamelist) (setq bnlen (length bnamelist)) (setq recoverlist '()) (repeat bnlen (setq bnold (car bnamelist)) (setq index 0) (setq bntemp (strcat bnold "-TEMP")) (while (tblsearch "BLOCK" bntemp) (setq bntemp (strcat bnold "-TEMP" (vl-princ-to-string index))) (setq index (+ index 1)) ) (vla-put-Name (vla-item (vla-get-blocks thisdrawing) bnold) bntemp) (setq recoverlist (cons (list bntemp bnold) recoverlist)) (setq bnamelist (cdr bnamelist)) ) (vla-PurgeAll thisdrawing) (setq ss (ssadd)) (setq entl (entlast)) (if (= entl nil) (progn (setq myline (vla-addline mspace (vlax-3d-point (list 0 0 0))(vlax-3d-point (list 1 1 1)))) (setq entl (entlast)) (ssadd entl ss) ) ) (command "pasteclip" "0,0") (while (setq ent (entnext entl)) (ssadd ent ss) (setq entl ent) ) (repeat ssl (setq entp (ssname ss 0)) (entdel entp) (ssdel entp ss) ) (setq rcl (length recoverlist)) (setq index 0) (repeat rcl (setq 1blk (nth index recoverlist)) (setq fromname (car 1blk)) (setq toname (cadr 1blk)) (if (setq ssb (ssget "_X" (list (cons 2 fromname)))) (repeat (setq n (sslength ssb)) (setq e1 (ssname ssb (setq n (1- n)))) (setq edata (entget e1)) (entmod (subst (cons 2 toname) (cons 2 fromname) edata)) (entupd e1) ) ) (setq index (+ index 1)) ) (command "redraw") (vla-PurgeAll thisdrawing) (setvar 'cmdecho 1) (vla-EndUndoMark thisdrawing) (princ) ) This is a rough routine, so it's not elegant. It's just an idea, so someone better can edit it. how to use it 1. Copy new blocks to copy base. 2. Run REPLACEBLOCKS on the drawing to be replaced. How it Works 1. Paste the copybased items once and add them to the selection set. 2. Since entlast is used to insert into the selection set, a temporary line is created in case entlast does not exist. (although it is almost never necessary...) 3. Collect block names by cycling through the selection set. 4. Filter out unique names. 5. Delete temporarily pasted objects and lines. 6. Find the corresponding block name in the blocks of this drawing. 7. Change the name to one with -TEMP. In case of duplicates, add serial numbers after that -TEMP. 8. Create a list by pairing the original name and TEMP name. To return it to its original state later. 9. Delete the existing block definition with PurgeAll. 10. PasteSpec again and paste the block from the clipboard to create a new definition. and then delete them. 11. Revert to the name changed with entmod. 12. Run purgeall again to delete the TEMP block definition. 13. End Since the temporary block is pasted twice and the temporary line is also created and deleted, it is best to check the area near 0,0 once. It worked fine in my tests, but I didn't assume all the scenarios.

@robierzo Rather than accepting bit codes other than closed, it may be wiser to reject the closed bit code, as this will continue to function if additional bit codes are added in future. (ssget "_X" '( (-4 . "<OR") (0 . "ARC,LINE") (-4 . "<AND") (0 . "LWPOLYLINE") (-4 . "<NOT") (-4 . "&=") (70 . 1) (-4 . "NOT>") (-4 . "AND>") (-4 . "OR>") ) )

Try this: ;;Draw leader and text inside circle (DEFUN C:LEADBBL (/ *error* _Common _Getkword ACD BOX C67 CLA CTB DIA DIC DIS DMC DMH DMS DMY DSO FDS FIL LDI POS PT1 PT2 PT3 PTE PTW RAD RGT SRT TXT ) (defun *error* (s) (if (and PT2 (not PT3)) (redraw)) (if (and ACD DSO DMS) (vla-put-activedimstyle ACD (vla-item DIC DMS))) (if DIC (vlax-release-object DIC)) (if ACD (vlax-release-object ACD)) (or (wcmatch (strcase s) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\nError: " s))) (princ) ) (defun _Common (nume) (mapcar (function cons) (quote (0 100 67 410 8)) (list nume "AcDbEntity" C67 CTB CLA) ) ) (defun _Getkword (Ini Def Esc Msg / lies lopt noli stop) (prompt Msg) (setq lies (list (quote (2 13)) (quote (2 32))) Ini (mapcar (function (lambda (x) (list 2 (ascii x)))) Ini) ) (while (not stop) (setq noli (vl-catch-all-error-p (setq lopt (vl-catch-all-apply (function grread) (list nil 8)))) stop (cond ( noli Esc) ( (or (= (car lopt) 25) (vl-position lopt lies)) Def) ( (vl-position lopt Ini) (princ (chr (cadr lopt)))) ( T (if (= (car lopt) 2) (princ (chr (cadr lopt)))) (prompt (strcat "\nInvalid option." Msg))) ) ) ) (strcase stop) ) (setq CTB (if (= (getvar "CVPORT") 1) (getvar "CTAB") "Model") C67 (if (= CTB "Model") 0 1) CLA (getvar "CLAYER") DMS (getvar "DIMSTYLE") ACD (vla-get-activedocument (vlax-get-acad-object)) DIC (vla-get-dimstyles ACD) FIL (vl-filename-mktemp (substr (rtos (getvar "CDATE") 2 8) 10) nil ".tmp") ) (vlax-for itm DIC (setq LDI (cons (vla-get-name itm) LDI))) (setq LDI (acad_strlsort LDI)) (if (= (_Getkword (quote ("n" "N" "y" "Y")) "N" "N" (strcat "\nCurrent Dimension Style \"" DMS "\" settings will be used. Select another Dimension Style [Yes/No] <No>: ")) "Y") (if (setq FDS (open FIL "w")) (progn (write-line (strcat "DimStyle:dialog{label=\"Dimension Style selection\";initial_focus=\"Dims\";:row{:boxed_row{label=\"Available Dimension Styles\";:list_box{key=\"Dims\";height=8;width=" (itoa (+ (apply (function max) (mapcar (function strlen) LDI)) 2)) ";}}:column{alignment=bottom;fixed_height=true;:button{label=\"&OK\";key=\"DoIt\";is_default=true;width=14;fixed_width=true;height=2;}:spacer{height=0.25;}:button{label=\"&Cancel\";key=\"Cancel\";is_cancel=true;width=14;fixed_width=true;height=2;}}}}" ) FDS ) (setq FDS (close FDS) DIA (load_dialog FIL) POS (itoa (vl-position DMS LDI)) ) (new_dialog "DimStyle" DIA) (start_list "Dims") (foreach el LDI (add_list el)) (end_list) (set_tile "Dims" POS) (action_tile "Dims" "(setq POS $value)") (action_tile "DoIt" "(done_dialog 1)") (action_tile "Cancel" "(done_dialog 0)") (setq SRT (start_dialog)) (unload_dialog DIA) (vl-file-delete FIL) (if (and (= SRT 1) (/= (vl-position DMS LDI) (atoi POS))) (progn (setq DSO (nth (atoi POS) LDI)) (vla-put-activedimstyle ACD (vla-item DIC DSO)) ) ) ) (alert (strcat "Unable to write data to folder \"" (vl-filename-directory FIL) "\". Current Dimension Style \"" DMS "\" settings will be used.")) ) ) (setq DMC (getvar "DIMCLRD") DMH (getvar "DIMTXT") DMY (getvar "DIMTXSTY") ) (initget 1) (setq PT1 (getpoint "\nLeader start point: ")) (initget 1) (setq PT2 (getpoint PT1 "\nLeader second point: ")) (grdraw PT1 PT2 (if (vl-position DMC (quote (0 256))) (vla-get-color (vla-item (vla-get-layers ACD) CLA)) DMC)) (initget 1) (setq PT3 (getpoint PT2 "\nX coordinate of the Leader last point: ") DIS (distance PT2 (list (car PT3) (cadr PT2) (caddr PT2))) PTE (polar PT2 0 DIS) PTW (polar PT2 pi DIS) RGT (< (car PT2) (car PT3)) ) (redraw) (entmake (append (_Common "LEADER") (list (cons 62 DMC) (quote (100 . "AcDbLeader")) (cons 3 (cond (DSO) (DMS))) (cons 10 PT1) (cons 10 PT2) (cons 10 (if RGT PTE PTW)) ) ) ) (if (and (setq TXT (getstring T "\nAnnotation text: ")) (vl-remove 32 (vl-string->list TXT)) ) (progn (setq BOX (textbox (list (cons 1 TXT) (cons 7 DMY) (cons 40 DMH))) RAD (fix (+ 0.5 (max 0.5 (* 0.9 DMH) (* 0.525 (distance (car BOX) (cadr BOX)))))) PT1 (if RGT (polar PTE 0 RAD) (polar PTW pi RAD)) ) (entmake (append (_Common "CIRCLE") (list (cons 62 DMC) (quote (100 . "AcDbCircle")) (cons 10 PT1) (cons 40 RAD) ) ) ) (entmake (append (_Common "TEXT") (list (cons 62 (getvar "DIMCLRT")) (quote (100 . "AcDbText")) (cons 10 PT1) (cons 40 DMH) (cons 1 TXT) (quote (50 . 0.)) (cons 41 (vla-get-width (vla-item (vla-get-textstyles ACD) DMY))) (quote (51 . 0.)) (cons 7 DMY) (quote (71 . 0)) (quote (72 . 1)) (cons 11 PT1) (quote (73 . 2)) ) ) ) ) ) (if DSO (vla-put-activedimstyle ACD (vla-item DIC DMS))) (vlax-release-object DIC) (vlax-release-object ACD) (princ) ) ;;C:LEADBBL

Sometimes it can be as simple as chain the correct sequence of commands, did not look very hard at code. Lots of code (c:offsec) (c:2)

An AcCmColor object is independent of the entity (graphical/non-graphical) to which it applies; hence, you can skip the testing for colour type altogether: (defun c:hn ( / e h n x ) (if (and (setq h (car (entsel "\nSelect hatch: "))) (progn (while (and (setq e (car (entsel "\nSelect text: "))) (not (and (= "TEXT" (cdr (assoc 0 (setq x (entget e))))) (snvalid (setq n (cdr (assoc 1 x)))) ) ) ) (princ "\nText not valid for use as a layer name.") ) e ) ) (vla-put-truecolor (vla-add (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) n) (vla-get-truecolor (vlax-ename->vla-object h)) ) ) (princ) )

(defun c:pp() (setq ssp (ssget '((0 . "LWPOLYLINE")))) (repeat (setq i (sslength ssp)) (setq p1 (ssname ssp (setq i (1- i))) a (assoc 10 (entget p1))) (entmake (list (cons 0 "INSERT") a (cons 2 "sample_block"))) ) ) Define a block named "sample_block", launch this lisp and select the polylines (all at once)

I looked at the SetCurrent.lsp and, by analogy, added two lines of code after (setq entity...) to textcalculator.lsp. Thanks to this, the program sets the current font size to the same as the font size of the selected object. (defun _Select ( msg / entity num dtext mtext ) (while (progn (setvar 'ERRNO 0) (setq entity (car (nentsel msg))) (setq entbl (entget entity)) (setvar "TextSize" (cdr (assoc 40 entbl))) I hope LeeMac will forgive me.

(defun c:bn ( / e p xtext ) (vl-load-com) (if (and (setq e (ssget '((0 . "INSERT")))) (setq e (vlax-ename->vla-object (ssname e 0))) (setq p (getpoint "\n Specify Point for Text: ")) ) (progn (setq xtext (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 10 (trans p 1 2)) (cons 1 (vlax-get-property e (if (vlax-property-available-p e 'effectivename) 'effectivename 'name))) (cons 50 (getvar 'VIEWTWIST)) (cons 41 1) (cons 51 0) (cons 71 0) (cons 72 1) (cons 11 (trans p 1 2)) (cons 100 "AcDbText") (cons 73 2)) ) ) ) ) (princ) ) how about like this ?

Hatched..... Eggs hatch..... I'll save this away - looks like a load of useful stuff in there

(defun c:interpol ( / acdoc *error* ss ssl index ent obj box ll ur lll url ss2 ss2l index2 ent2 obj2 elv2 interlist ) (vl-load-com) (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))) (defun *error* ( msg ) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\nError: " msg)) ) (vla-EndUndoMark acdoc) (princ) ) (vla-StartUndoMark acdoc) (if (setq ss (ssget '((0 . "LWPOLYLINE")))) (progn (setq ssl (sslength ss)) (setq index 0) (repeat ssl (setq ent (ssname ss index)) (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 (if (setq ss2 (ssget "C" lll url '((0 . "LWPOLYLINE")))) (progn (setq ss2l (sslength ss2)) (if (> ss2l 1) (progn (setq index2 0) (repeat ss2l (setq ent2 (ssname ss2 index2)) (if (/= ent ent2) (progn (setq obj2 (vlax-ename->vla-object ent2)) (setq elv2 (vlax-get-property obj2 'elevation)) (if (/= elv2 0) (vlax-put-property obj2 'elevation 0) ) (setq interlist (vlax-invoke obj 'intersectwith obj2 acextendnone)) (if (> (length interlist) 2) (vlax-put-property obj 'color 2) ) (if (/= elv2 0) (vlax-put-property obj2 'elevation elv2) ) ) (progn) ) (setq index2 (+ index2 1)) ) ) (progn ) ; ) ) (progn ) ) (setq index (+ index 1)) ) ) (progn) ) (vla-EndUndoMark acdoc) (princ) ) this try When selecting a line with "cp", a straight line area was not selected. i don't know before that difference "cp" and "c" so I switched to "c". then filter that ss2 with intersectwith. I'm not sure if leakage occurs this way. But it worked in the example.

; DentRepair - 2023.09.15 exceeds ; Dent repairs polyline segments with vertical and horizontal outlines outwards. ; If the length of one line segment is less than a certain value, it adjusted out to a wider side. (defun c:DentRepair ( / *error* acdoc ss ssl index ent obj clist cllen isclosed index2 p0 p1 p2 p3 linelength lineangle setlength tempclist1 tempclist2 temp1 temp2 temp1obj temp2obj temp1area temp2area stopper resultent ) (vl-load-com) (defun *error* (msg) (if (/= msg "Function cancelled") (princ (strcat "\nError: " msg)) ) (vla-EndUndoMark acdoc) (princ) ) ;; Group by Number - Lee Mac ;; Groups a list 'l' into a list of lists, each of max length 'n' (defun LM:group<n ( l n ) (if l (LM:group<n-sub (cons nil l) n n)) ) (defun LM:group<n-sub ( l m n ) (if (and (cdr l) (< 0 n)) (LM:group<n-sub (cons (cons (cadr l) (car l)) (cddr l)) m (1- n)) (cons (reverse (car l)) (LM:group<n (cdr l) m)) ) ) ;;---------------------=={ Subst Nth }==----------------------;; ;; ;; ;; Substitutes an item at the nth position in a list. ;; ;;------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; a - item to substitute ;; ;; n - position in list to make the substitution ;; ;; l - list in which to make the substitution ;; ;;------------------------------------------------------------;; ;; Returns: Resultant list following the substitution ;; ;;------------------------------------------------------------;; (defun LM:SubstNth ( a n l ) (if l (if (zerop n) (cons a (cdr l)) (cons (car l) (LM:SubstNth a (1- n) (cdr l))) ) ) ) ;; Unique - Lee Mac ;; Returns a list with duplicate elements removed. (defun LM:Unique ( l ) (if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l))))) ) ; degree to radian (defun dtr (a) (setq x (* pi (/ a 180.0))) ) ; radian to degree (defun rtd (a) (setq x (/ (* a 180) pi)) ) (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) ) ) ) (setq acdoc (vla-get-ActiveDocument (vlax-get-ACAD-Object))) (vla-StartUndoMark acdoc) (setq setlength (getreal "\n Input Minimum Segment Value (Space Bar = 1.5): ")) ; can edit this value (if (= setlength nil) (setq setlength 1.5) (setq setlength (abs setlength)) ) (setq ss (ssget '((0 . "LWPOLYLINE")))) (setq ssl (sslength ss)) (setq index 0) (repeat ssl (setq ent (ssname ss index)) (setq obj (vlax-ename->vla-object ent)) (setq clist (vlax-safearray->list (vlax-variant-value (vlax-get-property obj 'coordinates)))) (setq cllen (length clist)) (setq isclosed (vlax-get-property obj 'closed)) ;(princ "\n isclosed? ") ;(princ isclosed) (if (= isclosed :vlax-true) (progn (setq clist (append clist (list (car clist) (cadr clist)))) ) (progn (if (and (= (car clist) (nth (- cllen 2) clist)) (= (cadr clist) (nth (- cllen 1) clist))) (progn) (progn (setq clist (append clist (list (car clist) (cadr clist)))) ) ) ) ) (setq clist (lm:unique (lm:group<n clist 2))) ;(princ "\n clist - ") ;(princ clist) (setq cllen (length clist)) (setq index2 0) (if (>= cllen 4) (progn (repeat cllen (if (and (/= index2 0) (/= resultent nil)) (entdel resultent) ) (setq p1 (nth index2 clist)) (if (= (- cllen 1) index2) (setq p2 (nth 0 clist)) (setq p2 (nth (+ index2 1) clist)) ) (if (= index2 0) (setq p0 (last clist)) (setq p0 (nth (- index2 1) clist)) ) (if (<= index2 (- cllen 3)) (setq p3 (nth (+ index2 2) clist)) (setq p3 (nth (- (+ index2 2) cllen) clist)) ) (setq linelength (distance p1 p2)) ;(princ "\n linelength - ") ;(princ linelength) (setq lineangle (rtd (angle p1 p2))) ;(princ "\n lineangle - ") ;(princ lineangle) (setq tempclist1 '()) (setq tempclist2 '()) (if (>= linelength setlength) (progn ;(if (or (= lineangle 0) (= lineangle 90) (= lineangle 180) (= lineangle 270) (= lineangle 360)) ; (progn) ; (progn) ;) ) (progn (cond ((or (= (rtos lineangle 2 0) "0") (= (rtos lineangle 2 0) "180")) ;horizontal line (setq tempclist1 (LM:SubstNth (list (car p1) (cadr p0)) index2 clist)) (setq tempclist1 (LM:SubstNth (list (car p2) (cadr p0)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist1)) (setq tempclist2 (LM:SubstNth (list (car p1) (cadr p3)) index2 clist)) (setq tempclist2 (LM:SubstNth (list (car p2) (cadr p3)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist2)) ) ((or (= (rtos lineangle 2 0) "90") (= (rtos lineangle 2 0) "270") (= (rtos lineangle 2 0) "360")) ;verical line (setq tempclist1 (LM:SubstNth (list (car p0) (cadr p1)) index2 clist)) (setq tempclist1 (LM:SubstNth (list (car p0) (cadr p2)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist1)) (setq tempclist2 (LM:SubstNth (list (car p3) (cadr p1)) index2 clist)) (setq tempclist2 (LM:SubstNth (list (car p3) (cadr p2)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist2)) ) (t (setq tempclist1 clist) (setq tempclist2 clist) ) ) ;(princ "\n tempclist1 - ") ;(princ tempclist1) (setq temp1 (lwpolybylist tempclist1 1)) ;(princ "\n tempclist2 - ") ;(princ tempclist2) (setq temp2 (lwpolybylist tempclist2 1)) (setq temp1obj (vlax-ename->vla-object temp1)) (setq temp2obj (vlax-ename->vla-object temp2)) (setq temp1area (vla-get-area temp1obj)) (setq temp2area (vla-get-area temp2obj)) (if (>= temp1area temp2area) (setq clist tempclist1) (setq clist tempclist2) ) (entdel temp1) (entdel temp2) ) ) (setq resultent (lwpolybylist clist 1)) ;(setq stopper (getstring "\n continue ? : ")) ;(princ "\n index2 - ") ;(princ index2) ;(princ " / cllen - ") ;(princ cllen) (setq index2 (+ index2 1)) ) ) (progn (princ "\n not enough vertices. (less then 4)") ) ) ;(setq stopper (getstring "\n continue ? : ")) (setq index (+ index 1)) ) (vla-EndUndoMark acdoc) (princ) ) You can start with this. command : DENTREPAIR Below GIF is for example (with pauses to show the calculation step by step) + This isn't a perfect solution. The steps in this routine are... 1. Measure the length of each line segment of the polyline. 2. If it is less than the set value (=1.5), 3. determine whether the line segment is vertical or horizontal, 4. Get the X (for a vertical line) or Y (for a horizontal line) value of both nodes adjacent to the line segment. 5. Replace the values in the original coordinate list 6. After creating each polyline, Compare each area and select the larger one. 7. Repeat this by looping each line segment. It is useful when there is a large fixed outline with small cracks, but the leakage point of this logic is if it is sharp, that part can be omitted. -> sharp means If there is a line segment that protrudes to the outermost edge with a value smaller than the entered value of 1.5 This is because the two neighboring points of this sharp point are located in a direction where the area is smaller than the original outline. In that case, the original point should be included in the comparison to find the one with the largest area among the 3 cases. If the original wins, this case is difficult, picked line segment is not modified, but both neighboring points need to be modified. It is difficult to solve this problem by simply running a forward loop. Even after modifying the neighboring points on both sides, need to check whether the rules are correct retrieve the coordinate list again, and the node numbers may also be messed up. Of course, this may be difficult only for me. Because there are many smart people. so I created a routine to create a new line above it. not modifying original line. It would be better to check manually.

(defun c:pp() (setq ssp (ssget "X" (list '(0 . "LWPOLYLINE")))) (repeat (setq i (sslength ssp)) (setq pl1 (ssname ssp (setq i (1- i))) el1 (entget pl1) points (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) el1)) ) (cond ((= 3 (length points)) (setq points (if (< (distance (car points) (cadr points))(distance (cadr points) (caddr points)))(reverse points)points)))) (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(8 . "0") '(90 . 3) '(70 . 0) '(38 . 0) '(67 . 0) (cons 10 (car points)) (cons 10 (cadr points)) (cons 10 (mapcar '- (cadr points) (mapcar '- (caddr points)(cadr points)))))) ) ) Does this work for you? It draws new polylines on the layer "0". Change to suit your needs... *** editing *** Should the original polyline have been deleted? If so, please insert at the end of the loop: (entdel pl1)

I don't use script writer much, maybe a LISP could work to do what you want - make a LISP to do what you want with a single drawing and then run it via scriptwriter Or perhaps you might need to use: (setvar "tilemode" 1) (command "zoom" "E")

I'll often prefix a variable with something, perhaps in this case something like Arr_ (for example Arr_Angle) just to be sure that it can never be confused with a function and still retain some sort of description just to avoid this

This will be enough and should work, but not tested... (defun c:get_pline_data (/ pline_ent division_distance road_start_x road_end_x cur_x point ) ;;; res_y - global variable (setq pline_ent (car (entsel "\nSelect pline"))) (setq division_distance 50) ; should be 1 unit but for this example it is set to 50 (setq road_start_x (car (setq point (vlax-curve-getstartpoint pline_ent)))) (setq road_end_x (car (vlax-curve-getendpoint pline_ent))) (setq cur_x road_start_x) (while (<= cur_x road_end_x) (setq point (vlax-curve-getclosestpointtoprojection pline_ent point (list 0.0 1.0 0.0))) (setq res_y (cons (cadr point) res_y)) (setq cur_x (+ cur_x division_distance)) (setq point (mapcar '+ (list division_distance 0.0 0.0) point)) ) (princ) ) HTH. M.R.

Try this. I'm not sure I caught all possible errors, please test it in different scenarios. Ah yes, I took the lazy route of making sure the range value is always a 2-dimensional array. When the range is a single cell, the Value property returns its contents. (defun c:DCOL ( / variantvalue msg excel sheet range rows lst) (defun VariantValue (x / var) (cond ((not x) nil) ((eq (type x) 'safearray) (VariantValue (vlax-safearray->list x)) ) ((eq (type x) 'variant) (if (vl-catch-all-error-p (setq var (vl-catch-all-apply 'vlax-variant-value (list x))) ) nil (VariantValue var) ) ) ((listp x) (mapcar 'VariantValue x)) (T x) ) ) (if (and (setq msg "\nExcel is not open.") (setq excel (vlax-get-object "Excel.Application")) (setq msg "\nNo active sheet found.") (setq sheet (vlax-get excel "ActiveSheet")) (setq range (vlax-get sheet "UsedRange")) (setq rows (vlax-get (vlax-get range "Rows") "Count")) (setq range (vlax-get-property sheet "Range" (strcat "D1:D" (itoa rows)))) (setq msg "\nD column is empty.") (setq lst (variantValue (vlax-get-property range "value"))) ) (progn (if (listp lst) (setq lst (reverse lst)) (setq lst (list (list lst))) ) (while (and lst (not (caar lst))) (setq lst (cdr lst)) ) (if lst (progn (princ "\nD") (princ (length lst)) (princ " - ") (princ (caar lst)) ) (princ "\nD column is empty.") ) ) (if msg (princ msg)) ) (princ) )

Try this one, might work - it does in AutoCAD (defun c:Hatch2Poly ( / acount ss APoly MyPoly VertexList SplitHere MyWidth1 MyWidth2 MyWidth pt MyLayer thisdrawing vars MyCol MyLay) ;;https://www.cadtutor.net/forum/topic/24364-vertices-of-a-polyline/ (defun mAssoc ( key lst / l x ) ;Get association list entries for 'key' value (foreach x lst (if (= key (car x)) (setq l (cons (cdr x) l)) ) ; end if ) ; end foreach (reverse l) ) ; end defun (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object))) ; get file information (vla-EndUndoMark thisdrawing) ; clear undo marker (vla-startundomark thisdrawing) ; Start Undo marker (setq acount 0) ; a counter (princ "\n Select Hatches : ") ; Select Hatches message (setq ss (ssget '((0 . "HATCH")))) ; Select hatches ;;3 lines to disable command prompts and echo (setq vars '("CMDECHO")) (setq old (mapcar 'getvar vars)) ;;get old variables (mapcar 'setvar vars '(0)) ;;set variables to new (while (< acount (sslength ss)) ; Loop therough selection set (setq Apoly nil MyPoly nil VertexList nil SplitHere nil MyWidth1 nil MyWidth2 nil MyWidth nil pt nil MyCol nil MyLay nil ) ; reset variables - something funny happened (command "-hatchedit" (ssname ss acount) "B" "P" "Y") ; recreate hatch boundary (setq MyLay (assoc 8 (entget (ssname ss acount)) )) ; get hatch layer (setq MyCol (assoc 62 (entget (ssname ss acount)) )) ; get hatch colour (setq APoly (entlast)) ; entity name for the boundary (setq MyPoly (entget APoly)) ; entity assoc. list for boundary (setq MyPoly (subst (cons 70 0) (assoc 70 MyPoly) MyPoly )) ;; Make as open polyline (setq MyPoly (subst MyLay (assoc 8 MyPoly) MyPoly )) ;; Change Layer (entmod MyPoly)(entupd APoly) (setq MyPoly (entget APoly)) (if (= (cdr MyCol) nil) () ;; If hatch colour 'by-xyz' or not set (vla-put-Color (vlax-ename->vla-object APoly) (cdr MyCol) ) ;; Change Colour ) (setq VertexList (massoc 10 MyPoly)) ; get list of verticies for boundary (setq SplitHere (nth (/ (length VertexList) 2) VertexList)) ; split boundary coordinates ;;NOTE IF HATCH HAS UNEVEN NUMBER OF VERTICIES THIS COULD GO WEIRD (command "._break" APoly SplitHere SplitHere) ; Break the boundary at split (setq Len1 (length (mAssoc 10 (entget (entlast) )) ) ) ; verticies of last ent (setq Len2 (length (mAssoc 10 (entget APoly)) ) ) ; verticies of last ent (if (< Len1 Len2) (entdel (entlast)) (progn (entdel APoly) (setq Apoly (entlast)) ) ) (setq MyPOly (entget Apoly)) (setq VertexList (massoc 10 (entget APoly) )) ; get retained vertex list (setq MyWidth1 (distance (nth 1 VertexList) (nth 0 VertexList) )) ; get last segment widths (setq MyWidth2 (distance (nth 1 (reverse VertexList)) (nth 0 (reverse VertexList)) )) (if (< MyWidth1 MyWidth2) ; work out where to split off remaining hatch end (setq SplitHere (nth 1 VertexList) MyWidth MyWidth1 ; and the hatch width pt (nth 0 vertexlist) ) ; end setq (setq SplitHere (nth 1 (reverse VertexList)) MyWidth MyWidth2 pt (nth 0 (reverse vertexlist)) ) ; end setq ) ; end if (command "._break" APoly SplitHere SplitHere) ; split off and delte the end marker (if (< MyWidth1 MyWidth2) (progn (entdel APoly) (setq APoly (entlast)) ) ; end progn (entdel (entlast)) ) ; end if (entdel (ssname ss acount)) ; delete the hatch (command "offset" (/ MyWidth 2) APoly pt "") (entdel APoly) (command "._pedit" (entlast) "W" MyWidth "") (setq acount (+ acount 1)) ; increase counter ) ; end while ; end of while loop (mapcar 'setvar vars old) (vla-EndUndoMark thisdrawing) ; end undo marker (princ) );End

I will typically draw and dimension in model space. However, dimensioning is done through the viewports with the 'DIMSCALE' set to '0'. This will allow the current DIMSTYLE to be scaled to the viewport scale. No need to create multiple scales of the same DIMSTYLE.

how about to read this

Yup, we get COS and SIN, and have to make up the rest, search arccos, acos or suimilar

There are a lot of ways to work it out. If it is a standard AutoCAD command then the help and AutoDESK help will tell you what it all does. Some commands can be used from the command line - and they are ideal for LISP. Some commands can only be used via a dialogue box, which can be useful but you can't automate that part. Some commands can be run both ways, command line and dialogue box - command line is good for automation. typically if a command can be run both ways you can get it to run via the command line with a '-' prefix. For example -plot will step through plotting via the command line. To use a command like that you want (command "-yourcommandhere-" -andthing else that is needed here). Yourcommandhere is the command name and any '-' prefx necessary to make it work via the command line. Anything after that is what is needed to make the command work, and you can work out what is needed by running the command in CAD and noting down everything you type, including 'enter'. Type that into the LISP as you go - you;ll pick it up quick enough. One tip that might be useful is if you need a user input you can use pause instead of some information To make things worse there are other ways to do everything, possibly quicker than 'command', but you'll get to that soon enough. I think most of us started as you are doing and copying from the command line to a LISP. In your example, I'll type in 'circle' in the command line and it returns 'specify centre point for circle or [3P 2P TTR (tan tan radius) ]' I'll pick a point, or enter a point 0,0 - now this is text so when I make up the LISP later I'll remember to put it in " " 'Specify radius of circle or diameter' So now I can enter a point as before, or a value, or even pick a point and that is the command complete So make that into a line for a LISP: (command to start to tell the LISP what is about to happen "0,0" - my centre point pause - I decided I wanted the user to pick a point on the radius. In your example the "3,3" is a point, a point on the circumference to select the radius (command "circle" "0,0" pause) Might be that you have a centre point already selected, you can replace anything in the command with a variable. Try these 2 lines: (setq pt (getpoint "Select circle centre point") ; pt is a variable (; on code means comment afterwards) (princ pt) ; princ means display in the command line (command "circle" pt 5) ; make a circle centred on pt with a radius of 5

It is easy to know the angle of a line, but it is difficult to know the angle of a polyline because it has many nodes. I haven't read all of them, but his code has very clear structure, so, It can be applied with very little modifications. approx. 403 line, you have to add "ANGLE" (setq tStr (strcat "{\\C4;" (dxf 0 iLst) "}")) (foreach prop '( ANGLE LAYER COLOR LINETYPE LINEWEIGHT even if put only these 5 characters then test it, the radian angle will appear. and if you want degree, you have to add these 4 lines ( (eq prop 'ANGLE) (vl-princ-to-string (* 180 (/ (vlax-get-property iObj prop) pi))) ) in approx. 450 line, inside of (cond~~) like this (cond ( (eq prop 'COLOR) (_GetColour iLst) ) ( (eq prop 'ANGLE) (vl-princ-to-string (* 180 (/ (vlax-get-property iObj prop) pi))) ) ( (vl-position prop '(DISPLAYLOCKED CLOSED)) (_Stringify (vlax-get-property iObj prop)) )

Ok been answered so many times. Of recent and I need to finish it is what you want. Its done already but adding now the visibility. Its a case of making a list of the blocks getting name or effectivename, get visibility then sorting and counting. To do the answer correctly need a dwg showing the table and blocks, as the way to go is to make a custom table style that matches your dwg. Much easier do it one go rather than repeated changes. Need Visibility name.

Would seem to be 2 different tubes you are referring to. Is that the only view you have? Are you knowledgeable in steel shapes and dimensions?

Hi @Steven P I looked but didn't find any... Thanks, aridzv

Tested the code by @Emmanuel Delay and it's working perfectly fine on my side

Spent 10 minutes seeing what I missed - should be this line instead: (LM:vl-setattributevalue bobj "Order" (rtos (nth 2 blk)) )

Change this line (setq lst (cons (list ord itm qty) lst)) in terms of the item order. This will fix the data cells, you need to also do the headings. '("ORDER" "QUANTITY" "ITEM_DESCRIPTION") '(ord qty itm) Hopefully works not tested.

Option selection is this part? (setq option (getstring prompt options '("R" "L" "C" "A"))) The getstring function is the wrong format, it should be (getstring [cr] [msg]) Where [cr] is T or nothing to allow the user to enter spaces (in the case of T) or if a space acts like a carriage return [msg] would be prompt in your example (https://help.autodesk.com/view/ACD/2015/ENU/?guid=GUID-B139EFBD-74B7-4276-B422-D2186F7D8D0A) If you want to use options look at initget as a line immediately before the getstring line - which should be replaced by getkword (http://docs.autodesk.com/ACD/2013/ENU/index.html?url=files/GUID-9ED8841B-5C1D-4B3F-9F3B-84A4408A6BBF.htm,topicNumber=d30e618800) (initget "R L C A") (getkword (strcat prompt)) and this from Lee Mac will test that you have selected a valid input: ;;https://www.cadtutor.net/forum/topic/6451-initget-amp-getkword/ (and (not (initget 1 "R L C A")) (setq option (getkword prompt)))

Hi You can try this for move text to mleader (vl-load-com) (defun make_mlead (pt str lay / tmp ptlst arr nw_obj) (initget 9) (setq tmp (getpoint (trans pt 0 1) "\nLeader position: ") ptlst (append pt (polar pt (angle pt (trans tmp 1 0)) (distance pt (trans tmp 1 0)))) arr (vlax-make-safearray vlax-vbdouble (cons 0 (- (length ptlst) 1))) ) (vlax-safearray-fill arr ptlst) (setq nw_obj (vla-addMLeader Space (vlax-make-variant arr) 0)) (vla-put-contenttype nw_obj acMTextContent) (vla-put-textstring nw_obj str) (vla-put-layer nw_obj lay) (vla-put-ArrowheadSize nw_obj (* (getvar "TEXTSIZE") 0.5)) (vla-put-TextHeight nw_obj (getvar "TEXTSIZE")) (if (> (car pt) (car (trans tmp 1 0))) (progn (vla-SetDogLegDirection nw_obj 0 (vlax-3D-point '(-1.0 0.0 0.0))) (vla-put-TextJustify nw_obj acAttachmentPointMiddleRight) (vla-setLeaderLineVertices nw_obj 0 (vlax-make-variant arr)) ) (vla-put-TextJustify nw_obj acAttachmentPointMiddleLeft) ) (vla-update nw_obj) ) (vl-load-com) (defun c:movetxt2leader ( / js htx AcDoc Space ent pt ss dxf_ent txt lay) (princ "\nSelect polyline.") (while (not (setq js (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))) (initget 6) (setq htx (getdist (getvar "VIEWCTR") (strcat "\nGive text size <" (rtos (getvar "TEXTSIZE")) ">: "))) (if htx (setvar "TEXTSIZE" htx)) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) Space (if (= 1 (getvar "CVPORT")) (vla-get-PaperSpace AcDoc) (vla-get-ModelSpace AcDoc) ) ) (vla-startundomark AcDoc) (setq ent (ssname js 0) pr -1) (redraw ent 3) (repeat (fix (vlax-curve-getEndParam ent)) (setq pt (vlax-curve-GetPointAtParam ent (setq pr (1+ pr))) ss (ssget "_C" pt (mapcar '+ pt (list (getvar "PDSIZE") (getvar "PDSIZE") (getvar "PDSIZE"))) '((0 . "TEXT")) ) ) (cond (ss (setq dxf_ent (entget (ssname ss 0)) txt (cdr (assoc 1 dxf_ent)) lay (cdr (assoc 8 dxf_ent)) ) (make_mlead pt txt lay) (entdel (ssname ss 0)) ) ) ) (redraw ent 4) (vla-regen AcDoc acactiveviewport) (vla-endundomark AcDoc) (prin1) )

Can this be achieved ?. It can be very practical when pipes needs to be denser near windows and outer walls. p.s. is there an easy way to modify existing one ?

You can put (command) in your script file to cancel a command.