Leaderboard

Areas to m2 routine

Hi all, Here's a routine that I wrote to get areas in m² via drawing them or picking inside areas (It works for only decimal units). It allows the user to draw temporary lines to close up any large gaps and choose a gap tolerance. And then modifies existing TEXT or MTEXT or creates new MTEXT based on the chosen options. I believe it's still a WIP but I'd be happy to hear your well constructed critique on it. More notes on what it does in the header but GIF below of basic usage. ;; Quick loader for the routine. (defun c:--LDArea_Get_Mod_Or_New_Text ( / ) (progn (LOAD "3dwannab_Area_Get") (c:Area_Get_Mod_Or_New_Text))) ;; ;; Area_Get_Mod_Or_New_Text by 3dwannab ;; It's a WIP of sorts. ;; ;; First written on the 2022.01.22 ;; Last modified on the 2022.02.03 ;; ;; WHAT IS DOES: ;; 1. Asks the user if they want to modify existing TEXT or MTEXT or create ;; new MTEXT. ;; 2. Asks the user if they want to pick and area to draw an area to get. ;; 3. If they choose to modify existing TEXT or MTEXT then this programs will ;; First create a layer state to restore that after and hide layers that ;; contain things like, fur, dim, kitchen or hatch. ;; 4. If the pick option was chosen then it will then ask to draw temporary ;; lines to close up any large gaps. ;; 5. If the pick option was chosen, it asks the user for a gap tolerance. If no ;; gaps are leading to the other model space then this doesn't need any ;; value. ;; 6. If the pick option was chosen, you're asked to pick an internal point ;; inside the area that you have closed with the temporary lines if ;; applicable. ;; 7. Depending on whether you wanted to replace existing TEXT or MTEXT it will ;; either modify the existing TEXT or MTEXT or ask you to pick a point for ;; the new MTEXT which is MC (Middle Center) justified. ;; 8. And lastly, lastly it'll remove the temporary lines or hatches you had ;; created throughout the process. ;; ;; TO DO: ;; Nothing at the time of writing :) ;; ;; NOTES: ;; - The units used must be decimal. ;; - Hides all layers, then unhides wall, window and annotation layers. Change ;; this to suit your needs below in the code. ;; - Rounds off the area to 2 decimal places. ;; - The text must have the contents of either: 4.00m2 or 4.00m² to replace it ;; with. ;; - And this can also have other text in there but this program will only ;; replace either of the 2 types of string above as the match is done using a ;; regular expression. ;; (defun c:Area_Get_Mod_Or_New_Text ( / acDoc *error* acDoc ansDrawOrPick ansNewOrExisting areacmdstr areainmmval ent gaptolerance gaptoleranceDefault i loopForDrawLines loopForPickHatch mtextcontents MyPoint ptHatch ptNewText regexp_oldstr result ssHatches ssHide ssLines ssText ssTextAll stateName str var_cmdecho var_hpgaptol var_hpislanddetection var_hpislanddetectionmode var_hpname var_hpquickpreview var_hptransparency var_nomutt var_osmode ) (vl-load-com) (defun *error* (errmsg) (and acDoc (vla-EndUndoMark acDoc)) (and errmsg (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*")) (princ (strcat "\n<< Error: " errmsg " >>\n")) ) (vla-StartUndoMark (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))) ;; Deletes the temporary lines and hatches (if ssLines (command-s "_.Erase" ssLines "")) (if ssHatches (command-s "_.Erase" ssHatches "")) ;;; Unhides the selection set (if ssHide (acet-ss-visible ssHide 0)) ;; Restore the layer states and delete it (layerstate-restore stateName nil nil) (if (layerstate-has stateName) (progn (layerstate-delete stateName nil nil) ;; (layerstate-save stateName nil nil) ) ) (princ "\nExiting '3dwannab_Area_Get.lsp' Program\n")(princ) (setvar 'cmdecho var_cmdecho) (setvar 'hpgaptol var_hpgaptol) (setvar 'hpislanddetection var_hpislanddetection) (setvar 'hpislanddetectionmode var_hpislanddetectionmode) (setvar 'hpname var_hpname) (setvar 'hpquickpreview var_hpquickpreview) (setvar 'hptransparency var_hptransparency) (setvar 'nomutt var_nomutt) (setvar 'osmode var_hpseparate) (setvar 'osmode var_osmode) (princ) ) ;; Sets the variables (setq var_cmdecho (getvar "cmdecho")) (setq var_hpgaptol (getvar "hpgaptol")) (setq var_hpislanddetection (getvar "hpislanddetection")) (setq var_hpislanddetectionmode (getvar "hpislanddetectionmode")) (setq var_hpname (getvar "hpname")) (setq var_hpquickpreview (getvar "hpquickpreview")) (setq var_hpseparate (getvar "hpseparate")) (setq var_hptransparency (getvar "hptransparency")) (setq var_nomutt (getvar "nomutt")) (setq var_osmode (getvar "osmode")) ;; Set the ACAD variables that need setting for the program ;; Here's a list of variables relating to hatching: https://knowledge.autodesk.com/support/autocad/learn-explore/caas/CloudHelp/cloudhelp/2021/ENU/AutoCAD-Core/files/GUID-B94870E7-49CE-4BB0-A978-382A38E1FED8-htm.html (setq stateName "3dwannab_Area_Get") (setvar 'cmdecho 0) (setvar 'hpislanddetection 2) ; 0 Normal. Hatches islands within islands. 1 Outer. Hatches only areas outside of islands. 2 Ignore. Hatches everything within the boundaries. (setvar 'hpislanddetectionmode 1) ; Important that this is set to 1. Controls whether islands within new hatches and fills are detected in this session. 0 Off. 1 On (recommended). Hatches or ignores islands according to HPISLANDDETECTION. (setvar 'hpname "SOLID") ; This must be a string. (setvar 'hpquickpreview 1) ; This is either 0 for off or 1 for on. Test this in the off state. (setvar 'hpseparate 0) ; Important that this is set to 0 for joining the hatches as one. Controls whether a single hatch object or separate hatch objects are created when operating on several closed boundaries. (setvar 'hptransparency "22") ; This must be a string. (progn ;; Start the undo mark here (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object))) (or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc)) ;; initget from LeeMac help pages ;; Prompt the user to Modify the existing or create new text (initget "Modify New") (setq ansNewOrExisting (cond ( (getkword (strcat "\nModify existing text or create new MTEXT ?[Modify/New] <" (setq ansNewOrExisting (cond ( ansNewOrExisting ) ( "Modify" )) ) ">: " ) ) ) ( ansNewOrExisting ) ) ) ;; Save the layer states here before hiding layers below (layerstate-save stateName nil nil) ;; Based on the answer at the beginning setup the Modify variables (cond ((= "Modify" ansNewOrExisting) (progn ;; First select the TEXT and/or MTEXT that needs to get updated (Can be ;; multiple selection) ;; This will allow hidding of all other text objects using the: ;; (acet-ss-visible ss1 1) ; Hide ss1 ;; (acet-ss-visible ss1 0) ; Un-hide ss1 (terpri)(prompt "Select any TEXT or MTEXT you want to update :")(terpri) (setvar 'nomutt 1) ; Setting the numutt variable to 1 allows the prompt to show up. See: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/ssget-with-custom-prompt/m-p/1735374#M219362 ;; (setq ssText (ssget '((0 . "MTEXT,TEXT")))) (setq ssText (ssget '((0 . "*TEXT")))) (setvar 'nomutt 0) (if ssText (progn ;; Get all the text in the drawing space and put it to a selection for hiding. (setq ssTextAll (ssget "_X" '((0 . "*TEXT,LEADER,MULTILEADER,DIMENSION")))) (setq ssHide (3d:RemoveSSFromSS ssText ssTextAll)) ) ) ;; Another option here to do the same as my 3d:RemoveSSFromSS function above. ;; See: https://www.cadtutor.net/forum/topic/74425-remove-selection-set-from-another-retain-the-first-selection-set/?do=findComment&comment=589247 ;; (setq ssHide ;; (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssText))) ;; (ssdel ent ssTextAll) ;only removes the entity from the selection set doesn't delete the entity from the drawing. ;; ) ;; ) (acet-ss-visible ssHide 1) ; Hides ssHide ;; If the ssText selection set is empty exit the program (if (= ssText nil) (exit)) ) ) ;; No condition needed for new text here ) ;; initget from LeeMac help pages ;; Prompt the user to Modify the existing or create new text (initget "Pick Draw") (setq ansDrawOrPick (cond ( (getkword (strcat "\nPick or draw the area to get ?[Pick/Draw] <" (setq ansDrawOrPick (cond ( ansDrawOrPick ) ( "Pick" )) ) ">: " ) ) ) ( ansDrawOrPick ) ) ) ;; Hides all layers. (command "._layer" "_OFF" "*" "" "") ;; Turn on the layers that you want to here. (command "._layer" "_ON" "*wall*" "") (command "._layer" "_ON" "*boundary*" "") (command "._layer" "_ON" "*area*" "") (command "._layer" "_ON" "*window*" "") (command "._layer" "_ON" "0" "") (command "._layer" "_ON" "*AN*" "") ;; Based on the answer for drawing or picking an area do these conditions (cond ((= "Draw" ansDrawOrPick) ;; Enter the area command (command-s "area" pause "" "") ) ((= "Pick" ansDrawOrPick) (progn ;; While loop to draw temporary lines using initget ;; Based off LeeMacs code here: https://www.cadtutor.net/forum/topic/70799-how-to-continuously-run-a-condition/#comment-568357 (setvar 'osmode 3) ; Set snaps to what you want (setq ssLines (ssadd)) ; Create empty selection set (setq loopForDrawLines "loop") ; Marker to whether to loop again or end the loop (while (= "loop" loopForDrawLines ) ; Loop if loop marker says 'loop' (progn (setq MyPoint (getpoint "\nDraw gap filling lines? (Press SPACE or ENTER to skip this step) : ")) ) (if (= MyPoint nil) (setq loopForDrawLines "StopLoop") ; If no point is selected (enter or space pressed) (progn ; Else do this loop (Command "._Line" MyPoint pause "") (setq MyPoint nil) ; Might not be needed, but why not have this (setq ssLines (ssadd (entlast) ssLines)) ; Add line to selection set (as item 0, the previous line is line 1, etc) ) ) ) ; End while ;; Only turn off osmode after drawing the lines. (setvar 'osmode 0) ;; Get hpgaptol variable and set it to the entered amount (setq gaptoleranceDefault (getvar "hpgaptol")) ;; Prompt for distance, if nil use default (setq gaptolerance (cond ((getdist (strcat "\nPick or enter the gap tolerance for the hatched area :\nCurrent value <" (vl-princ-to-string (getvar "hpgaptol")) ">: "))) (gaptoleranceDefault) ) ) (setvar "hpgaptol" gaptolerance) ;; Click the internal area for the hatching ;; (command "_.bhatch") ; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/hatching-by-lisp/m-p/5923832/highlight/true#M336978 ;; Loop the hatch command until the user exits or returns out it (setq ssHatches (ssadd)) ; Create empty selection set (setq loopForPickHatch "loop") ; Marker to whether to loop again or end the loop (while (= "loop" loopForPickHatch ) ; Loop if loop marker says 'loop' (progn (setq ptHatch (getpoint "\nPick an area to hatch (Press ESC cancel) : ")) ) (if (/= ptHatch nil) (progn ; Do this loop (command "._bhatch" ptHatch) (while (> (getvar 'cmdactive) 0) (progn (command pause) (setq ssHatches (ssadd (entlast) ssHatches)) ) ) (setq loopForPickHatch "StopLoop") ; If no point is selected (enter or space pressed) (setq ptHatch nil) ; Might not be needed, but why not have this (setq ssHatches (ssadd (entlast) ssHatches)) ; Add hatch to selection set ) ) ) ; End while loopForPickHatch ;; Old method for picking the hatch, this step could get skipped when ;; enter, right-click or space bar was used. ;; (setq ssHatches (ssadd)) ; creates a blank selection set ;; (while (> (getvar 'cmdactive) 0) ;; (progn ;; (command pause) ;; (setq ssHatches (ssadd (entlast) ssHatches)) ;; ) ;; ) ; while end ;; Here it checks the lastprompt variable and if it finds: ;; Valid hatch boundary not found. ;; Then the program will exit. ;; (while (> (getvar 'cmdactive) 0) (if (wcmatch (strcase (getvar 'lastprompt)) "*HATCH BOUNDARY NOT*") (progn (ACET-UI-MESSAGE "Valid hatch boundary not found. " "Exiting Program" (+ Acet:OK Acet:ICONWARNING) ) (setq ssLines nil) ; This will set the selection set to nil (setq ssHatches nil) ; This will set the selection set to nil (exit) ) ) ;; Use the area command to get the last value and convert it to m² ;; Only do this for the picking. The (getvar "area") below will do it for the drawn area (command "._area" "_O" "_L") ) ) ) (setq areainmmval (rtos (/ (getvar "area") 1e6) 2 2)) ; How to get m² from mm² in area in AutoCAD. https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/mm2-to-m2-soma-areas-m2-lsp-and-mm-to-m-soma-perimetros-lsp/m-p/5963137/highlight/true#M337718 (setq areacmdstr (strcat "\n\nArea in m\U+00B2 is: " areainmmval)) (setq mtextcontents (strcat areainmmval "m\U+00B2")) (terpri)(princ (strcat areacmdstr))(terpri) (cond ;; Modify the MTEXT based on the answer at the beginning ((= "Modify" ansNewOrExisting) ;; Modify the selected TEXT and/or MTEXT with the area in meters squared (if ssText (progn (repeat (setq i (sslength ssText)) (setq ent (entget (ssname ssText (setq i (1- i)))) str (cdr (assoc 1 ent)) ) (if (wcmatch str "*") (progn (setq regexp_oldstr "\\d+\\.?\\d*m[²|2]") (setq result (SS_RegExp str regexp_oldstr mtextcontents )) (setq str (vl-string-translate "*" " " result) ) (setq ent (subst (cons 1 str) (assoc 1 ent) ent)) (entmod ent) ) ) ) ) ; End progn ) ; End if ssText ) ;; Create the MTEXT at the picked point based on the answer at the beginning ((= "New" ansNewOrExisting) (progn (princ (strcat areacmdstr)) ;; Click the internal area for the hatching (graphscr) (setq ptNewText (getpoint "\nClick position for new text point : "))(terpri) (command "._MTEXT" ptNewText "_J" "_TC" "_C" "_N" "_H" pause ptNewText mtextcontents "") ) ) ) ) (vla-EndUndoMark acDoc) (*error* nil) (princ) ) ;; ----------------------------------------------------------------------- ;; ----------------------=={ Functions START }==-------------------------- ;; 3dwannab ;; Removes a selection set from another. And also removes any of the same ;; entities. ;; Returns ssKeep selection set. ;; Wrote on 2022.01.31 ;; Usage: ;; (3d:RemoveSSFromSS ssKeep ssRemove) (defun 3d:RemoveSSFromSS ( ssKeep ssRemove / i ent ssNew ) (setq ssNew (ssadd)) (repeat (setq i (sslength ssRemove)) (setq ent (ssname ssRemove (setq i (1- i)))) (if (not (ssmemb ent ssKeep)) (setq ssNew (ssadd ent ssNew)) ) ) ssNew ) (defun SS_RegExp ( strOld findPattern strReplace / reObj result ) (vl-load-com) (setq reObj (vlax-create-object "Vbscript.RegExp")) (vlax-put-property reObj "IgnoreCase" 1) (vlax-put-property reObj "Global" 1) (vlax-put-property reObj "Pattern" findPattern ) (setq result (vlax-invoke-method reObj "Replace" strOld strReplace) ) result ) (princ (strcat "\n3dwannab_Area_Get.lsp edited on " (menucmd "m=$(edtime,0,DD-MO-yyyy)") " by 3dwannab (stephensherry147@yahoo.co.uk) loaded" "\nType \"Area_Get_Mod_Or_New_Text\" to run Program" ) ) (princ)