Jump to content

Leaderboard

  1. BIGAL

    BIGAL

    Trusted Member


    • Points

      31

    • Posts

      17,863


  2. Steven P

    Steven P

    Trusted Member


    • Points

      27

    • Posts

      2,184


  3. pkenewell

    pkenewell

    Community Member


    • Points

      25

    • Posts

      432


  4. Lee Mac

    Lee Mac

    Trusted Member


    • Points

      23

    • Posts

      20,854


Popular Content

Showing content with the highest reputation since 01/21/2024 in all areas

  1. Try something like this - change the value of the two variables at the top of the code to suit: (defun c:test ( / bln idx lst nla pat ) (setq pat "*block*" nla "NewLayer" pat (strcase pat) ) (if (setq sel (ssget '((0 . "INSERT")))) (repeat (setq idx (sslength sel)) (setq idx (1- idx) bln (cdr (assoc 2 (entget (ssname sel idx)))) ) (if (not (member bln lst)) (progn (setq lst (cons bln lst)) (processblock bln pat nla) ) ) ) ) (princ) ) (defun processblock ( bln str lay / ent ) (if (setq ent (tblobjname "block" bln)) (while (setq ent (entnext ent)) (processobject ent str lay) ) ) ) (defun processobject ( ent str lay / bln enx ) (cond ( (not (setq enx (entget ent)))) ( (/= "INSERT" (cdr (assoc 0 enx)))) ( (not (wcmatch (setq bln (strcase (cdr (assoc 2 enx)))) str)) (processblock bln str lay) ) ( (entmod (subst (cons 8 lay) (assoc 8 enx) enx)) (processblock bln str lay) ) ) ) (princ)
    4 points
  2. I merged your threads. No need to create new threads for the same question.
    3 points
  3. (defun c:11 (/) (setq ent (vlax-ename->vla-object (car (entsel))) lat (vla-get-latitude ent) lon (vla-get-longitude ent) ) (alert (strcat "Latitude = " lat "\nLongitude = " lon)) )
    3 points
  4. Use DATE instead of CDATE: https://help.autodesk.com/view/ACD/2023/ENU/?guid=GUID-CBB24068-1654-4753-BE2E-1D0CE9700411 DATE stores the date value as a Julian date, which simply counts the number of days which have elapsed from a given epoch - as such, you can easily subtract two integer Julian date values to calculate the number of elapsed days between two dates, e.g.: (< 7 (- (getvar 'date) (atoi (getenv "TELNUMBERS")))) (assuming you have changed TELNUMBERS to store the DATE value instead of CDATE)
    3 points
  5. Cool, I saved this one. I just added a couple lines for settings. @cooldude224 My edit should help you with the position of the attribute (defun c:add_ATT (/ ss blk blk-lst atts-lst def AttObj obj2 text_height ip mode align) ;; settings. Feel free to adapt to your needs. ;; Feel free to change the settings from hard coded to user input. See below (setq text_height 2.5) (setq ip (list 0.0 0.0)) ;; insert point in the block (setq default_value "") ;; MODE: ;; (any combination of constants can be used by adding them together): ;; acAttributeModeNormal ;; acAttributeModeInvisible ;; acAttributeModeConstant ;; acAttributeModeVerify ;; acAttributeModePreset (setq mode acAttributeModeNormal) ;; Allignment: ;; acAlignmentLeft / acAlignmentCenter / acAlignmentRight / acAlignmentAligned / acAlignmentMiddle / acAlignmentFit / acAlignmentTopLeft / acAlignmentTopCenter / acAlignmentTopRight / acAlignmentMiddleLeft / acAlignmentMiddleCenter / acAlignmentMiddleRight / acAlignmentBottomLeft / acAlignmentBottomCenter / acAlignmentBottomRight (setq align acAlignmentRight) ;; COMMENT OUT THESE NEXT LINES IF YOU WANT THE HARD CODED SETTINGS (setq text_height (getdist "\nText height: ")) (setq ip (getpoint "\nInsert point: ")) (setq default_value (getstring "\nDefault value: " T)) (vl-load-com) (setq Tag (strcase (getstring "\nSpecify attribute tag: "))) (if (setq ss (ssget '((0 . "INSERT")))) ;change if to while repeats command if you keep selecting things (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS))) ;makes a list of all entitys by ename in selection set and steps thought them one at a time (setq blk (cdr (assoc 2 (entget e)))) (if (not (vl-position blk blk-lst)) (progn (setq blk-lst (cons blk blk-lst)) (setq obj2 (vlax-ename->vla-object e)) (setq atts-lst nil) ;clear list from last use (if (= (vla-get-hasattributes obj2) :vlax-true) (foreach att (vlax-invoke obj2 'getattributes) (setq atts-lst (cons (strcase (vla-get-tagstring att)) atts-lst)) ;make a list of all Attributs tag names to check rather then checking them all individually ) ;;close foreach ) ;;close if (if (not (member tag atts-lst)) ;checks list for "SYSTEM" could also use vl-position (progn (setq def (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) blk)) ;; VL : RetVal = (vla-AddAtribute object Height Mode Prompt InsertionPoint Tag Value) (setq AttObj (vla-addattribute def text_height mode "" (vlax-3D-point ip) TAG default_value)) (vlax-put AttObj 'Alignment align) (vla-move AttObj (vlax-3D-point (list 0.0 0.0)) (vlax-3D-point ip)) (command "_.attsync" "_N" blk) ) ;;close progn ) ;;close if ) ;;close progn ) ;;close if ) ;;close foreach ) ;;close if (princ) )
    3 points
  6. 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
  7. 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
  8. 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
  9. 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"))) "") )
    2 points
  10. @ajithkumar.t I recommend you try using the (vla-Saveas) method: ;; Use VlaSaveAs Method (setq saveFileName (strcat saveFileNamepath (vl-filename-base (getvar "DWGNAME")) ".dxf")) (vla-saveas (vla-get-activedocument (vlax-get-acad-object)) SaveFileName ac2018_dxf) (if (findfile SaveFileName) (prompt (strcat "\nProcessed drawing saved to: " saveFileName)) (prompt (strcat "\nError: Unable to save the processed drawing as DXF.")) ) Also note: you have some incomplete code in your post above: (setq subfolderName (strcat (rtos x 2 2) "-" modtext)) There is nothing in the function that defines "x" or "modtext" so it errors here.
    2 points
  11. Something like this: (defun C:POSM-TO-CSV ( / doc fil sel lst hdr ) (vl-load-com) (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) (cond ((null (setq fil (getfiled "Save CSV:" (if (= 1 (getvar 'dwgtitled)) (strcat (getvar 'dwgprefix) (vl-filename-base (getvar 'dwgname)) ) (strcat "C:\\" (vl-filename-base (getvar 'dwgname))) ) "csv" 1 ) ) ) (princ "\n*Cancel*") ) ((null (ssget '((0 . "POSITIONMARKER"))))(princ "\nInvalid Selection.")) ( t (vlax-for x (setq sel (vla-get-ActiveSelectionSet doc)) (setq lst (cons (list (vla-get-latitude x)(vla-get-longitude x)) lst)) ) (setq lst (mapcar '(lambda ( x ) (list (car x) (cadr x))) lst)) (setq hdr (cons (list "<Latitude>" "<Longitude>") hdr)) (LM:WriteCSV (setq lst (append hdr lst)) fil) (princ "\nPlease Wait, Opening CSV File in Excel...") (startapp "Explorer" fil) (vla-delete sel) ) ) (princ) ) Requires Lee Mac's WriteCSV
    2 points
  12. 2 points
  13. It is not a overnight learning process but Google is your friend, there are many forums out there with a Lisp section and you will find so many examples to learn from. When googling ask question and add "Autocad Lisp" eg "export attributes to excel autocad lisp" I like many others support people having a go at coding rather than "do this for me". Avoid CHATGP as its not up to scratch and produces a lot of incorrect code. There are a lot of books out there also and these days are electronic so can copy code, I have books from Kindle very cheap.
    2 points
  14. @Jozef13 ;; Change this (setq blockname (cdr (assoc 2 (entget blkobj)))) ;; To this (setq blockname (getpropertyvalue blkobj "BlockTableRecord/Name")) ;; Then change this (setq sel (ssget (list (cons 0 "INSERT") (cons 2 blockname)))) ;; To this (if (setq sel (ssget (list '(0 . "INSERT") (cons 2 (strcat "`*U*," blockname))))) (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex sel))) (or (= blockname (getpropertyvalue e "BlockTableRecord/Name")) (ssdel e sel)) ) )
    2 points
  15. as always you make it look so easy master Lee
    2 points
  16. Yes, this is possible, although no one think a lisp is needed because you can do this using the polyline command, but just to keep programming here it is my version of it ;;; Creates a fixed lwpolyline based on different given distances ;;; By Isaac A 20240128 ;;; https://www.cadtutor.net/forum/topic/79256-lisp-for-creating-new-line-with-a-sum-of-numbers-of-length/ (defun c:fpl (/ a b c d dw e f l oe) (vl-load-com) (vla-startundomark (setq dw (vla-get-activedocument (vlax-get-acad-object)))) (setq oe (getvar 'cmdecho)) (setvar 'cmdecho 0) (setq a (getpoint "\nPick the starting point") b (getpoint "\Pick a second point for the direction" a) c (angle a b) f (list a) ) (initget 2) (if (not (= (setq d (getreal "\nType the starting distance: ") f (append f (list (polar a c d))) ) (or 0 nil))) (progn (initget 6) (while (setq e (getreal "\nType the next distance: ")) (setq d (+ d e) f (append f (list (polar a c d))) ) ) (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(410 . "Model") '(8 . "Test_lwpolylines") '(62 . 40) '(100 . "AcDbPolyline") (cons 90 (length f)) ) (mapcar (function (lambda (l) (cons 10 l))) f) ) ) ) ) (setvar 'cmdecho oe) (vla-endundomark dw) (princ) )
    2 points
  17. Command always takes a second to run. so if you had about 50 layers that match the wcmatch its setting the first transparency to 35. then if it maches the 2nd wcmatch it then changes to 55 trans. this means it could take 50 to 100 seconds. using a cond function and swapping the order it would only execute the correct transparency on the layer. Lee's way works because its running the command once rather then 50 to 100 times. Tho I try and stay away from using command. if you don't want 100 lines of spam to the command prompt you have to set cmdecho to 0 then back after, also has a higher potential to error. this should work for autocad. might also have to throw in a regen to take effect. (vlax-for layer (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) (cond ((wcmatch (vla-get-name layer) "*map*|*") (setpropertyvalue layer "Transparency" 55) ) ((wcmatch (vla-get-name layer) "*|*") (setpropertyvalue layer "Transparency" 35) ) ) )
    2 points
  18. Why not just: (command "_.-layer" "_tr" "35" "*|*" "_tr" "55" "*map*|*" "")
    2 points
  19. Here is my attempt. (defun c:Test (/ int sel ent get ) ;;----------------------------------------------------;; ;; Author : Tharwat Al Choufi ;; ;; website: https://autolispprograms.wordpress.com ;; ;;----------------------------------------------------;; (and (princ "\nSelect Mtexts to remove linebreaks entirely : ") (setq int -1 sel (ssget "_:L" '((0 . "MTEXT")))) (while (setq int (1+ int) ent (ssname sel int)) (entmod (subst (cons 1 (vl-string-translate "\\P" " " (cdr (assoc 1 (setq get (entget ent)))))) (assoc 1 get) get ) ) ) ) (princ) ) (vl-load-com)
    2 points
  20. Had the same problem and this is how I solved it: Problem: I click to start selecting, then zoom in to click again to end the selection, type the command (ex. Move) and only the objects that I see will actually move. Solution: turn SELECTIONOFFSCREEN to 1
    1 point
  21. @Lee Mac that is perfect thanks! I often spend more time searching for the documentation than reading it. @Steven P @BIGAL while I was trying to figure out entmake it occurred to me that I already have the entity and all I need to do is (setpropertyvalue (entlast) "Thickness" value). Which does exactly what I needed. My main takeaways from this exercise are: 1. Localize critical variables (you never know what else is running). 2. Clean up your code. all those 1 condition conditions were not helping. 3. Make sure all your variables are accounted for. I declared MRAD when I collected the projection and width (which I do for all the options) but changed that and forgot to declare it in option 3. nice catch. 4. consider your environmental settings when troubleshooting odd behavior! o-snap is awesome. it also messes things up. consider alternatives. This program is ready for use now! Can't thank you folks enough for all your help. I've learned more than I ever wanted to about LISP! its going to be useful moving forward. flatcalc.lsp
    1 point
  22. Sounds like you have a plan.
    1 point
  23. Thanks Steven. I saw that post but didn't catch that part of the code did the same thing. However, upon testing it only appears to affect box width, whereas double-clicking the ruler arrows shrinks both the width and the height. I'll review that post to see if that was discussed at all - maybe they already came up with a solution...
    1 point
  24. @EYNLLIB thy has been forgiven.
    1 point
  25. In the line 259 uncomment the line and comment the line 261 Same way on lines 253 and 255 En la linea 259 quita el punto y coma ; Y pon uno en la linea 261 De igual forma en las lineas 253 y 255
    1 point
  26. @3dwannab Here is the simplest way - no minimal error checking: (defun c:moff (/ *error* _Strparse cnt dstr en go op s tl) (defun *error* (msg)(if oc (setvar "cmdecho" oc))(princ msg)) (setq oc (getvar "cmdecho")) (setvar "cmdecho" 0) (command "._undo" "_BE") (defun _StrParse (str del / pos) (if (and str del) (if (setq pos (vl-string-search del str)) (cons (substr str 1 pos) (_StrParse (substr str (+ pos 1 (strlen del))) del)) (list str) ) ) ) (if (and (setq dstr (getstring t "\nEnter Distances separated by spaces: ")) (setq s (entsel "\nSelect a curve to offset: ")) (setq en (car s) cnt 0) (setq go (wcmatch (cdr (assoc 0 (entget en))) "LINE,*POLYLINE,SPLINE,XLINE,CIRCLE,ARC,ELLIPSE")) (setq op (getpoint (cadr s) "\nSelect side to Offset: ")) ) (if (setq tl (_Strparse dstr " ")) (foreach n tl (command "._offset" (nth cnt tl) en "_non" op "") (setq cnt (1+ cnt)) ) ) (if (not go)(princ "\nInvalid Object Selected.")) ) (command "._undo" "_E") (setvar "cmdecho" oc) (princ) )
    1 point
  27. Just in case you didn't know the "direct distance entry" trick, try this: Start the line command (say press L followed by <enter> or <space>). AutoCAD prompts you for the first point. Click on the screen to enter it. When AutoCAD prompts you for the next point, move the mouse to the desired place in order to define the direction (OSNAP is useful at this point!), but don't click. Leave the mouse in that place and enter from the keyboard (+ 5 2 3)<enter> That should draw the line you are after. From there you can continue the line command, meaning to draw the next line, or press <enter> again to exit. Please note that you must enter the plus sign first, a space, and next enter all the numbers to be added, separated by a space. It is not so complicated...
    1 point
  28. Welcome in the forum, Ivy Tr! I think it is possible, but how do you wish to draw the line? Maybe you wish to click the start point, an other click to define the direction, and next enter those numbers? Or if you wish less user inputs, just enter those numbers end let the program to draw a horizontal line from the origin? Please give us more data.
    1 point
  29. That's some old code... To account for variation in the UCS & View, you would need to calculate a bounding box relative to the current UCS - consider the following example: (defun c:zz ( / box sel ) (cond ( (not (setq sel (ssget)))) ( (not (setq box (LM:ucsssboundingbox sel (vlax-tmatrix (LM:transmatrix 1 0))))) (princ "\nUnable to obtain UCS selection set bounding box.") ) ( (vla-zoomwindow (vlax-get-acad-object) (vlax-3D-point (trans (car box) 1 0)) (vlax-3D-point (trans (cadr box) 1 0)) ) ) ) (princ) ) ;; UCS Selection Set Bounding Box - Lee Mac ;; Returns a list of the lower-left & upper-right UCS coordinates of a rectangular frame bounding all ;; objects in a supplied selection set following transformation by the supplied transformation matrix ;; sel - [sel] Selection set for which to return bounding box ;; mat - [var] Variant representing a 4x4 transformation matrix (defun LM:ucsssboundingbox ( sel mat / box idx ls1 ls2 obj ) (repeat (setq idx (sslength sel)) (if (setq idx (1- idx) obj (vlax-ename->vla-object (ssname sel idx)) box (LM:ucsboundingbox obj mat) ) (setq ls1 (cons (car box) ls1) ls2 (cons (cadr box) ls2) ) ) ) (if (and ls1 ls2) (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2)) ) ) ;; UCS Bounding Box - Lee Mac ;; Returns a list of the lower-left & upper-right UCS coordinates of a rectangular frame ;; bounding the supplied object following transformation by the supplied transformation matrix ;; obj - [vla] VLA-Object for which to return bounding box ;; mat - [var] Variant representing a 4x4 transformation matrix (defun LM:ucsboundingbox ( obj mat / cpy llp rtn urp ) (if (and (vlax-write-enabled-p obj) (vlax-method-applicable-p obj 'getboundingbox) (setq cpy (LM:catchapply 'vla-copy (list obj))) (LM:catchapply 'vla-transformby (list cpy mat)) (LM:catchapply 'vla-getboundingbox (list cpy 'llp 'urp)) ) (setq rtn (list (vlax-safearray->list llp) (vlax-safearray->list urp))) ) (if (and (= 'vla-object (type cpy)) (vlax-write-enabled-p cpy)) (vla-delete cpy) ) rtn ) ;; Catch Apply - Lee Mac ;; Applies a function to a list of parameters and catches any exceptions. (defun LM:catchapply ( fnc prm / rtn ) (if (not (vl-catch-all-error-p (setq rtn (vl-catch-all-apply fnc prm)))) (cond ( rtn ) ( t )) ) ) ;; Trans Matrix - Lee Mac ;; Returns a 4x4 matrix encoding a transformation from one coordinate system to another (defun LM:transmatrix ( src dst ) (append (mapcar '(lambda ( v o ) (append (trans v src dst t) (list o)) ) '( (1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0) ) (trans '(0.0 0.0 0.0) dst src) ) '((0.0 0.0 0.0 1.0)) ) ) (vl-load-com) (princ)
    1 point
  30. No problem, hoping it speeds things up a lot for you.
    1 point
  31. Tried this, i had to add pkenewell's mxv functions, and removed the non used linebreak filters, then in works perfectly! Thanks so much !! I tried this, and it removes all linebreaks, but the "defined width" seems to be super small at the end. Like 50 instead of a 9000 long text. Thanks for this anyway Love you all!
    1 point
  32. Wow, this is an old thread. The recursion used here will only cause problems for very large point lists, for which the stack limit may be reached (i.e. the size of the stack imposes a limit on the maximum number of recursive calls).
    1 point
  33. Tamim, I have updated code above - not tested and no error checking.
    1 point
  34. Likewise, I guess it will be corrected shortly.
    1 point
  35. Try this to adjust the text box width: The parts I added aren't indented for clarity of the changes, and I borrowed some code from Lee Macs Box Text LISP. The width used is a little bit wider than the widest line in the existing text - just as a starting point. Also corrected as above for //P and /n new line references. Not corrected today anything for long text strings as discussed above (that bit wasn't working right for 500+ characters). (defun c:TxtRemCR ( / MySS SSCountMyEnt MyEntGet Mytext TextList OrderList NewText n acount) ; txt remove carriage returns ;;Sub Functions: ;;Starting with LM: Refer to Lee Macs website (defun LM:str->lst ( str del / pos ) (if (setq pos (vl-string-search del str)) (cons (substr str 1 pos) (LM:str->lst (substr str (+ pos 1 (strlen del))) del)) (list str) ) ) (defun LM:lst->str ( lst del ) (if (cdr lst) (strcat (car lst) del (LM:lst->str (cdr lst) del)) (car lst) ) ) ;; From Box Text LISP ;; Text Box - gile / Lee Mac ;; Returns an OCS point list describing a rectangular frame surrounding ;; the supplied text or mtext entity with optional offset ;; enx - [lst] Text or MText DXF data list ;; off - [rea] offset (may be zero) (defun text-box-off ( enx off / bpt hgt jus lst ocs org rot wid ) ;;; VXV Returns the dot product of 2 vectors (defun vxv (v1 v2) (apply '+ (mapcar '* v1 v2)) ) ;; MXV Apply a transformation matrix to a vector -Vladimir Nesterovsky- (defun mxv (m v) (mapcar '(lambda (r) (vxv r v)) m) ) (cond ( (= "TEXT" (cdr (assoc 00 enx))) (setq bpt (cdr (assoc 10 enx)) rot (cdr (assoc 50 enx)) lst (textbox enx) lst (list (list (- (caar lst) off) (- (cadar lst) off)) (list (+ (caadr lst) off) (- (cadar lst) off)) (list (+ (caadr lst) off) (+ (cadadr lst) off)) (list (- (caar lst) off) (+ (cadadr lst) off)) ) ) ) ( (= "MTEXT" (cdr (assoc 00 enx))) (setq ocs (cdr (assoc 210 enx)) bpt (trans (cdr (assoc 10 enx)) 0 ocs) rot (angle '(0.0 0.0) (trans (cdr (assoc 11 enx)) 0 ocs)) wid (cdr (assoc 42 enx)) hgt (cdr (assoc 43 enx)) jus (cdr (assoc 71 enx)) org (list (cond ((member jus '(2 5 8)) (/ wid -2.0)) ((member jus '(3 6 9)) (- wid)) (0.0)) (cond ((member jus '(1 2 3)) (- hgt)) ((member jus '(4 5 6)) (/ hgt -2.0)) (0.0)) ) lst (list (list (- (car org) off) (- (cadr org) off)) (list (+ (car org) wid off) (- (cadr org) off)) (list (+ (car org) wid off) (+ (cadr org) hgt off)) (list (- (car org) off) (+ (cadr org) hgt off)) ) ) ) ) (if lst ( (lambda ( m ) (mapcar '(lambda ( p ) (mapcar '+ (mxv m p) bpt)) lst)) (list (list (cos rot) (sin (- rot)) 0.0) (list (sin rot) (cos rot) 0.0) '(0.0 0.0 1.0) ) ) ) ) (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object))) (princ "\nSelect MText") ;; Note in command line "Select text" (setq MySS (ssget '((0 . "MTEXT")))) ;; Select objects with a selection set, filtered to 'MTEXT' entity type (setq SSCount 0) ;; Just a counter set to 0 (while (< SSCount (sslength MySS)) ;; loop through length or selection set using SSCount (vla-startundomark thisdrawing) ;;Undo mark start for each text (setq MyEnt (ssname MySS SSCount)) ;; get the nth item in the selection set entity name (setq MyEntGet (entget MyEnt)) ;; get the entity definition from the above (setq MTextCoords (text-box-off MyEntGet 1)) ;;Use sub function above to get text coordinates (setq MyText (cdr (assoc 1 MyEntGet))) ;; get the text from the entity (first 256 characters) (if (vl-string-search "\P" MyText) (setq del "\\P")) ; adjust depends on new line character used (if (vl-string-search "\p" MyText) (setq del "\\p")) ; adjust depends on new line character used (if (vl-string-search "\N" MyText) (setq del "\N")) ; adjust depends on new line character used (if (vl-string-search "\n" MyText) (setq del "\n")) ; adjust depends on new line character used (setq TextList (LM:str->lst MyText del)) ;; Convert the text string to a list, (setq MyEntGet (subst (cons 1 (LM:lst->str TextList " ")) (assoc 1 MyEntGet) MyEntGet)) (setq MTextWidth (Distance (car MTextCoords) (cadr MTextCoords))) ;; Existing text width (setq MyEntGet (subst (cons 41 MTextWidth) (assoc 41 MyEntGet) MyEntGet)) ;; Adjust modified text width (entmod MyEntGet) ;; Modify the text (vla-endundomark thisdrawing) ;;End undo mark for this text string (setq SSCount (+ SSCount 1)) ) ; end while (princ) ); end function
    1 point
  36. Also, I did not explain that the application that writes the xlsx file to be read by AutoCAD is not AutoCAD. It is GPS software from another party. It writes out 13(?) decimals to the xlsx file, but I cannot get AutoCAD to read in more than 4 decimal places. Now I am wondering. I only looked at the number of decimal places in the AutoCAD vlisp editor and on the command line. Turns out I'm an idiot. If I do (RTOS Lat 2 13) of the latitude read in by AutoCAD, all the decimal digits are there. AutoCAD only returns the 1st four to the display. Having started lisp at v10 286, I'm pretty embarrassed to admit how many years I've know this. My sincere apologies for wasting your collective time.
    1 point
  37. @Tharwat Are you sure? I tested your exact original code, and it left behind a "P" where every line break was. Am I missing something? Just did it again to be sure. That's why I did the 2nd post afterwards.
    1 point
  38. Why didn't you say so before!! While we are taking out the line breaks adjusting the mtext width is able to be done at the same time The methods use above are using "entmod" to adjust the text, also in the entity definition is the code 41 which is the mtext width code something like: (if (= (cdr (assoc 41) 0) will find out if they are 0 width, and we can set a nominal width or calculate a width according to the font and number of characters used in each line I am going out this evening but might have a look at this later
    1 point
  39. Hi @Pixel_Outlaw, I'm the author of BabaCAD software and I just want to encourage you to start programming lisp in BabaCAD. There are so many users (more and more every day) switching to BabaCAD because of it's low price and because it has Lisp support, but also for developers, there are also C# (dot.Net) and VisualBasic programming API and soon there will be Python API for BabaCAD Home users. You can use your knowledge and experience in Lisp programming to help BabaCAD users to speed up their drafting work. I'm ready to put your contact (for free, no obligations) as a BabaCAD lisp developer on BabaCAD's website main page, so please feel free to contact me.
    1 point
  40. The LISP program below will determine the instantaneous radius of curvature for multiple points along a spline then draw a line from the point on the spline to its center of curvature. For example, in the image below the yellow spline has an approximate arc segment where it is near the green circle. Responding y to the SplineCurvatue command yields: Each white line goes from the spline to the center of curvature for that point. Since we are interested only in the portion of the spline that runs along the circle we can delete most of the other radial lines yielding the following. The center for the approximating arc would be in the area noted in red. If the spline more closely fit an arc the line ends would be closer togther. The program provides good feedback as to how "arc-like" a portion of a spline may be. It can be used on 2D and 3D splines. The program can also display the curvature of a spline (the inverse of the radius of curvature) where a short line shows where the spline is almost flat and longer lines indicate a tighter radius of curvature. Note, an exact 90° arc can be created with a spline with 3 Control Vertices as show below in red against a green circle. The weight of the first and third CV is 1 and the second CV weight is 0.7070 = (square root of 2)/2. As can be seen here all the lines for the instanteous centers converge to the same point. (defun C:SplineCurvatue (/ path inc n osm par der1 der2 curva p perp normv p2 sf curveType ans) ; = Degree Of Curvature - Lines ; Creates curvature lines or radius-of-curvature lines ; normal to a spline. ; LRM 8/18/2022 edited to place curvature vectors outside (setq path (car (entsel)) inc (/ (vlax-curve-getEndParam path) 100) n 0 osm (getvar 'osmode) ) (setvar 'osmode 0) (setvar "cmdecho" 0) (initget "y n") (setq ans (getkword "Do you want radius-of-curvature instead of curvature? [y/n] <n>: ")) (if (= ans "y") (setq curveType 1) (setq curveType 2 sf (getdist "Enter scale factor.") ) ) (repeat 100 (setq par (* inc n)) (setq der1 (vlax-curve-getfirstDeriv path par) der2 (vlax-curve-getSecondDeriv path par) ) ; calculate curvature at point par (setq d (distance '(0 0 0) (cross der1 der2))) (if (> (abs d) 1.0e-15) (progn (setq curva (/ (expt (distance '(0 0 0) der1) 3) d)) (if (= curveType 2) (setq curva (* -1. (* sf (/ 1. curva)))) ) (princ "\n") (princ n) (princ " curvature = ") (princ curva) (setq p (vlax-curve-getPointAtParam path par) perp (unitv (cross der1 (cross der2 der1))) normv (mapcar '* perp (list curva curva curva)) p2 (mapcar '+ p normv) ) (command "_.line" p p2 "") ) ; end progn ) (setq n (1+ n)) ) (setvar 'osmode osm) (setvar "cmdecho" 1) (princ) ) ;;; Compute the cross product of 2 vectors a and b (defun cross (a b / crs) (setq crs (list (- (* (nth 1 a) (nth 2 b)) (* (nth 1 b) (nth 2 a)) ) (- (* (nth 0 b) (nth 2 a)) (* (nth 0 a) (nth 2 b)) ) (- (* (nth 0 a) (nth 1 b)) (* (nth 0 b) (nth 1 a)) ) ) ;end list ) ;end setq c ) ;end cross (defun unitV ( v / d) (setq d (distance '(0 0 0) v) d (mapcar '/ v (list d d d))))
    1 point
  41. You're in double luck.... I created a a similar routine in the same thread as pkenewell, an alternative method. Likewise, the same text length limit applies - can adjust these if that becomes an issue (for most things, 256 characters is usually enough except a notes block of text) (defun c:TxtRemCR ( / MySS SSCountMyEnt MyEntGet Mytext TextList OrderList NewText n acount) ; txt remove carriage returns ;;Sub Functions: ;;Starting with LM: Refer to Lee Macs website (defun LM:str->lst ( str del / pos ) (if (setq pos (vl-string-search del str)) (cons (substr str 1 pos) (LM:str->lst (substr str (+ pos 1 (strlen del))) del)) (list str) ) ) (defun LM:lst->str ( lst del ) (if (cdr lst) (strcat (car lst) del (LM:lst->str (cdr lst) del)) (car lst) ) ) (princ "\nSelect MText") ;; Note in command line "Select text" (setq MySS (ssget '((0 . "MTEXT")))) ;; Select objects with a selection set, filtered to 'MTEXT' entity type (setq SSCount 0) ;; Just a counter set to 0 (while (< SSCount (sslength MySS)) ;; loop through length or selection set using SSCount (setq MyEnt (ssname MySS SSCount)) ;; get the nth item in the selection set entity name (setq MyEntGet (entget MyEnt)) ;; get the entity definition from the above (setq MyText (cdr (assoc 1 MyEntGet))) ;; get the text from the entity (first 256 characters) (setq TextList (LM:str->lst MyText "\n")) ;; Convert the text string to a list, deliminator \n (new line) (setq MyEntGet (subst (cons 1 (LM:lst->str TextList " ")) (assoc 1 MyEntGet) MyEntGet)) (entmod MyEntGet) ;; Modify the text (setq SSCount (+ SSCount 1)) ) ; end while ); end function
    1 point
  42. @jim78b OOPS - I made a slight change to the routine above. Re-copy it from the post. I realized it changes everything to color 200, rather than changing everything inside blocks to ByBlock. corrected.
    1 point
  43. @Highvoltage You're in luck. I just created a very similar routine for another poster. In addition to the problem with (vl-string-subst), one of other the problems with using DXF is sometimes the mtext string is separated into multiple DXF codes if the text is more than 250 chars. The additional codes use DXF code 3 instead of 1. It's better to get the full text string using ActiveX and parsing it. Try the following instead: (defun c:mbch (/ _StrParse d obj ss tls txt) (vl-load-com) (vla-StartUndoMark (setq d (vla-get-activedocument (vlax-get-acad-object)))) (defun _StrParse (str del / pos) (if (and str del) (if (setq pos (vl-string-search del str)) (cons (substr str 1 pos) (_StrParse (substr str (+ pos 1 (strlen del))) del)) (list str) ) ) ) (princ "\nSelect MTEXT Objects: ") (if (setq ss (ssget '((0 . "MTEXT")))) (repeat (setq n (sslength ss)) (setq obj (vlax-ename->vla-object (ssname ss (setq n (1- n)))) txt (vla-get-textstring obj) tls (_strparse txt "\\P") ) (if (> (length tls) 1) (setq txt (apply 'strcat (cons (car tls)(mapcar '(lambda (x)(strcat " " x)) (cdr tls)))) obj (vla-put-textstring obj txt) ) ) ) ) (redraw) (vla-endundomark d) (princ) )
    1 point
  44. Nice code Lee as usual maybe OP has limited lisp experience added a couple of extras. (defun c:pretext ( / p ) (if (/= "" (setq p (getstring t "\nSpecify prefix: "))) (pstext p "" 1)) (princ) ) (defun c:sufftext ( / s ) (if (/= "" (setq s (getstring t "\nSpecify suffix: "))) (pstext "" s 1)) (princ) ) (defun c:presuff( / p s) (if (and (/= "" (setq p (getstring t "\nSpecify prefix: "))) (/= "" (setq s (getstring t "\nSpecify suffix: "))) ) (pstext p s 1) ) (princ) )
    1 point
  45. Using the code found here, you can define a program such as the following: (defun c:pretext ( / p ) (if (/= "" (setq p (getstring t "\nSpecify prefix: "))) (pstext p "" 1)) (princ) ) ;; (pstext "Prefix Text" "Suffix Text" <mode>) ;; ;; <mode> = 0 - single selection ;; = 1 - window selection ;; ;; Author: Lee Mac 2011 - www.lee-mac.com (defun pstext ( preftext sufftext mode / a e i s ) (cond ( (= 0 mode) (while (progn (setvar 'ERRNO 0) (setq e (car (nentsel))) (cond ( (= 7 (getvar 'ERRNO)) (princ "\nMissed, try again.") ) ( (eq 'ENAME (type e)) (if (wcmatch (cdr (assoc 0 (entget e))) "TEXT,MTEXT,ATTRIB") (entmod (setq e (entget e) a (assoc 1 e) e (subst (cons 1 (strcat preftext (cdr a) sufftext)) a e) ) ) (princ "\nInvalid Object.") ) ) ) ) ) ) ( (setq s (ssget "_:L" (list '(0 . "TEXT,MTEXT")))) (repeat (setq i (sslength s)) (entmod (setq e (entget (ssname s (setq i (1- i)))) a (assoc 1 e) e (subst (cons 1 (strcat preftext (cdr a) sufftext)) a e) ) ) ) ) ) (princ) ) The command for the above is pretext.
    1 point
  46. In fact my intention was simple, in order to clean up the [BBcodes] within the new code tags in this forum. Therefore, IMO optimized with CLIPBOARD without using 'getfiled' is much more convenient, isn't it? code updated - post#1 Copy text (from forum) -> run 'FORUM' (in ACAD) -> [Ctrl+V] Paste (in forum active editor) Done!
    1 point
  47. p/s: i recall there was discussions regarding LISP code tags schema at theswamp.org but i couldn't find it now
    1 point
  48. Use the getstring function to prompt the user for the prefix/suffix, e.g.: (defun c:test ( ) (pstext (getstring t "\nSpecify Prefix <none>: ") (getstring t "\nSpecify Suffix <none>: ") 1) )
    1 point
  49. Apologies... won't let me upload a DCL... erm, try this zip of it... I've run it on 2006/7/8 stripmtext[3].zip
    1 point
  50. I use one called stripmtext.lsp but I suspect it does essentially the same thing... stripmtext[308].lsp
    1 point
×
×
  • Create New...