Jump to content

Leaderboard

Popular Content

Showing content with the highest reputation on 03/21/2022 in all areas

  1. Because I didn't edit anything of "LH" in that post, haha I still don't know what LH wants, but looking at additional your code, it seems that you want to make a loft hatch so that not only ucs but also the view is displayed vertically on the screen even when the view is rotated. So I merged your two lisp into one and removed the select part. I hope this helps you. ; command list - 2022.03.21 ; TT - Creates the first text, continues the text on the bottom line. (regardless of UCS) ; UT - Selects text that already exists, and creates text from the bottom line (regardless of UCS) ; LH - "Loft Hatch" is created as MTEXT. (Regardless of the angle of the view) (defun c:TT (/ *error* lll osm edp txt e en2 en3 type1 ) (setvar "cmdecho" 0) (LM:startundo (LM:acdoc)) ;error control (defun *error* ( msg ) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar "cmdecho" 1) (princ) ) (graphscr) (setq lll (getvar "clayer")) (setq osm (getvar "osmode")) (command "osnap" "none") (command "layer" "m" "GTEXT" "") (setq edp (getpoint "\n pick point for first text - ")) (setq txt (getstring t "\n input first text value - ")) (command "TEXT" "C" edp "" 0.0 txt) (setq e (entget (entlast))) (setq en2(cdr(assoc -1 e))) (setq en3(entget en2)) (textun) (setvar "osmode" osm) (command "layer" "S" lll "") (setvar "cmdecho" 1) (LM:endundo (LM:acdoc)) (princ) ) (vl-load-com) (defun textun ( / ) (setq txt (getstring t "\n input text - ")) (if (= txt "") (progn (princ "\n end process \n")) (progn (setq textlocation '()) (setq putlocation '()) (setq ss0 (ssadd en2)) (setq lst (LM:textbox en3)) (setq ang (angle (car lst) (last lst))) (setq textsize (cdr (assoc 40 en3))) (setq textlocation (trans (cdr (assoc 10 en3)) 0 1)) (setq ucsang (angle '(0 0) (getvar "ucsxdir"))) (setq ang (- ang ucsang)) (setq putlocation (polar textlocation (+ ang pi) (* textsize 1.5) )) ;(princ "\n ang - ") ;(princ ang) (command "copy" ss0 "" textlocation putlocation) (setq ename2 (entlast)) (setq obj2 (vlax-ename->vla-object ename2)) ;(vla-put-alignment obj2 1) (vla-put-textstring obj2 txt) (setq en2 (vlax-vla-object->ename obj2)) (setq en3 (entget en2)) (textun) );end of progn );end of if (princ) ) (defun c:UT (/ *error* style1 layer1 size1 col2 col3 en1 en2 en3 type1 ) (setvar "cmdecho" 0) (LM:startundo (LM:acdoc)) ;error control (defun *error* ( msg ) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar "cmdecho" 1) (princ) ) (graphscr) ; (setq style1 (getvar "TEXTSTYLE")) ; (setq layer1 (getvar "CLAYER")) ; (setq size1 (GETVAR "TEXTSIZE")) ; (setq col2 (GETVAR "CECOLOR")) ; (setq col3 (atoi COL2)) ;;;SELECT TEXT TO UNDERWRITE (setq en1 (entsel "\n Select the TEXT to write under - ")) (while (= en1 nil) (alert "\n No TEXT selected") (setq en1 (entsel "\n Select the TEXT to write under - ")) );end of while (setq en2 (car en1)) (setq en3 (entget en2)) ;;;CHECK TO SEE IF TEXT OR MTEXT (setq type1 (cdr (assoc 0 en3))) (if (= type1 "MTEXT") (command "DDEDIT" en1 "") (textun) ) ;;;RESET EXISTING VALUES ; (setvar "TEXTSIZE" size1) ; (setvar "TEXTSTYLE" style1) ; (setvar "CLAYER" layer1) ; (setvar "CECOLOR" col2) (setvar "cmdecho" 1) (LM:endundo (LM:acdoc)) (princ) ) (defun c:LH (/ *error* lll osm edp mspace mtext vta tbmtext midpt ) (setvar "cmdecho" 0) (LM:startundo (LM:acdoc)) ;error control (defun *error* ( msg ) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar "cmdecho" 1) (princ) ) (graphscr) (setq lll (getvar "clayer")) (setq osm (getvar "osmode")) (command "OSNAP" "INTERSECTION") (command "layer" "m" "GTEXT" "") (setq edp (getpoint "\n pick point for Loft Hatch - ")) ;(command "MTEXT" edp "_Justify" "MC" "_none" "@" "Loft" "hatch" "") (setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))) (setq mtext (vla-AddMText mspace (vlax-3d-point (trans edp 1 0)) 0 "Loft\nHatch")) (setvar "OSMODE" osm) (command "LAYER" "S" lll "") (setq vta (- 0 (getvar "viewtwist"))) (vla-put-rotation mtext vta) (vla-put-AttachmentPoint mtext acBottomCenter) (setq tbmtext (LM:textbox (entget (vlax-vla-object->ename mtext)))) (setq midpt (mid (car tbmtext) (caddr tbmtext)) ) (vla-move mtext (vlax-3d-point midpt) (vlax-3d-point edp)) (setvar "cmdecho" 1) (LM:endundo (LM:acdoc)) (princ) ) ;; Active Document - Lee Mac ;; Returns the VLA Active Document Object (defun LM:acdoc nil (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object)))) (LM:acdoc) ) ;; Start Undo - Lee Mac ;; Opens an Undo Group. (defun LM:startundo ( doc ) (LM:endundo doc) (vla-startundomark doc) ) ;; End Undo - Lee Mac ;; Closes an Undo Group. (defun LM:endundo ( doc ) (while (= 8 (logand 8 (getvar 'undoctl))) (vla-endundomark doc) ) ) ;; Text Box - Lee Mac (based on code by gile) ;; Returns the bounding box of a text, mtext, or attribute entity (in OCS) ;; enx - [lst] Text, MText or Attribute DXF data list (defun LM:textbox ( enx / bpt hgt jus lst ocs org rot wid ) (cond ( (and (= "ATTRIB" (cdr (assoc 000 enx))) (= "Embedded Object" (cdr (assoc 101 enx))) ) (LM:textbox (cons '(000 . "MTEXT") (member '(101 . "Embedded Object") enx))) ) ( (cond ( (wcmatch (cdr (assoc 000 enx)) "ATTRIB,TEXT") (setq bpt (cdr (assoc 010 enx)) rot (cdr (assoc 050 enx)) lst (textbox enx) lst (list (car lst) (list (caadr lst) (cadar lst)) (cadr lst) (list (caar lst) (cadadr lst))) ) ) ( (= "MTEXT" (cdr (assoc 000 enx))) (setq ocs (cdr (assoc 210 enx)) bpt (trans (cdr (assoc 010 enx)) 0 ocs) rot (angle '(0.0 0.0) (trans (cdr (assoc 011 enx)) 0 ocs)) wid (cdr (assoc 042 enx)) hgt (cdr (assoc 043 enx)) jus (cdr (assoc 071 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 org (mapcar '+ org (list wid 0)) (mapcar '+ org (list wid hgt)) (mapcar '+ org (list 0 hgt))) ) ) ) ( (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) ) ) ) ) ) (princ "\n loading complete") LH's steps are as follows: 1. Create an mtext at the specified point. In this case, the automatically selected MTEXT insertion point is upper left. 2. Rotate by "0 - viewtwist value" to compensate the viewtwist value. 3. Change the attachment point to bottom center. At this point, the position of the text is changed. (not like TJUST command) 4. Find the midpoint of the mtext and move the mtext from midpoint to the specified point step1 without changing the attachment point property. If any of these steps are incorrect, you can correct them. + Line spacing between texts in TT and UT is changed by modifying "1.5" of "(* textsize 1.5)."
    1 point
  2. Do you have large or many xrefs attached?
    1 point
  3. I'm afraid you are suffering from limited computer resources. AutoCAD NEEDS a powerful aftermarket graphics processor. Do you have a green or blue progress bar appear at the lower right of the task bar when this happens? If so try checking in your options dialog and/or the help file (F1) for when the program does an automatic REGEN and an automatic SAVE. Either one can cause what you are experiencing if set for too frequent actions. However, without sufficient video processing power it will occasionally be a problem anyway.
    1 point
  4. Something like this. (setq a 3) ;size to test (if (setq ss (ssget '((0 . "*POLYLINE")(70 . 1)))) ;select only closed poly for correct area (foreach poly (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) (if (< (vla-get-area (vlax-ename->vla-object poly)) a) (ssdel poly SS) ;remove any polylines that are to small ) ) )
    1 point
  5. There is another post trying to find it again by Andrea and a routine called "entgui" it shows all the detail of an entity even down the rabbit hole with block attributes, I posted a PM but no return.
    1 point
  6. For Exceed 2 columns just never posted it. I was going to make a new multi radio buttons that could have as many columns as you like so a list of lists approach 1 -> a practical limit. The other thing I think its in Multi getvals if only a few items has double spacing could add also to radio buttons. (cond ((= answer "return-to-origin") (ex:mic)) ((= answer "red") (ex:mip 1)) ((= answer "yellow") (ex:mip 2)) (cond ((= but 1) (ex:mic)) ((= but 2) (ex:mip 1)) ((= but 3) (ex:mip 2)) Multi radio buttons 2col.lsp
    1 point
×
×
  • Create New...