alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Display directional arrow ;;; #Location - arrow placement point ;;; #Angle - arrow directional angle ;;; Alan J. Thompson, 04.28.09 (defun AT:Arrow (#Location #Angle / #Size #Point1 #Point2 #Point3) (setq #Size (* (getvar "viewsize") 0.02) #Point1 (polar #Location #Angle #Size) #Point2 (polar #Location (+ #Angle (* pi 0.85)) #Size) #Point3 (polar #Location (+ #Angle (* pi 1.15)) #Size) ) ;_ setq (grvecs (list 4 #Point1 #Point2 #Point2 #Point3 #Point3 #Point1) ) ;_ grvecs ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Egg Timer for calculating run time in milliseconds ;;; Alan J. Thompson, 03.22.09 ;;; Argument: #StartStop - 1 for begin, 0 for end (defun AT:EggTimer (#StartStop) (cond ((eq 1 #StartStop) (setq *EggTimer* (getvar "millisecs"))) ((eq 0 #StartStop) (if *EggTimer* (progn (alert (strcat "Process Time: " (rtos (- (getvar "millisecs") *EggTimer*)) " Milliseconds" ) ;_ strcat ) ;_ alert (setq *EggTimer* nil) ) ;_ progn ) ;_ if ) ) ;_ cond ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Draw a square with an "X" in the middle (grdraw) ;;; Alan J. Thompson, 04.07.09 (defun AT:Square (#Point / #Dist) (setq #Dist (* (getvar "VIEWSIZE") 0.1)) ;; RIGHT (grdraw (trans (polar #Point (* 0.25 pi) #Dist) 0 1) (trans (polar #Point (* 1.75 pi) #Dist) 0 1) 1 ) ;_ grdraw ;; BOTTOM (grdraw (trans (polar #Point (* 1.75 pi) #Dist) 0 1) (trans (polar #Point (* 1.25 pi) #Dist) 0 1) 2 ) ;_ grdraw ;; LEFT (grdraw (trans (polar #Point (* 1.25 pi) #Dist) 0 1) (trans (polar #Point (* 0.75 pi) #Dist) 0 1) 3 ) ;_ grdraw ;; TOP (grdraw (trans (polar #Point (* 0.75 pi) #Dist) 0 1) (trans (polar #Point (* 0.25 pi) #Dist) 0 1) 4 ) ;_ grdraw ;; X IN MIDDLE (TR->BL) (grdraw (trans (polar #Point (* 0.25 pi) #Dist) 0 1) (trans (polar #Point (* 1.25 pi) #Dist) 0 1) 7 ) ;_ grdraw ;; X IN MIDDLE (TL->BR) (grdraw (trans (polar #Point (* 0.75 pi) #Dist) 0 1) (trans (polar #Point (* 1.75 pi) #Dist) 0 1) 7 ) ;_ grdraw ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Convert color number to string and give ;;; color name if number is between 1 and 7 ;;; #ColorNumber - color number to process ;;; Alan J. Thompson, 06.16.09 (defun AT:ColorFix (#ColorNumber) (if (numberp #ColorNumber) (cond ((eq 1 #ColorNumber) "Red") ((eq 2 #ColorNumber) "Yellow") ((eq 3 #ColorNumber) "Green") ((eq 4 #ColorNumber) "Cyan") ((eq 5 #ColorNumber) "Blue") ((eq 6 #ColorNumber) "Magenta") ((eq 7 #ColorNumber) "White") (T (itoa #ColorNumber)) ) ;_ cond ) ;_ if ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; VLA entsel replacement (returns entsel or ENAME as VLA-OBJECT) ;;; #EntityOrMessage - nil: entsel-style selection ;;; "string": will display selection message with entsel-style selection ;;; Selection: convert to VLA-OBJECT ;;; Alan J. Thompson, 08.11.09 (defun AT:VlaSel (#EntityOrMessage / #EntityOrMessage #VlaObject) (or #EntityOrMessage (setq #EntityOrMessage "\nSelect object: ") ) ;_ or (cond ((vl-consp #EntityOrMessage) (setq #VlaObject (vlax-ename->vla-object (car #EntityOrMessage))) ) ((eq (type #EntityOrMessage) 'STR) (setvar "errno" 0) (if (while (and (not #VlaObject) (/= 52 (getvar "errno")) ) ;_ and (setq #VlaObject (entsel #EntityOrMessage)) ) ;_ while (setq #VlaObject (vlax-ename->vla-object (car #VlaObject))) ) ;_ if ) ((eq (type #EntityOrMessage) 'ENAME) (setq #VlaObject (vlax-ename->vla-object #EntityOrMessage)) ) ) ;_ cond ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Entsel or NEntsel with options ;;; #Nested - Entsel or Nentsel (T for Nentsel, nil for Entsel) ;;; #Message - Selection message (if nil, "\nSelect object: " is used) ;;; #FilterList - DXF ssget style filtering (nil if not required) ;;; "V" as first item in list to convert object to VLA-OBJECT (must be in list if no DXF filtering) ;;; "L" as first item in list to ignore locked layers (must be in list if no DXF filtering) ;;; #Keywords - Keywords to match instead of object selection (nil if not required) ;;; Example: (AT:Entsel nil "\nSelect MText not on 0 layer [settings]: " '("LV" (0 . "MTEXT")(8 . "~0")) "Settings") ;;; Example: (AT:Entsel T "\nSelect object [settings]: " '("LV") "Settings") ;;; Alan J. Thompson, 04.16.09 ;;; Updated: Alan J. Thompson, 06.04.09 (changed filter coding to work as ssget style dxf filtering) ;;; Updated: Alan J. Thompson, 09.07.09 (added option to ignore locked layers and convert object to VLA-OBJECT ;;; Updated: Alan J. Thompson, 09.18.09 (fixed 'missed pick' alert) (defun AT:Entsel (#Nested #Message #FilterList #Keywords / #Count #Message #Choice #Ent #VLA&Locked #FilterList ) (vl-load-com) (setvar "errno" 0) (setq #Count 0) ;; fix message (or #Message (setq #Message "\nSelect object: ")) ;; set entsel/nentsel (if #Nested (setq #Choice nentsel) (setq #Choice entsel) ) ;_ if ;; check if option to convert to vla-object or ignore locked layers in #FilterList variable (and (vl-consp #FilterList) (eq (type (car #FilterList)) 'STR) (setq #VLA&Locked (car #FilterList) #FilterList (cdr #FilterList) ) ;_ setq ) ;_ and ;; select object (while (and (not #Ent) (/= (getvar "errno") 52)) ;; if keywords (and #Keywords (initget #Keywords)) (cond ((setq #Ent (#Choice #Message)) ;; if ignore locked layers (and #VLA&Locked (vl-consp #Ent) (wcmatch (strcase #VLA&Locked) "*L*") (not (zerop (cdr (assoc 70 (entget (tblobjname "layer" (cdr (assoc 8 (entget (car #Ent)))) ) ;_ tblobjname ) ;_ entget ) ;_ assoc ) ;_ cdr ) ;_ zerop ) ;_ not (setq #Ent nil #Flag T ) ;_ setq ) ;_ and ;; #FilterList check (if (and #FilterList (vl-consp #Ent)) ;; process filtering from #FilterList (or (not (member nil (mapcar '(lambda (x) (wcmatch (strcase (vl-princ-to-string (cdr (assoc (car x) (entget (car #Ent)))) ) ;_ vl-princ-to-string ) ;_ strcase (strcase (vl-princ-to-string (cdr x))) ) ;_ wcmatch ) ;_ lambda #FilterList ) ;_ mapcar ) ;_ member ) ;_ not (setq #Ent nil #Flag T ) ;_ setq ) ;_ or ) ;_ if ) ) ;_ cond (and (or (= (getvar "errno") 7) #Flag) (/= (getvar "errno") 52) (not #Ent) (setq #Count (1+ #Count)) (prompt (strcat "\nNope, keep trying! " (itoa #Count) " missed pick(s)." ) ;_ strcat ) ;_ prompt ) ;_ and ) ;_ while (if (and (vl-consp #Ent) #VLA&Locked (wcmatch (strcase #VLA&Locked) "*V*") ) ;_ and (vlax-ename->vla-object (car #Ent)) #Ent ) ;_ if ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Convert selection set to list of ename or vla objects ;;; #Selection - SSGET selection set ;;; #VLAList - T for vla objects, nil for ename ;;; Alan J. Thompson, 04.20.09 (defun AT:SS->List (#Selection #VlaList / #List) (and #Selection (setq #List (vl-remove-if 'listp (mapcar 'cadr (ssnamex #Selection)) ) ;_ vl-remove-if ) ;_ setq #VlaList (setq #List (mapcar 'vlax-ename->vla-object #List)) ) ;_ and #List ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Convert list of vla or ename objects to 1 selection set ;;; #SelectionList - list of vla or ename selections ;;; Alan J. Thompson, 05.07.09 (defun AT:List->SS (#SelectionList / #SSAdd) (setq #SSAdd (ssadd)) (mapcar '(lambda (x) (if (eq (type x) 'VLA-OBJECT) (ssadd (vlax-vla-object->ename x) #SSAdd) (ssadd x #SSAdd) ) ;_ if ) ;_ lambda #SelectionList ) ;_ mapcar #SSAdd ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Tab filter for ssget selection filtering ;;; Alan J. Thompson, 06.05.09 (defun AT:TabFilter (/) (if (eq 2 (getvar "cvport")) (cons 410 "Model") (cons 410 (getvar "ctab")) ) ;_ if ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Remove all spaces from string ;;; Alan J. Thompson, 03.20.09 (defun AT:NoSpaces (#String / #String) (while (vl-string-search " " #String) (setq #String (vl-string-subst "" " " #String)) ) ;_ while ) ;_ defun ;;; Remove all extra spaces from string ;;; Alan J. Thompson, 03.20.09 (defun AT:NoExtraSpaces (#String / #String) (vl-string-trim " " (while (vl-string-search " " #String) (setq #String (vl-string-subst "" " " #String)) ) ;_ while ) ;_ vl-string-trim ) ;_ defun ;;; Remove/Add Carriage Returns From String ;;; #String - The string. ;;; #Alternate: Replacement for or to be replaced with carriage return ;;; Alan J. Thompson, 03.20.09 (defun AT:CarriageToggle (#String #Alternate / #Find #Replace #String) (if (vl-string-search "\\P" #String) (setq #Find "\\P" #Replace #Alternate ) ;_ setq (setq #Find #Alternate #Replace "\\P" ) ;_ setq ) ;_ if (while (or (vl-string-search #Find #String) (vl-string-search (strcat #Replace #Replace) #String) ) ;_ and (setq #String (vl-string-subst #Replace (strcat #Replace #Replace) (vl-string-subst #Replace #Find #String) ) ;_ vl-string-subst ) ;_ setq ) ;_ while ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; List of Multileader Style VLA-Objects in drawing ;;; Alan J. Thompson, 06.15.09 (defun AT:MLeaderStyleObjList (/) (vl-remove-if 'null (mapcar '(lambda (x) (if (eq 350 (car x)) (vlax-ename->vla-object (cdr x)) ) ;_ if ) ;_ lambda (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE") ) ;_ mapcar ) ;_ vl-remove-if ) ;_ defun ;;; List of dimension styles in drawing (with or w/o child styles) ;;; #ChildStyles - T for child styles, nil to ignore ;;; Alan J. Thompson, 06.18.09 (defun AT:DimStyleObjList (#ChildStyles / #List) (vlax-for x (vla-get-dimstyles (vla-get-activedocument (vlax-get-acad-object) ) ;_ vla-get-activedocument ) ;_ vla-get-dimstyles (setq #List (cons x #List)) ) ;_ vlax-for (if #ChildStyles #List (vl-remove-if '(lambda (x) (wcmatch (vla-get-name x) "*$*")) #List ) ;_ vl-remove-if ) ;_ if ) ;_ defun ;;; Convert existing dimstyle to VLA-Object ;;; #DimStyleName - name of dimension style ;;; Alan J. Thompson, 06.18.09 (defun AT:DimStyleObj (#DimStyleName / #Obj) (and (tblsearch "dimstyle" #DimStyleName) (setq #Obj (vla-item (vla-get-dimstyles (vla-get-activedocument (vlax-get-acad-object) ) ;_ vla-get-activedocument ) ;_ vla-get-dimstyles #DimStyleName ) ;_ vla-item ) ;_ setq ) ;_ and #Obj ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Retreive current UCS angle ;;; Alan J. Thompson, 03.09.09 (defun AT:UCSAngle (/ xdir) (setq xdir (getvar "ucsxdir")) (atan (cadr xdir) (car xdir)) ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 LoL :twisted::twisted: Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Release object (VLA) ;;; Alan J. Thompson, 04.23.09 (defun AT:Release (#Object) (and (eq (type #Object) 'VLA-OBJECT) (vl-catch-all-apply 'vlax-release-object (list #Object)) ) ;_ and ) ;_ defun ;;; Send string to commandline ;;; #String - String to send ;;; Alan J. Thompson, 04.28.09 (defun AT:Send (#String) (if (eq (type #String) 'STR) (vla-sendcommand (vla-get-activedocument (vlax-get-acad-object) ) ;_ vla-get-activedocument #String ) ;_ vla-sendcommand ) ;_ if ) ;_ defun ;;; Regenerate active view ;;; Alan J. Thompson, 04.28.09 (defun AT:Regen (/) (vla-Regen (vla-get-ActiveDocument (vlax-get-Acad-Object)) acActiveViewport ) ;_ vla-Regen ) ;_ defun ;;; Save active drawing ;;; Alan J. Thompson, 05.26.09 (defun AT:Save (/) (vla-save (vla-get-activedocument (vlax-get-acad-object) ) ;_ vla-get-activedocument ) ;_ vla-save ) ;_ defun ;;; Zoom Window a specified area ;;; #Point1 - 1st corner of window ;;; #Point2 - 2nd corner of window ;;; Alan J. Thompson, 06.04.09 (defun AT:ZoomWindow (#Point1 #Point2) (and (vl-consp #Point1) (vl-consp #Point2) (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point #Point1) (vlax-3d-point #Point2) ) ;_ vla-zoomwindow ) ;_ and ) ;_ defun ;;; Zoom Extents ;;; Alan J. Thompson, 06.04.09 (defun AT:ZoomExtents (/) (vla-zoomextents (vlax-get-acad-object)) ) ;_ defun ;;; Zoom Previous ;;; Alan J. Thompson, 06.04.09 (defun AT:ZoomPrevious (/) (vla-zoomprevious (vlax-get-acad-object)) ) ;_ defun ;;; Switch to model-paperspace (mspace replacement) ;;; Alan J. Thompson, 06.04.09 (defun AT:MSpace (/) (and (zerop (getvar "tilemode")) (vla-put-mspace (vla-get-activedocument (vlax-get-acad-object)) :vlax-true ) ;_ vla-put-mspace ) ;_ and ) ;_ defun ;;; Switch to paperspace (pspace replacement) ;;; Alan J. Thompson, 06.04.09 (defun AT:PSpace (/) (and (zerop (getvar "tilemode")) (vla-put-mspace (vla-get-activedocument (vlax-get-acad-object)) :vlax-false ) ;_ vla-put-mspace ) ;_ and ) ;_ defun ;;; Dump VLA info of specified object ;;; #Object - VLA-Object ;;; Alan J. Thompson, 09.07.09 (defun AT:Dump (#Object) (if #Object (vl-catch-all-apply 'vlax-dump-object (list #Object)) (vl-catch-all-apply '(lambda () (vlax-dump-object (vlax-ename->vla-object (car (entsel "\nSelect object to dump: ")) ) ;_ vlax-ename->vla-object ) ;_ vlax-dump-object ) ;_ lambda ) ;_ vl-catch-all-apply ) ;_ if (textscr) ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Xref bound name fix (replace "$0$" with desired text) ;;; #Replace - text string to replace "$0$" with ;;; Alan J. Thompson, 09.16.09 (defun AT:XrefBindNameFix (#Replace) (and (snvalid #Replace) (vlax-for x (vla-get-layers (vla-get-activedocument (vlax-get-acad-object) ) ;_ vla-get-activedocument ) ;_ vla-get-layers (and (vl-string-search "$0$" (vla-get-name x)) (vl-catch-all-apply 'vla-put-name (list x (vl-string-subst #Replace "$0$" (vla-get-name x))) ) ;_ vl-catch-all-apply ) ;_ and ) ;_ vlax-for ) ;_ and ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Purge Multileader Styles (since vla-purgeall ignores them) ;;; Alan J. Thompson, 08.24.09 (defun AT:MleaderStylePurge (/) (vl-remove-if 'null (mapcar '(lambda (x) (and (eq 350 (car x)) (not (eq 330 (car (nth 5 (entget (cdr x)))))) (not (eq (getvar "cmleaderstyle") (vla-get-name (vlax-ename->vla-object (cdr x))) ) ;_ eq ) ;_ not (entdel (cdr x)) ) ;_ and ) ;_ lambda (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE") ) ;_ mapcar ) ;_ vl-remove-if ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Test if item is specifed type (T=Yes, nil=No) ;;; #Item - Item to compare ;;; #Type - Type to compare with ;;; Alan J. Thompson, 08.28.09 (defun AT:IsType (#Item #Type) (eq (type #Item) #Type ) ;_ eq ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; Check if Current Coordinate System is "World" ;;; Return: T = Yes, nil = No ;;; Alan J. Thompson, 08.28.09 (defun WCS? (/) (not (zerop (getvar "worlducs"))) ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted September 22, 2009 Author Share Posted September 22, 2009 ;;; List of TextStyle Objects ;;; Alan J. Thompson, 09.02.09 (defun AT:TextStyleObjList (/ #List) (vlax-for x (vla-get-textstyles (vla-get-activedocument (vlax-get-acad-object)) ) ;_ vla-get-textstyles (setq #List (cons x #List)) ) ;_ vlax-for #List ) ;_ defun ;;; List of Xref Objects ;;; Alan J. Thompson, 09.02.09 (defun AT:XrefObjList (/ #List) (vlax-for x (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)) ) ;_ vla-get-blocks (and (eq (vla-get-isxref x) :vlax-true) (setq #List (cons x #List)) ) ;_ and ) ;_ vlax-for #List ) ;_ defun Quote Link to comment Share on other sites More sharing options...
alanjt Posted October 27, 2009 Author Share Posted October 27, 2009 ;;; Add MText to drawing ;;; #InsertionPoint - MText insertion point ;;; #String - String to place in created MText object ;;; #Width - Width of MText object (if nil, will be 0 width) ;;; #Layer - Layer to place Mtext object on (nil for current) ;;; #Justification - Justification # for Mtext object ;;; 1 or nil= TopLeft ;;; 2= TopCenter ;;; 3= TopRight ;;; 4= MiddleLeft ;;; 5= MiddleCenter ;;; 6= MiddleRight ;;; 7= BottomLeft ;;; 8= BottomCenter ;;; 9= BottomRight ;;; Alan J. Thompson, 05.23.09 (defun AT:MText (#InsertionPoint #String #Width #Layer #Justification / #Width #Space #Insertion #Object ) (or #Width (setq #Width 0)) (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))) ) ;_ or (setq #Space (if (or (eq acmodelspace (vla-get-activespace *AcadDoc*) ) ;_ eq (eq :vlax-true (vla-get-mspace *AcadDoc*)) ) ;_ or (vla-get-modelspace *AcadDoc*) (vla-get-paperspace *AcadDoc*) ) ;_ if #Insertion (cond ((vl-consp #InsertionPoint) (vlax-3d-point #InsertionPoint)) ((eq (type #InsertionPoint) 'variant) #InsertionPoint) (T nil) ) ;_ cond ) ;_ setq ;; create MText object (setq #Object (vla-addmtext #Space #Insertion #Width #String)) ;; change layer, if applicable (and #Layer (tblsearch "layer" #Layer) (vla-put-layer #Object #Layer) ) ;_ and ;; change justification & match insertion point with new justification (cond ((member #Justification (list 1 2 3 4 5 6 7 8 9)) (vla-put-attachmentpoint #Object #Justification) (vla-move #Object (vla-get-InsertionPoint #Object) #Insertion ) ;_ vla-move ) ) ;_ cond #Object ) ;_ defun Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.