Jump to content

Leaderboard

  1. BIGAL

    BIGAL

    Trusted Member


    • Points

      46

    • Posts

      18,026


  2. Steven P

    Steven P

    Trusted Member


    • Points

      33

    • Posts

      2,251


  3. Jonathan Handojo

    Jonathan Handojo

    Community Member


    • Points

      24

    • Posts

      666


  4. alanjt

    alanjt

    Trusted Member


    • Points

      19

    • Posts

      6,462


Popular Content

Showing content with the highest reputation since 02/19/2024 in all areas

  1. This only assumes the horizontal and vertical lines are drawn in UCS, and not WCS: (defun c:vmirror nil (OnePointMirror '(00 10 00))) (defun c:hmirror nil (OnePointMirror '(10 00 00))) (defun OnePointMirror (dir / ss pt) (and (setq ss (ssget "_:L")) (setq pt (getpoint "\nSpecify base point <exit>: ")) (command "_mirror" ss "" "_non" pt "_non" (mapcar '+ dir pt) "No") ;; <--- Change to Yes to delete source object, or \\ to prompt user. (while (not (zerop (getvar "cmdactive"))) (command "")) ) (princ) ) And while this may be off the OP, this might be worth looking at as well: Quick Mirror.
    4 points
  2. Usually fonts follow the same chr # but different languages or a custom font might not be the right number you can use this to find the corrrect # ;;----------------------------------------------------------------------------;; ;; Output Character ASCii number table (defun C:text_table (/ vars vals base i c tx base_n) (setq vars '(snapmode osmode cmdecho ATTDIA ATTREQ LUPREC) ;list of variables vals (mapcar 'getvar vars) ;store old values ) (mapcar 'setvar vars '(0 0 0 0 1 0)) ;set new values (setq base (getpoint "\nEnter Starting Point :") i 0 c 0 n (/ (getvar 'textsize) 8) H (getvar 'textsize) ) (while (< i 1000) (setq tx (strcat (AT:NumFix (itoa i) 4) " = " (chr i)) base_n (list (+ (car base) (* (fix (* (/ c 25) n)) 100)) (- (cadr base) (* 20 (* c n)))) ) (entmake (list '(0 . "TEXT") (cons 8 (getvar 'clayer)) (cons 10 base_n) (cons 40 H) (cons 1 tx) (cons 7 (getvar 'textstyle)) ) ) (setq i (1+ i)) (setq c (1+ c)) (if (eq c 25) ;simple counter to step over (progn (setq base (polar base 0 3)) (setq c 0) ) ) ) (mapcar 'setvar vars vals) ;restore old values (princ) ) (defun AT:NumFix (s n) ;; Fix number string with leading zeros ;; s - Number string to fix ;; n - Number of characters for final string ;; Alan J. Thompson, 10.29.09 ;; (AT:NumFix i 3) i= 1 = 001 (if (< (strlen s) n) (AT:NumFix (strcat "0" s) n) s ) )
    3 points
  3. and \U+00B2 for squared or \U+00B3 for cubed as an alternative to Alt+ ("\U+.... " works better in LISP) Can also use (chr 178) and (chr 179) ... which is why LISP is brilliant - so many ways to do the same thing! "\n Area = " (rtos a 2 2) " m\U+00B2" "\n Area = " (rtos a 2 2) " m " (chr 178)
    3 points
  4. Something I was playing around with a while back. I use it form time to time. Made a little update yesterday and thought I'd add it here. Will allow you to select a group of objects and store them for later copying. This objects are stored in a global variable and do not have anything to do with the Clipboard. Once you store the objects, you can continue performing any normal functions and when you are ready to have those stored objects to place somewhere else, just execute the command. Call with Copystored or CS Sorry for the choppy video, I had to cut the frames to keep file size down (not sure what's going on with Camtasia). ;;; ------------------------------------------------------------------------ ;;; CopyStored.lsp v1.3 ;;; ;;; Copyright© 08.18.09 ;;; Alan J. Thompson (alanjt) ;;; ;;; Permission to use, copy, modify, and distribute this software ;;; for any purpose and without fee is hereby granted, provided ;;; that the above copyright notice appears in all copies and ;;; that both that copyright notice and the limited warranty and ;;; restricted rights notice below appear in all supporting ;;; documentation. ;;; ;;; The following program(s) are provided "as is" and with all faults. ;;; Alan J. Thompson DOES NOT warrant that the operation of the program(s) ;;; will be uninterrupted and/or error free. ;;; ;;; Allows user to select object(s) for copying (uses first object in ;;; selection for insertion point or specified point) and stores ;;; selection set and insertion point for later usage. ;;; ;;; Express Tools "acet-ss-drag-move" subroutine required. ;;; ;;; Revision History: ;;; ;;; v1.1 (09.29.09) 1. Changed copy method. ;;; 2. Updated error handler ;;; 3. Added AT:SS->List subroutine. ;;; ;;; v1.2 (12.15.09) 1. Updated to account for non WCS (oversite). ;;; ;;; v1.3 (02.23.10) 1. Added check if "acet-ss-drag-move" is loaded. ;;; 2. Added option to specify copy base point. ;;; ;;; ------------------------------------------------------------------------ CopyStored.lsp
    3 points
  5. I believe any command that is built-in to AutoCAD is proprietary product and cannot be disclosed to the public. However, some built-in AutoLISP commands, for example, the Express Tools of AutoCAD, are all saved in your local computer and can be viewed anytime under your directory "C:\Program Files\Autodesk\AutoCAD 2021\Express" (assuming your CAD version is 2021). Anyways, that aside, just as the previous comment suggested, finding a point that overlaps with basically any curve is relatively easy. But finding the overlaps of two curves, even between two polylines as shown below, is not easy.
    3 points
  6. Or if you need it to be something other than 45 degrees: (polar '(0 0 0) (cvunit <your_angle_in_degrees> "degrees" "radians") 10)
    3 points
  7. 20 19 is what your looking for, I dont know why 2 values, a min max thing, as suggested in code tested with 145 144, its number of characters in the edit box. You can make each edit box a different size like 4 3 for say 1-10 then 30 29 for a big string. A further hint if you set a variable to say a number you can use that variable in the lst (setq lst (list "Please enter values " "Enter client name: " 20 19 " " "Enter location: " 20 19 " " "Enter crop: " 20 19 "10" "Enter date code: " 20 19 " " "Enter acres: " 20 19 " " "Enter plant count: " 20 19 " " "Enter application rate: " 20 19 "20")) (if (= apprate nil)(setq apprate 20)) (setq lst (list "Please enter values " "Enter client name: " 20 19 " " "Enter location: " 20 19 " " "Enter crop: " 20 19 " " "Enter date code: " 20 19 " " "Enter acres: " 20 19 " " "Enter plant count: " 20 19 " " "Enter application rate: " 20 19 (rtos apprate 2 0)))
    2 points
  8. A bit on the longer side, but maybe this: (defun c:fo ( / a c dir ent i pt r ss sstb txt) (cond ( (not (setq sstb (ssget "_X" (append (list '(0 . "ACAD_TABLE") '(-4 . "<OR") ) (mapcar '(lambda (a) (cons 8 (LM:escapewildcards a)) ) (JH:GetLockedFrozenOffLayers nil nil nil nil) ) (list '(-4 . "OR>") (cons 410 (if (= (getvar "cvport") 1) (getvar "ctab") "Model")) ) ) ) ) ) (princ (if (= (getvar "cvport") 1) "\nNo tables in current paper space." "\nNo tables in model space.")) ) ( (not (setq ss (ssget '((0 . "TEXT,MTEXT")))))) ( (setq sstb (JH:selset-to-list-vla sstb)) (repeat (setq i (sslength ss)) (setq i (1- i) ent (ssname ss i) txt (cons (vla-get-TextString (vlax-ename->vla-object ent)) txt) ) ) (setq txt (LM:lst->str txt " ")) (while (progn (setvar "errno" 0) (initget "Exit") (setq pt (getpoint "\nSpecify table cell [Exit] <exit>: ")) (cond ( (= (getvar "errno") 7) (princ "\nNothing selected.")) ( (member pt '("Exit" nil)) nil) ( (progn (setq pt (vlax-3d-point (trans pt 1 0)) dir (vlax-3d-point (getvar "viewdir"))) (vl-some (function (lambda (a) (if (eq (vla-hittest a pt dir 'r 'c) :vlax-true) (progn (if (not (zerop (logand accellstatecontentlocked (vla-getcellstate a r c)))) (princ "\nTable cell is locked.") (vla-settext a r c txt) ) t ) ) ) ) sstb ) ) ) ( (princ "\nNo table cell detected.")) ) ) ) ) ) ) ;; JH:GetLockedFrozenLayers --> Jonathan Handojo ;; Gets a list of layers that are locked and/or frozen. ;; lck - T to get locked layers, nil to get unlocked layers ;; frz - T to get frozen layers, nil to get thawed layers ;; off - T to get 'off' layers, nil to get 'on' layers ;; xref - T to include xref, nil to exclude xref (defun JH:GetLockedFrozenOffLayers (lck frz off xref / nm nx rtn) (while (setq nx (tblnext "layer" (null nx))) (setq nm (cdr (assoc 2 nx))) (if (not (and (not xref) (wcmatch nm "*|*"))) (if (and (or (and lck (= 4 (logand 4 (cdr (assoc 70 nx))))) (and (not lck) (zerop (logand 4 (cdr (assoc 70 nx))))) ) (or (and frz (= 1 (logand 1 (cdr (assoc 70 nx))))) (and (not frz) (zerop (logand 1 (cdr (assoc 70 nx))))) ) (or (and off (minusp (cdr (assoc 62 nx)))) (and (not off) (> (cdr (assoc 62 nx)) 0)) ) ) (setq rtn (cons nm rtn)) ) ) ) (reverse rtn) ) ;; JH:selset-to-list-vla --> Jonathan Handojo ;; Returns a list of vla objects from a selection set ;; ss - selection set (defun JH:selset-to-list-vla (ss / rtn i) (if ss (repeat (setq i (sslength ss)) (setq rtn (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) rtn)) ) ) ) ;; Escape Wildcards - Lee Mac ;; Escapes wildcard special characters in a supplied string (defun LM:escapewildcards ( str ) (vl-list->string (apply 'append (mapcar '(lambda ( c ) (if (member c '(35 64 46 42 63 126 91 93 45 44)) (list 96 c) (list c) ) ) (vl-string->list str) ) ) ) ) ;; List to String - Lee Mac ;; Concatenates each string in a supplied list, separated by a given delimiter ;; lst - [lst] List of strings to concatenate ;; del - [str] Delimiter string to separate each item (defun LM:lst->str ( lst del / str ) (setq str (car lst)) (foreach itm (cdr lst) (setq str (strcat str del itm))) str ) The selected text will be concatenated together, using spaces. You may need to select the text by picking instead of window or crossing to get the text in order.
    2 points
  9. (getstring T "Enter Clients Name: ")
    2 points
  10. Something like this? (defun c:pp( / ) (setq txtHeight 11 a8 (cons 8 (getvar "clayer"))) (setq p (trans (getpoint "select point") 1 0)) (entmake (list '(0 . "POINT") (cons 10 p) a8)) (entmake (list '(0 . "TEXT") (cons 1 (rtos (last p))) (cons 10 p) a8 (cons 40 txtHeight))) )
    2 points
  11. @Steven P, so NOTEPAD demand more from the user, I use VLIDE since my first LSP, and debug is easiest, and I can run line by line to test it.
    2 points
  12. This usually gets me in trouble now since im not using lisp on a daily basis anymore. I suggest notepad++ recognizes lisp code structure so things are color coded and its easier to hunt down errors. if you want to go off the deep end get Visual stuido Code. doe everything notpad++ does and alot more like specific addins and autocomplete syntax. if you have BrisCAD 18 or higher they have a build in coder called blade.
    2 points
  13. I think most of us started with an idea "How do I do this quicker, more accurately or more consistently" and start from there, building up knowledge as you create LISPs to do what you want to do. I use a lot of online resources, this forum is great by the way. For learning don't ask for a complete LISP since you are likely just to save that and not learn how it does what it does, but ask for small portions of code. Use these codes in your projects Apart from here, there is another forum, TheSwamp which is also good. Online: AfraLisp has a lot of good examples, Lee Mac has a lot of small functions which can be used to build larger functions or as stand alone functions AutoDesk has online help for all the functions As for creating a LISP, it is a text based language and you can use any simple text editor to write the code as the simplest form First off though I'd look on Lee Macs website for his tutorials on writing and running LISPs
    2 points
  14. Something like this: Linetype is the line name "TRAZOS" (I don't think it i case sensitive) acad.lin is the line definition file that the line type is described in - you might need to find out what that is and replace the text below assumes here that the file 'acad.lin' is in trusted files location (defun MakeLoadLines ( linetype / ) (if (tblsearch "LTYPE" linetype) ;;Check if linetype is loaded (command ".-linetype" "_Load" linetype "acad.lin" "_Yes" "") ;; reload it anyway. Replace with (progn ) for no reloading (command ".-linetype" "_Load" linetype "acad.lin" "") ;; otherwise load it ) (princ) )
    2 points
  15. See this page. You can open your list of aliases on the Manage ribbon or with the ai_editcustfile command, which allows you to edit your acad.pgp file. Or you can open the file directly. I thought there was an option on the customization menu to edit the aliases, but apparently not. Let us know if you need more help.
    2 points
  16. As Mhupp suggested use BEDIT on the block, and click on attribute have properties open can change Tagname there, then do Bclose to save. You may need to attsync the block to update the redefinition of the block. Yes can do a get attribute1 change, then get next attribute, but to much effort compared to bedit.
    2 points
  17. I think you can do that in block editor. either that or explode the block rename the attribute and then remake the block
    2 points
  18. I too deal with a lot of files each day where the radii are broken into many small straight lines. I think one of my clients creates the Rads in their Cad environment using splines, and then converts them into polylines which makes them change to these small line segments. Please keep up the great work Steven P, this appears to have been progressing nicely, and I can't wit to see the final result
    2 points
  19. A start with this? (defun def_bulg_pl (ls lb / l_rad) (setq ls (append ls (list (car ls)))) (while (cadr ls) (if (zerop (car lb)) (setq l_rad (cons (car lb) l_rad)) (setq l_rad (cons (/ (distance (car ls) (cadr ls)) (sin (* 2.0 (atan (abs (car lb))))) 2.0) l_rad)) ) (setq ls (cdr ls) lb (cdr lb)) ) l_rad ) (defun c:test ( / sspl typent lst l_bulg e_next dxf_next rad) (while (null (setq sspl (ssget "_+.:E:S" '((0 . "*POLYLINE") (-4 . "<AND") (-4 . "&") (70 . 1) (-4 . "<NOT") (-4 . "&") (70 . 124) (-4 . "NOT>") (-4 . "AND>"))))) (princ "\nInvalid object") ) (setq typent (cdr (assoc 0 (setq dxf_ent (entget (setq ent (ssname sspl 0))))))) (cond ((eq typent "LWPOLYLINE") (setq lst (mapcar '(lambda (x) (trans x ent 1)) (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) dxf_ent))) l_bulg (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 42)) dxf_ent)) lst (def_bulg_pl lst l_bulg) ) ) ((eq typent "POLYLINE") (setq e_next (entnext ent)) (while (= "VERTEX" (cdr (assoc 0 (setq dxf_next (entget e_next))))) (if (zerop (boole 1 223 (cdr (assoc 70 dxf_next)))) (setq lst (cons (trans (cdr (assoc 10 dxf_next)) ent 1) lst) l_bulg (cons (cdr (assoc 42 dxf_next)) l_bulg) ) ) (setq e_next (entnext e_next)) ) (setq lst (reverse lst) l_bulg (reverse l_bulg) lst (def_bulg_pl lst l_bulg) ) ) ) (if (setq rad (car (vl-remove 0.0 (vl-sort lst '<)))) (princ (strcat "\nMinor radius found " (rtos rad 2))) (princ "\nNo radius found in this polyline") ) (prin1) )
    2 points
  20. Interesting and thanks, this is one I am going to keep for myself so worth me taking the time over it, I should have time this week to look at the very small lines and small gaps. Having a quick look, some of the circles are not -quite- identical (overlaid one on top of another, overkill, and there are some lines left from both) which might explain that.
    2 points
  21. Try using this modified version of some super old code. I cleanup drawings with this daily. (defun c:endit (/ adoc c e file s) (if (and (= 1 (getvar 'dwgtitled)) (getvar 'writestat)) (progn (acad-push-dbmod) (setq e (getvar 'expert) c (getvar 'cmdecho) file (strcat (getvar 'dwgprefix) (getvar 'dwgname)) adoc (vla-get-activedocument (vlax-get-acad-object)) ) (dictremove (namedobjdict) "ACAD_DGNLINESTYLECOMP") (repeat 3 (setq s (ssget "_X" '((0 . "AEC*,*PROXY*")))) (progn (setvar 'qaflags 1) (vl-catch-all-apply 'vl-cmdf (list "_.explode" s "")) (setvar 'qaflags 0) ) ) (vla-save adoc) (setvar 'expert 5) (setvar 'cmdecho 0) (setvar 'tilemode 1) (if (= 0 (getvar 'worlducs)) (command "_.ucs" "_World") ) (command "_.-wblock" (strcat (getvar 'dwgprefix) (getvar 'dwgname)) "*") (setvar 'expert e) (setvar 'cmdecho c) (acad-pop-dbmod) (if (= 0 (getvar 'cmdactive)) (vl-cmdf "_.close" "_Yes") ) ) (alert "\nThis routine only works on drawings that have been saved or not readonly.") ) (princ) )
    2 points
  22. @3dwannab FYI - I changed the code above again to allow different units, like fractions, architectural, etc. Simple change from using "atof" to convert the strings to using "distof".
    2 points
  23. @3dwannab Thanks! NOTE: I updated the code in my previous post to have better error handling if someone enters an invalid string for the distances. Please re-copy it.
    2 points
  24. Brilliant stuff @pkenewell, this is brilliant for footpaths, cavity walls and other things I can't think off atm.
    2 points
  25. I could modify my Layer Director application to achieve this - feel free to drop me a message through my site if you want to go this route.
    2 points
  26. Save it as a global variable: ( (defun c:test () (setq *your_global_variable* (cond ((getdist (strcat "\nSpecify distance" (if *your_global_variable* (strcat " <" (rtos *your_global_variable* 2 3) ">") "") ": "))) (*your_global_variable*) ) ) )
    2 points
  27. I think this is the next step, it isn't pretty though but I need to go to the supermarket. Select 1 segment in the arc. Might fail if the arc doesn't have a straight line either side of it and a few other errors. not tested fully and needs be tidied up with some notes added. Try it and see. Step after this is to do this for all the drawing and not one arc at a time (defun c:ConnectedLines ( / StopLoop MySS MyList MyLines acount pt pt1 pt2 pt3 pt4 LineSS ConnectedLines) ;;Sub Functions (defun onlyunique ( MyList / returnList ) (setq ReturnList (list)) ; blank list for result (foreach n MyList ; loop through supplied list (if ( = (member n (cdr (member n MyList))) nil) ; if list item occurs only once (setq ReturnList (append ReturnList (list n))) ; add to list ) ) ; end foreach ReturnList ) (defun uniquepoints ( MySS / MyList acount) (princ "Select Lines") (setq MyList (list)) ; Blank list for line coordinates (setq acount 0) (while (< acount (sslength MySS)) ; loop each line (setq MyEnt (entget (ssname MySS acount))) (setq MyList (append MyList (list (cdr (assoc 10 MyEnt))))) ; add end A to list (setq MyList (append MyList (list (cdr (assoc 11 MyEnt))))) ; add end B to list (setq acount (+ acount 1)) ) (list (onlyunique MyList) MyList) ; list: Unique Items, All Items ) ;; 3-Point Circle - Lee Mac ;; Returns the center (UCS) and radius of the circle defined by three supplied points (UCS). ;; Modified to return only radius (defun 3PR (pt1 pt2 pt3 / cen md1 md2 vc1 vc2) (if (setq md1 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) pt1 pt2) md2 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) pt2 pt3) vc1 (mapcar '- pt2 pt1) vc2 (mapcar '- pt3 pt2) cen (inters md1 (mapcar '+ md1 (list (- (cadr vc1)) (car vc1) 0)) md2 (mapcar '+ md2 (list (- (cadr vc2)) (car vc2) 0)) nil ) ) (distance cen pt1) ) ) (defun mid-pt ( p1 p2 / ) (polar p1 (angle p1 p2) (/ (distance p1 p2) 2.) ) ) (defun LM:intersections ( ob1 ob2 mod / lst rtn ) (if (and (vlax-method-applicable-p ob1 'intersectwith) (vlax-method-applicable-p ob2 'intersectwith) (setq lst (vlax-invoke ob1 'intersectwith ob2 mod)) ) (repeat (/ (length lst) 3) (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn) lst (cdddr lst) ) ) ) (reverse rtn) ) (defun DrawLine (pt1 pt2) (entmakex (list '(0 . "LINE") (cons 10 pt1) (cons 11 pt2) ))) ;;End sub functions (setq MyEnt (car (entsel "Select a line"))) ; A selected line (setq ConnectedLines (ssadd MyEnt)) ; List for lines connected to selected (setq MyList (ssadd MyEnt)) ; List for used lines ; Later: for selection set selections (setq Pt (cdr (assoc 10 (entget MyEnt)))) ; End A point (setq Pt2 (cdr (assoc 11 (entget MyEnt)))) ; End A point (setq AnEnt MyEnt) ; Starting Entity ;;Get initial intersection (setq LineSS (ssadd)) ; Empty Selection Set (setq MidPt (mid-pt Pt Pt2)) (setq MyAng (angle Pt Pt2)) (setq Pt3 (polar MidPt (- MyAng (/ pi 2)) 1000)) (setq LineSS (ssadd (DrawLine MidPt Pt3) LineSS )) (setq Pt1 (mapcar '+ '(-0.0001 -0.0001) Pt)); Small area around end of line (setq Pt3 (mapcar '+ '( 0.0001 0.0001) Pt)); Other corner (setq MySS (ssget "_C" Pt1 Pt3 '((0 . "LINE"))) ) ; select joining lines within 0.0001 (if (= (sslength MySS) 1) ; If only 1 joining lines (progn (setq Pt1 (mapcar '+ '(-0.0001 -0.0001) Pt2)); Small area around end of line (setq Pt3 (mapcar '+ '( 0.0001 0.0001) Pt2)); Other corner (setq MySS (ssget "_C" Pt1 Pt3 '((0 . "LINE"))) ) ; select joining lines within 0.0001 ) ) (if (= (sslength MySS) 2) ; If 2 joining lines (progn (setq AnEnt (ssname (ssdel AnEnt MySS) 0)) (setq APtA (cdr (assoc 10 (entget AnEnt)))) ; next line end points (setq APtB (cdr (assoc 11 (entget AnEnt)))) (setq MidPt (mid-pt APtA APtB)) (setq MyAng (angle APtA APtB)) (setq Pt3 (polar MidPt (- MyAng (/ pi 2)) 1000)) (setq LineSS (ssadd (DrawLine MidPt Pt3) LineSS )) ) ) (setq Int1 (LM:intersections (vlax-ename->vla-object (ssname LineSS 0)) (vlax-ename->vla-object (ssname LineSS 1)) acextendboth)) (setq MyRadius (distance (car Int1) APtA)) ;;Reset points (setq Pt (cdr (assoc 10 (entget MyEnt)))) ; End A point (setq Pt2 (cdr (assoc 11 (entget MyEnt)))) ; End B point (setq AnEnt MyEnt) ; Starting Entity (setq EndLines (ssadd)) (repeat 2 ; Repeat2 - both directions (setq StopLoop "No") ; Marker to stop looping (while (= StopLoop "No") (setq Pt1 (mapcar '+ '(-0.0001 -0.0001) Pt)); Small area around end of line (setq Pt3 (mapcar '+ '( 0.0001 0.0001) Pt)); Other corner (setq MySS (ssget "_C" Pt1 Pt3 '((0 . "LINE"))) ) ; select joining lines within 0.0001 (if (= (sslength MySS) 2) ; If only 2 joining lines (progn (setq MySS (ssdel AnEnt MySS)) ; Next line (setq AnEnt (ssname MySS 0)) ; next line entity name (setq APtA (cdr (assoc 10 (entget AnEnt)))) ; next line end points (setq APtB (cdr (assoc 11 (entget AnEnt)))) (if (ssmemb AnEnt MyList) (progn (princ "Repeating Selection") (setq StopLoop "Yes") ) (progn (setq MyList (ssadd MyEnt)) ; List for used lines ; Later: for selection set selections ;;get intersection (setq MidPt (mid-pt APtA APtB)) (setq MyAng (angle APtA APtB)) (setq Pt3 (polar MidPt (- MyAng (/ pi 2)) 1000)) (setq LineSS (ssadd (setq TempLine (DrawLine MidPt Pt3)) LineSS )) (setq Int2 (LM:intersections (vlax-ename->vla-object (ssname LineSS 0)) (vlax-ename->vla-object TempLine) acextendboth)) (if (equal Int1 Int2 0.01) ; intersection point the same (progn (setq ConnectedLines (ssadd AnEnt ConnectedLines)) ; add next line to list of connected lines ) (progn (setq EndLines (ssadd AnEnt EndLines)) (setq StopLoop "Yes") ) ) (if (equal APtA Pt 0.0001) (setq Pt APtB)(setq Pt APtA) ; work out if next line connected at end A or B ) ) ) ) ; end progn (progn (setq StopLoop "Yes") ) ; end progn ) ; end if SSlength = 2 ) ; end while stoploop (setq Pt (cdr (assoc 11 (entget MyEnt)))) (setq AnEnt MyEnt) ) ; end repeat (command "erase" LineSS "") ; delete temporary lines (if (< 2 (sslength ConnectedLines)) (progn (setq MyList (uniquepoints ConnectedLines));; SP ADDED (setq p1 (car (car MyList)));; SP ADDED (setq p2 (nth (/ (length (cadr MyList)) 2) (cadr MyList)));; SP ADDED (setq p3 (cadr (car MyList)));; SP ADDED ;;Do something here error checking or so no fillet needed: Lee Mac 3 point Arcs (setq line1 (ssname EndLines 0)) (setq line2 (ssname EndLines 1)) ; (setq line1 (car (entsel "Select line"))) ; (setq line2 (car (entsel "Select line"))) (setq FilletRad_Old (getvar 'filletrad)) (setvar 'filletrad MyRadius) (setvar 'filletrad (3PR p1 p2 p3)) (command "fillet" line1 line2) (setvar 'filletrad FilletRad_OLd) (command "erase" ConnectedLines "") ) ; end progn ) ; end if ; (ssdel ConnectedLines) )
    2 points
  28. A better idea is to work out by calculating the perpendicular bisectors of the line segments. Take 3 consecutive lines and calculate the point where the perpendicular bisector intersects. The point where the perpendicular bisectors meet is the centre of the arc, so if they are within close proximity (to a certain tolerance), then this entails an arc segment. Otherwise, it's not.
    2 points
  29. Perhaps this tutorial is helpful - https://lee-mac.com/promptwithdefault.html
    1 point
  30. You are almost correct. In your rectification above, the global variable will be set to nil if the user presses Enter without giving a distance. The purpose of the cond function is to justify the default value that was previously stored. In my code snippet, the cond function will put in whatever value the user inputs (if the user actually does input something in). Otherwise, getdist then returns nil, and the cond function proceeds into the second line and inserts the default variable. In your snippet, you managed to get your message prompt right. However, remember that, just because the prompt simply alerts the user the default value using <> doesn't mean that getdist acually returns that value. You still need to use if conditions to account for this.
    1 point
  31. 1 point
  32. Looking at the block, probably AttSync will work. Sometimes this won't work if you have changed the attributes in a block in the Enhanced Attribute Editor, AttSync will reset them to the default, so try below. For example, Sometimes with title blocks if the freetexts - drawing title or description can extend out of the area assigned and you change the width factor perhaps - attsync will reset that (as a example) (defun c:MoveBlocks ( / target-point block-name) (setq target-point '(300.0 5.25 0.0)) ;;Point to move to (setq block-name "RegionserviceUTR") ;;Block Name to move (MoveBlock target-point block-name) ) (defun MoveBlock (target-point block-name / BlockSS acount) (setq BlockSS (ssget "_X" (list '(0 . "INSERT")(cons 2 block-name)))) (setq acount 0) (while (< acount (sslength BlockSS)) (entmod (subst (cons 10 target-point) (assoc 10 (entget (ssname BlockSS acount))) (entget (ssname BlockSS acount)) )) (setq acount (+ acount 1)) ) ; end while (command "attsync" "N" block-name) )
    1 point
  33. i once needed something similar, i found a function somewhere online that does that and modified it somewhat to my needs. Its still somewhat clumpy but maybe it helps.. (defun c:divarea (/ *error* osmode cmdecho blipmode correctent-p ready fixpt parpt answer ename divider area) (defun *error* (msg) (if osmode (setvar "osmode" osmode)) (if cmdecho (setvar "cmdecho" cmdecho)) (if blipmode (setvar "blipmode" blipmode)) (princ (strcat "\nError: " msg)) (princ) ) (defun correctent-p (ent /) (if ent (and (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE") (= (cdr (assoc 70 (entget ent))) 1) ) nil ) );defun (defun ready () (setvar "osmode" osmode) (setvar "cmdecho" cmdecho) (setvar "blipmode" blipmode) (princ (strcat "\nFull Area : " (rtos area))) (princ (strcat "\nNew Area : " (rtos newarea))) (princ) );defun (defun initiate-parpt (newarea i / parpt getcenter divisionline boundarypoint oldline ptb temp newboundary pt1) (defun parpt (tem line pts / p1 p2 precision deln pts par linedata) (setvar "osmode" osmode) (setq precision (/ (vla-get-length (vlax-ename->vla-object line)) 10)) (setvar "osmode" 0) (command "_line" p1 p2 "") (setq deln (entlast)) ;put line to delete later (if (not ptb) (setq ptb (getpoint "\nPick any point into the REST of the piece, FAR from division line: "))) (setvar "blipmode" 0) (princ "\nPlease wait...") (command "_boundary" pts "") (setq newboundary (entlast)) (setq par (vla-get-area (vlax-ename->vla-object newboundary))) ;par = area created by boundary (while (> (abs (- par tem)) 0.00001) (if (< par tem) (progn (while (< par tem) (entdel newboundary) ;delete boundary (command "_offset" precision deln ptb "") (entdel deln) (setq deln (entlast)) (command "_boundary" pts "") (setq newboundary (entlast)) (setq par (vla-get-area (vlax-ename->vla-object newboundary))) ) ) (progn (while (> par tem) (entdel newboundary) (command "_offset" precision deln pts "") (entdel deln) (setq deln (entlast)) (command "_boundary" pts "") (setq newboundary (entlast)) (setq par (vla-get-area (vlax-ename->vla-object newboundary))) ) ) ) (setq linedata (entget deln)) (entdel deln) (setq precision (/ precision 1.5)) (princ precision) ) (command "_change" newboundary "" "_p" "_c" "_green" "") linedata );defun (defun getcenter (line1 line2 / p1 p2) (setq p1 (cdr (assoc 10 (entget line1)))) (setq p2 (cdr (assoc 11 (entget line2)))) (list (/ (+ (car p1) (car p2)) 2) ; x-coordinate of the center point (/ (+ (cadr p1) (cadr p2)) 2) ; y-coordinate of the center point ) );defun (command "_line" (setq pt1 (getpoint "\nPick one point of division line (far from lwpoly) : ")) (getpoint pt1 "\nPick other point of division line (far from lwpoly) : ") "" ) (setq divisionline (entlast)) (setq boundarypoint (getpoint "\nPick any point into FIRST piece, FAR from division line: ")) (setq temp (parpt newarea divisionline boundarypoint)) (while (> i 2) (entmake temp) (setq oldline (entlast)) (command "_offset" (/ (vla-get-length (vlax-ename->vla-object oldline)) 200) oldline ptb "") (setq divisionline (entlast)) (setq boundarypoint (getcenter oldline divisionline)) (entdel oldline) (setq temp (parpt newarea divisionline boundarypoint)) (setq i (1- i)) ) (command "_boundary" ptb "") (setq newboundary (entlast)) (command "_change" newboundary "" "_p" "_c" "_green" "") );defun (setq osmode (getvar "osmode") cmdecho (getvar "cmdecho") blipmode (getvar "blipmode") ) (setvar "osmode" 0) (setvar "cmdecho" 0) (while (not (correctent-p ename)) (setq ename (car (entsel "\nSelect closed LWPOLY to divide: "))) ) (setq area (vla-get-area (vlax-ename->vla-object ename))) (initget "Divide Cut") (setq answer (cond ((getkword "\nDIVIDE by number or CUT a part ? [Divide/Cut] <Divide>: ")) ("Divide"))) (if (= answer "Divide") (progn (setq divider (cond ((getreal "\nEnter number to divide the whole part by <2>: ")) (2))) (setq newarea (/ area divider)) ) (setq newarea (getreal "\nArea to cut : ")) ) (initiate-parpt newarea divider) (ready) )
    1 point
  34. This was something that I also challenged myself to do. Though not perfect, the purpose of this program was to "neaten" Revit exported or similar pipelines so that they are all "filleted" and "trimmed" cleanly so that it works with my other commands that I've created. I don't know how useful this will be, but if it doesn't suit your requirements, I'll give another crack at it. You will probably just have to select the lines separately (the yellow and green lines). Neaten.lsp
    1 point
  35. I don't know if I understood everything! But like this, can it be suitable? (vl-load-com) (defun gr-osmode (pt-i str-md / n pt md rap pt1 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt56 pt67 pt78 pt85 one_o) (setq n (/ (cadr (getvar "screensize")) 5.0)) (setq pt (osnap pt-i str-md)) (while (and (eq (strlen (setq md (substr str-md 1 4))) 4) (not one_o)) (repeat 2 (setq rap (/ (getvar "viewsize") n) pt1 (list (- (car pt) rap) (- (cadr pt) rap) (caddr pt)) pt2 (list (+ (car pt) rap) (- (cadr pt) rap) (caddr pt)) pt3 (list (+ (car pt) rap) (+ (cadr pt) rap) (caddr pt)) pt4 (list (- (car pt) rap) (+ (cadr pt) rap) (caddr pt)) pt5 (list (car pt) (- (cadr pt) rap) (caddr pt)) pt6 (list (+ (car pt) rap) (cadr pt) (caddr pt)) pt7 (list (car pt) (+ (cadr pt) rap) (caddr pt)) pt8 (list (- (car pt) rap) (cadr pt) (caddr pt)) pt56 (polar pt (- (/ pi 4.0)) rap) pt67 (polar pt (/ pi 4.0) rap) pt78 (polar pt (- pi (/ pi 4.0)) rap) pt85 (polar pt (+ pi (/ pi 4.0)) rap) n (- n 16) ) (if (equal (osnap pt-i md) pt) (setq one_o T)) (cond ((and (eq "_end" md) one_o) (grdraw pt1 pt2 1) (grdraw pt2 pt3 1) (grdraw pt3 pt4 1) (grdraw pt4 pt1 1) ) ((and (eq "_mid" md) one_o) (grdraw pt1 pt2 1) (grdraw pt2 pt7 1) (grdraw pt7 pt1 1) ) ((and (eq "_cen" md) one_o) (grdraw pt5 pt56 1) (grdraw pt56 pt6 1) (grdraw pt6 pt67 1) (grdraw pt67 pt7 1) (grdraw pt7 pt78 1) (grdraw pt78 pt8 1) (grdraw pt8 pt85 1) (grdraw pt85 pt5 1) (grdraw pt5 pt7 7) (grdraw pt6 pt8 7) ) ((and (eq "_nod" md) one_o) (grdraw pt5 pt56 1) (grdraw pt56 pt6 1) (grdraw pt6 pt67 1) (grdraw pt67 pt7 1) (grdraw pt7 pt78 1) (grdraw pt78 pt8 1) (grdraw pt8 pt85 1) (grdraw pt85 pt5 1) (grdraw pt1 pt3 1) (grdraw pt2 pt4 1) ) ((and (eq "_qua" md) one_o) (grdraw pt5 pt6 1) (grdraw pt6 pt7 1) (grdraw pt7 pt8 1) (grdraw pt8 pt5 1) ) ((and (eq "_int" md) one_o) (grdraw pt1 pt3 1) (grdraw pt2 pt4 1) ) ((and (eq "_ins" md) one_o) (grdraw pt5 pt2 1) (grdraw pt2 pt6 1) (grdraw pt6 pt8 1) (grdraw pt8 pt4 1) (grdraw pt4 pt7 1) (grdraw pt7 pt5 1) ) ((and (eq "_per" md) one_o) (grdraw pt1 pt2 1) (grdraw pt1 pt4 1) (grdraw pt8 pt 1) (grdraw pt pt5 1) ) ((and (eq "_tan" md) one_o) (grdraw pt5 pt56 1) (grdraw pt56 pt6 1) (grdraw pt6 pt67 1) (grdraw pt67 pt7 1) (grdraw pt7 pt78 1) (grdraw pt78 pt8 1) (grdraw pt8 pt85 1) (grdraw pt85 pt5 1) (grdraw pt3 pt4 1) ) ((and (eq "_nea" md) one_o) (grdraw pt1 pt2 1) (grdraw pt2 pt4 1) (grdraw pt4 pt3 1) (grdraw pt3 pt1 1) ) ) ) (setq str-md (substr str-md 6) n (/ (cadr (getvar "screensize")) 5.0)) ) ) (defun nentsel-getreal ( / o mod ent key n nbr) (setq o (getvar "osmode")) (if (or (zerop o) (eq (boole 1 o 16384) 16384)) (setq mod "_none") (progn (setq mod "") (mapcar '(lambda (xi xs) (if (not (zerop (boole 1 o xi))) (if (zerop (strlen mod)) (setq mod (strcat mod xs)) (setq mod (strcat mod "," xs)) ) ) ) '(1 2 4 8 16 32 64 128 256 512 2048 4096 8192) '("_endp" "_mid" "_cen" "_nod" "_qua" "_int" "_ins" "_per" "_tan" "_nea" "_appint" "_ext" "_par") ) ) ) (setq nbr "") (princ (strcat "\nSpecify a point at [" mod "] of, or choose Text/Multiline Text/Attribute to get Z <" (rtos (caddr (getvar "LASTPOINT")) 2 2) ">: ")) (while (and (not (member (setq key (grread T 4 2)) '((2 13) (2 32)))) (/= (car key) 25) (/= (car key) 3)) (cond ((eq (car key) 5) (redraw) (mapcar '(lambda (p1 p2) (grdraw (trans p1 0 1) (trans p2 0 1) 7)) lst_tmp (cdr lst_tmp)) (if (and (/= mod "_none") (osnap (cadr key) mod)) (progn (gr-osmode (cadr key) mod) (repeat 128 (princ "\010")) (princ (caddr (osnap (cadr key) mod)))) ) ) ((eq (car key) 2) (if (member (cadr key) '(8 46 48 49 50 51 52 53 54 55 56 57)) (if (eq (cadr key) 8) (progn (princ (chr 8)) (princ (chr 32)) (princ (chr 8)) (setq nbr (substr nbr 1 (1- (strlen nbr)))) ) (progn (setq n (chr (cadr key))) (princ n) (setq nbr (strcat nbr n)) ) ) ) ) ) ) (if (eq (car key) 3) (if (setq ent (nentselp (cadr key))) (progn (setq ent (entget (car ent))) (if (member (cdr (assoc 0 ent)) '("TEXT" "MTEXT" "ATTRIB")) (progn (setq ent (read (cdr (assoc 1 ent)))) (if (or (eq (type ent) 'INT) (eq (type ent) 'REAL)) (progn (princ (strcat "\nZ = " (rtos ent 2 2))) ent) (progn (princ "\nInvalid text!") (nentsel-getreal)) ) ) (progn (setq nbr "") (if (osnap (cadr key) mod) (setvar "LASTPOINT" (osnap (cadr key) mod)) (nentsel-getreal) ) (princ (strcat "\nZ = " (rtos (caddr (getvar "LASTPOINT")) 2 2))) (caddr (getvar "LASTPOINT")) ) ) ) (progn (princ "\nEmpty selection!") (setq ent nil) (nentsel-getreal)) ) (if (/= nbr "") (progn (princ (strcat "\nZ = " nbr)) (atof nbr)) (progn (princ (strcat "\nZ = " (rtos (caddr (getvar "LASTPOINT"))2 2))) (caddr (getvar "LASTPOINT"))) ) ) ) (defun c:Test ( / pt1 pt2 height radius dxf_210 center textChoices selectedIndex selectedText) (initget 9) (setq pt1 (getpoint "\nEnter first point of circle's diameter: ")) (initget 9) (setq pt2 (getpoint pt1 "\nEnter second point of circle's diameter: ")) (setvar "PDMODE" 2) (setvar "PDSIZE" 0.05) (setq height (nentsel-getreal)) (setq radius (* (distance pt1 pt2) 0.5)) (setq dxf_210 (trans '(0 0 1) 1 0 T)) (setq pt1 (list (car pt1) (cadr pt1) height)) (setq pt2 (list (car pt2) (cadr pt2) height)) (setq center (trans (mapcar '* (mapcar '+ pt1 pt2) '(0.5 0.5 0.5)) 1 dxf_210)) (entmake (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 8 "Test") (cons 40 radius) (cons 10 center) (cons 210 dxf_210) ) ) (entmake (list '(0 . "POINT") '(100 . "AcDbEntity") '(100 . "AcDbPoint") (cons 8 "Test") (cons 10 (trans center dxf_210 0)) (cons 50 (angle '(0 0 0) (getvar "UCSXDIR"))) ) ) (setq textChoices '("test1" "test2" "test3" "test4" "test5" "test6" "User to input custom text")) (setq selectedIndex (getint (strcat "\nEnter the index of the desired text choice:\n" "1. test1\n" "2. test2\n" "3. test3\n" "4. test4\n" "5. test5\n" "6. test6\n" "7. User to input custom text\n" "Enter choice (1-7): "))) (setq selectedText (if (= selectedIndex 7) (getstring "\nEnter the custom text: ") (nth (1- selectedIndex) textChoices))) (entmake (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText") (cons 8 "Test_text") (cons 7 "Arial") (cons 1 selectedText) (cons 40 0.15) (cons 10 (trans center dxf_210 0)) (cons 50 (angle '(0 0 0) (getvar "UCSXDIR"))) (cons 210 dxf_210) ) ) (princ) )
    1 point
  36. Hello friend, good morning, thank you very much for the help, it has worked wonderfully for me.
    1 point
  37. @leonucadomi As i ask for before, please UPLOAD your sample dwg with BEFORE and AFTER. Btw Did you try my lisp?
    1 point
  38. @MFEC Your problem is you are trying to go on to the next prompt before the MOVE command is completed. Command functions need to account for all input. Use PAUSE in a command to stop and get input before continuing. ;Change This (COMMAND "MOVE" CONJUNTO_SELECCION "" P1) ;into This (COMMAND "MOVE" CONJUNTO_SELECCION "" P1 pause);<--- Pause here allows you to complete the command before prompting to go on to the next loop.
    1 point
  39. Check the radius setting for the FILLET command. It needs to be zero if you want a sharp corner. If that doesn't help, please provide more information.
    1 point
  40. Your circle is not in the world UCS. If you set a UCS using the circle as the base, then all the snaps work perfectly.
    1 point
  41. unfortunately I have moved on from CAD and am now using exclusively solidworks at my job. so i don't get to dabble in lisp as much as i use to. Here is another manual proof. Make a 3 point arc use newly created entity's bounding box delete lines that are selected with the lower left and upper right points. ;;----------------------------------------------------------------------------;; ;; Lines to Arc ;; https://www.cadtutor.net/forum/topic/80056-i-want-to-convert-many-straight-lines-into-one-arc/ (defun c:MSLIOA (/ LL UR) ;Many Stright Lines Into One Arc (command "Arc" pause pause pause) ;wait for user to pick points. (vla-getboundingbox (vlax-ename->vla-object (entlast)) 'minpt 'maxpt) (setq LL (vlax-safearray->list minpt) UR (vlax-safearray->list maxpt)) (command "_.Erase" (ssget "_W" LL UR '((0 . "LINE"))) "") )
    1 point
  42. Hi devitg maybe use Xline for the temporary line working out the second point on the ellipse. It auto extends to infinity.
    1 point
  43. Do you have Ortho on ? Press F8 for on off. Thne using mouse for angle should work.
    1 point
  44. Ok you can get the blocks into a selection set using a wild card search as 1st step, can then get attributes. Then you can check for an attribute tagname. (setq ss (ssget "X" '((0 . "INSERT")(cons 2 "Abschn_11_3_NN009*")))) <Selection set: 0000000064361620> : (sslength ss) 115 (vlax-get (nth 3 atts) 'Tagstring) "DN" (vlax-get (nth 3 atts) 'Textstring) "200.00" What do you know about lisp ?
    1 point
  45. What does -30 do. There is a command Lengthen.
    1 point
  46. Another method: (defun c:vpon ( / d s ) (vl-load-com) (if (setq s (ssget "_+.:S:E:L" '((0 . "VIEWPORT")))) (progn (setq d (vla-get-activedocument (vlax-get-acad-object))) (vla-put-mspace d :vlax-true) (vla-put-activeviewport d (vlax-ename->vla-object (ssname s 0))) ) ) (princ) ) And to 'deactivate': (defun c:vpoff ( ) (vla-put-mspace (vla-get-activedocument (vlax-get-acad-object)) :vlax-false) (princ) )
    1 point
  47. Tip - I like to set ucsfollow to '1' so it automatically rotates the view in model space when you change the ucs via views on the ribbon. This is helpful when rotating the ucs to unusual angles.
    1 point
  48. Or, using the fact that non tangential arc segments are not bevelled, draw your lines as a series of arc segments (of infinite radius), and join them up with pedit.
    1 point
×
×
  • Create New...