Areas to m2 routine

February 3, 2022

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)

February 5, 2022

Updated to get areas of objects. These are supported. Arc, Circle, Ellipse, Hatch or Polyline.

Also to round off the value of the area. This value is saved to the registry so it'll get remembered after restarting AutoCAD.


;; Quick loader for the routine.
(defun c:--LDAreas_Get_Mod_Or_New_Text ( / ) (progn (LOAD "3dwannab_Areas_Get") (c:Areas_Get_Mod_Or_New_Text)))

;;
;; Areas_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.06
;;
;; 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 an area, draw an area to get or select
;;    any of the following objects: Arc, Circle, Ellipse, Hatch or Polyline to
;;    get the area of.
;; 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. You will get prompted for the decimal round off value at the end which
;;    where the value will get saved to the registry so it'll get remembered
;;    even after closing AutoCAD.
;;    0 will result in an area: 4m²
;;    2 will result in an area: 4.44m²
;;    3 will result in an area: 4.443m²
;; 9. 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:Areas_Get_Mod_Or_New_Text ( /
  acDoc
  *error*

  acDoc
  ansDrawPickSelectHatch
  ansNewOrExisting
  areacmdstr
  areaHatchSel
  areainmmval
  ent
  eo
  gaptolerance
  gaptoleranceDefault
  i
  loopForDrawLines
  loopForPickHatch
  lst
  mtextcontents
  MyPoint
  pt
  ptHatch
  ptNewText
  regexp_oldstr
  regValDecimalPlaces
  result
  ssHatches
  ssHatchesExisting
  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_Areas_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_Areas_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)) ; Remove the first selection set from the second
          )
        )

      (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 "Pick Draw Select")
  (setq ansDrawPickSelectHatch
    (cond
      (
        (getkword
          (strcat "\nPick, Draw or Select object to get the area of ?[Pick/Draw/Select] <"
            (setq ansDrawPickSelectHatch
              (cond ( ansDrawPickSelectHatch ) ( "Pick" ))
              )
            ">: "
            )
          )
        )
      ( ansDrawPickSelectHatch )
      )
    )

  ;; 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" ansDrawPickSelectHatch)

      ;; Enter the area command
      ;; This will ask for multiple areas. Just return twice to finish
      (command-s "area" "_A" pause "")

      )

    ((=  "Select" ansDrawPickSelectHatch)

      ;; Get the area of the selected objects

      (progn

        (setq
          areaHatchSel 0
          i 0
          )

        ;; Get any objects here that are pre selected
        ;; (sssetfirst nil (ssget "_P"))
        (princ "\nSelect any Arc, Circle, Ellipse, Hatch or Polyline")
        (setq ssHatchesExisting (ssget "_:L" '((0 . "ARC,CIRCLE,ELLIPSE,HATCH,*POLYLINE"))))

        (cond
          ((and(and ssHatchesExisting) (> (sslength ssHatchesExisting) 0))
            (repeat (sslength ssHatchesExisting)
              (setq eo (vlax-ename->vla-object (ssname ssHatchesExisting i)))
              (setq areaHatchSel (+ areaHatchSel (vlax-get eo 'Area)))
              (setq i (+ i 1))
              )
            )
          ) ; End cond

        ) ; End progn

      )

    ((=  "Pick" ansDrawPickSelectHatch)

      (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")

        )

)

)

;; Get saved round off value from the registry or default to 1
(setq regValDecimalPlaces (cond ((getenv "Area_Get_Decimal_Places")) (1)))

;; Prompt for integer value to round off to
(setq regValDecimalPlaces (cond ((getint (strcat "\nEnter the decimal places you want to round off to :\nCurrent value <" (vl-princ-to-string regValDecimalPlaces) ">: ")))
  (regValDecimalPlaces)
  )
)
;; Set the registry value to the variable
(setenv "Area_Get_Decimal_Places" (vl-princ-to-string regValDecimalPlaces))

;; This if statement is for when objects are selected or if the area is
;; retrieved via the area command.
(if areaHatchSel
  (setq areainmmval (rtos (/ areaHatchSel 1e6) 2 (read (getenv "Area_Get_Decimal_Places")))) ; 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 areainmmval (rtos (/ (getvar "area") 1e6) 2 (read (getenv "Area_Get_Decimal_Places")))) ; 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 (3d_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)

     (initget 1) ; Prevents using enter, therefore the point is required. Escape to cancel is the only option.
     (setq ptNewText (getpoint "\nClick position for new text point : "))

     (if ptNewText
       (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 3d_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 \"Areas_Get_Mod_Or_New_Text\" to run Program"
  )
 )
(princ)

Edited February 6, 2022 by 3dwannab

July 3, 2022

Updated to draw a regular rectangle.


;; Quick loader for the routine.
(defun c:--LDAreas_Get_Mod_Or_New_Text ( / ) (progn (LOAD "3dwannab_Areas_Get") (c:Areas_Get_Mod_Or_New_Text)))

;;
;; Areas_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.07.04
;;
;; 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 an area, draw a rectangle, draw an area
;;    to get or select any of the following objects: Arc, Circle, Ellipse, Hatch
;;    or Polyline to get the area of.
;; 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. You will get prompted for the decimal round off value at the end which
;;    where the value will get saved to the registry so it'll get remembered
;;    even after closing AutoCAD.
;;    0 will result in an area: 4m²
;;    2 will result in an area: 4.44m²
;;    3 will result in an area: 4.443m²
;; 9. 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:Areas_Get_Mod_Or_New_Text ( /
  acDoc
  *error*

  ansDrawPickSelectHatch
  ansNewOrExisting
  areacmdstr
  areaHatchSel
  areainmmval
  commandFinished
  ent
  eo
  gaptolerance
  gaptoleranceDefault
  i
  loopForDrawLines
  loopForPickHatch
  lst
  mtextcontents
  MyPoint
  newPolyline
  pt
  ptHatch
  ptNewText
  regexp_oldstr
  regValDecimalPlaces
  result
  ssHatches
  ssHatchesExisting
  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_Areas_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_Areas_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)) ; Remove the first selection set from the second
          )
        )

      (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 "Pick Draw drawRectangle Select")
  (setq ansDrawPickSelectHatch
    (cond
      (
        (getkword
          (strcat "\nPick, Draw or Select object to get the area of ?[Pick/Draw/draw Rectangle/Select] <"
            (setq ansDrawPickSelectHatch
              (cond ( ansDrawPickSelectHatch ) ( "Pick" ))
              )
            ">: "
            )
          )
        )
      ( ansDrawPickSelectHatch )
      )
    )

  ;; 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" "*kitchen*" "")
  (command "._layer" "_ON" "*window*" "")
  (command "._layer" "_ON" "0" "")
  (command "._layer" "_ON" "*AN*" "")
  (command "._layer" "_ON" "*ST*" "")
  (command "._layer" "_ON" "*no*plot*" "")
  (command "._layer" "_ON" "*WC*" "")
  (command "._layer" "_ON" "*WS*" "")

  ;; Based on the answer for drawing or picking an area do these conditions
  (cond

    ((= "drawRectangle" ansDrawPickSelectHatch)

      ;; Enter the rectangle command and get its area
      ;; Delete the rectangle once finish.
      ;; Required function from Lee Mac to  return the last subentity in the
      ;; database
      ;; This will prevent this section from deleting other objects if the
      ;; rectangle command is cancelled.
      (progn

        (setq ent (LM:entlast))
        (command-s "._rectang")
        (while (< 0 (getvar 'cmdactive)) (command "\\"))
        (while (setq ent (entnext ent))
          (command-s "area" "_O" "_L" "")
          (entdel ent)
          )

        (setq commandFinished T)

        )

      ) ;; End Draw Rectangle

    ((= "Draw" ansDrawPickSelectHatch)

      ;; Enter the area command
      ;; This will ask for multiple areas. Just return twice to finish
      (progn
        (command-s "area" "_A" pause "")
        (setq commandFinished T)
        )

      )

    ((= "Select" ansDrawPickSelectHatch)

      ;; Get the area of the selected objects

      (progn

        (setq
          areaHatchSel 0
          i 0
          )

        ;; Get any objects here that are pre selected
        ;; (sssetfirst nil (ssget "_P"))
        (princ "\nSelect any Arc, Circle, Ellipse, Hatch or Polyline")
        (setq ssHatchesExisting (ssget "_:L" '((0 . "ARC,CIRCLE,ELLIPSE,HATCH,*POLYLINE"))))

        (cond
          ((and(and ssHatchesExisting) (> (sslength ssHatchesExisting) 0))
            (repeat (sslength ssHatchesExisting)
              (setq eo (vlax-ename->vla-object (ssname ssHatchesExisting i)))
              (setq areaHatchSel (+ areaHatchSel (vlax-get eo 'Area)))
              (setq i (+ i 1))
              )
            )
          ) ; End cond

        (setq commandFinished T)

        ) ; End progn

      )

    ((= "Pick" ansDrawPickSelectHatch)

      (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 commandFinished T)

        )

)

)

;; IMPORTANT
;; First, exit the program if the commandFinished is not T.
(if (not commandFinished)
  (exit)
  )

;; Get saved round off value from the registry or default to 1
(setq regValDecimalPlaces (cond ((getenv "Area_Get_Decimal_Places")) (1)))

;; Prompt for integer value to round off to
(setq regValDecimalPlaces (cond ((getint (strcat "\nEnter the decimal places you want to round off to :\nCurrent value <" (vl-princ-to-string regValDecimalPlaces) ">: ")))
  (regValDecimalPlaces)
  )
)
;; Set the registry value to the variable
(setenv "Area_Get_Decimal_Places" (vl-princ-to-string regValDecimalPlaces))

;; This if statement is for when objects are selected or if the area is
;; retrieved via the area command.
(if areaHatchSel
  (setq areainmmval (rtos (/ areaHatchSel 1e6) 2 (read (getenv "Area_Get_Decimal_Places")))) ; 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 areainmmval (rtos (/ (getvar "area") 1e6) 2 (read (getenv "Area_Get_Decimal_Places")))) ; 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*\\s*m[²|2]")

              (setq result (3d_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)

     (initget 1) ; Prevents using enter, therefore the point is required. Escape to cancel is the only option.
     (setq ptNewText (getpoint "\nClick position for new text point : "))

     (if ptNewText
       (command "._MTEXT" ptNewText "_J" "_TC" "_C" "_N" "_H" pause ptNewText mtextcontents "")
       )

     )

    )
  )

)

(vla-EndUndoMark acDoc)

(*error* nil) (princ)

)

;; -----------------------------------------------------------------------
;; ----------------------=={ Functions START }==--------------------------

;; entlast  -  Lee Mac
;; A wrapper for the entlast function to return the last subentity in the database

(defun LM:entlast ( / ent tmp )
 (setq ent (entlast))
 (while (setq tmp (entnext ent)) (setq ent tmp))
 ent
 )

;; 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 3d_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 \"Areas_Get_Mod_Or_New_Text\" to run Program"
  )
 )
(princ)

;; (c:Areas_Get_Mod_Or_New_Text)

Sign In

Areas to m2 routine

Recommended Posts

3dwannab

Link to comment

Share on other sites

3dwannab

Link to comment

Share on other sites

3dwannab

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity