(defun c:NE (/ ss tek acss )
(if (setq ss (ssget (list (cons 0 "TEXT"))))
  (progn
    (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
    (vla-StartUndomark doc)
    (vlax-for tek (setq acss (vla-get-ActiveSelectionSet doc))
      (vla-put-textstring tek (strcat (substr (vla-get-textstring tek) 1 1)
    (itoa (- (atoi (substr (vla-get-textstring tek) 2))1))
    )))
    (vla-endUndomark doc)
    ))
(princ))

(defun c:ky(/ eks eksdata plset mes obj lenobj dgr km mes angle1 pt1 pt2)
  (setq eks (car (entsel "\n Ekseni seciniz..:")))
  (setq eksdata (entget eks))
  (setq mes (getint "\nAra mesafeyi giriniz..:"))
  (vl-load-com)
  (setq obj (vlax-ename->vla-object eks))
  (setq lenobj (vlax-get-property obj 'length))
  (setq dgr 0)
  (setq km 0)
  (while (> lenobj km)
    (setq km (+ dgr mes))
    (setq pt (vlax-curve-getpointAtDist obj km))
    (setq pt1 (vlax-curve-getpointAtDist obj (- km 0.01))) ;Bir önceki nokta
    (setq pt2 (vlax-curve-getpointAtDist obj (+ km 0.01))) ;Bir sonraki nokta
    (setq angle1 (angle pt1 pt2)) ;İki nokta arasındaki açiyi hesapla
    (setq angle1 (+ angle1 (/ pi 2.0)))
    (entmake (list (cons 0 "text") (cons 10 pt) (cons 40 1) (cons 1 (itoa km)) (cons 50 angle1)))
    (entmake (list (cons 0 "point") (cons 10 pt) (cons 8 "0")))
    (setq dgr km)
  );while
);end

(defun c:YSEC (/ ss c say secim tek lst y-say)
(if (setq ss (ssget (list (cons 0 "LWPOLYLINE"))))
(progn
  (setq c -1 say (sslength ss) secim (ssadd))
  (while (< (setq c (1+ c))say)
    (setq tek (ssname ss c)
  lst (mapcar 'cdr (vl-remove-if '(lambda (x)(/= (car x) 10)) (entget tek))))
(if (setq sec (ssget "_wp" lst '((0 . "TEXT"))))
  (progn
    (setq y-say (sslength sec) cc -1)
    (while (< (setq cc (1+ cc)) y-say)
      (ssadd (ssname sec cc) secim)))))
  (sssetfirst nil secim)))(princ))

; Get Block Name and Base Point
   (while (or (not bn)
          (not (snvalid bn))
      ) ;_  end or
   (setq bn (getstring "Specify Block Name: "))
   ) ;_  end while
;   (initget 1)
   (setq pt '(0 0)) ;(getpoint "Specify Base Point for Block: "))
;;; Create BLOCK Header

;**********************************
;          Rename block name
;    (block isminin degistirilmesi)
;
;        powered by yazgunesi
;       www.autocadokulu.com
;
; *********************************
(defun c:rbk (/ blksecimi blkname blknew)
; select block to view name
(setq blksecimi (entget(car(entsel "Select block to view NAMES : ")))
      blkname (cdr(assoc 2 blksecimi)) )
(princ (strcat ">>> " (cdr (assoc 2 blksecimi)) " <<<" )) ; princ block name
(setq blknew (getstring t "\nEnter new block name: "))
(command "_.rename" "_block" blkname blknew)
(prompt "\nBlock ismi basariyla degistirilmistir...")
(princ)
)

; secilen nesneleri istenen uygulama noktasini kullanarak tek blok yapar
; blok ismini secilen text iceri olarak yapar
; orjinal nesnelerin silinmesini istiyorsaniz   ;(command "_.ERASE" ss "")  asagida  bulunan bu satirin onundeki  " ; " simgesini silin
; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/a-lisp-routine-to-create-a-block-from-selected-objectes-and/td-p/11026565
(defun c:obj2blk1 (/ ss bn pt i ent elist)
; Get Entities
   (while (not ss)
   (princ "\nSelect Objects to Convert to Blocks:")
   (setq ss (ssget '((-4 . "<NOT") (0 . "INSERT,POLYLINE,VIEWPORT") (-4 . "NOT>"))))
   ) ;_  end while
; Get Block Name and Base Point
   (while (or (not bn)
          (not (snvalid bn))
      ) ;_  end or
(setq entt (car (entsel "\nSelect source text:")))
(setq enttx (entget entt))
(setq bn (cdr (assoc 1 enttx)))
   ) ;_  end while
   (initget 1)
   (setq pt (getpoint "Specify Base Point for Block: "))
;;; Create BLOCK Header
   (entmake (list (cons 0 "BLOCK") (cons 10 pt) (cons 2 bn) (cons 70 0)))
;;;STEP THRU THE SET
   (setq i (sslength ss))
   (while (>= i (setq i (1- i)) 0)
   (setq ent   (ssname ss i)
         elist (entget ent)
   ) ;_  end setq
   (entmake elist)
   ) ;_  end while
;;;FINISH THE BLOCK DEFINITION
   (entmake (list (cons 0 "ENDBLK") (cons 8 "0")))
;;;Insert the Block & Delete Originals
   (entmake (list (cons 0 "INSERT") (cons 2 bn) (cons 8 "0") (cons 10 pt)))
   ;(command "_.ERASE" ss "")
   (redraw)
   (prin1)
) ;_  end defun

; ----------------------------------------------------------------------
;          Bloklari , blok ismiyle tek tek dwg`lere ayirir
;
; ----------------------------------------------------------------------
;
; ----------------------------------------------------------------------
(defun c:wba ()
  (setq cmdecho (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  ;
  (defun LM:browseforfolder ( msg dir bit / err fld pth shl slf )
    (setq err
        (vl-catch-all-apply
            (function
                (lambda ( / app hwd )
                    (if (setq app (vlax-get-acad-object)
                              shl (vla-getinterfaceobject app "shell.application")
                              hwd (vl-catch-all-apply 'vla-get-hwnd (list app))
                              fld (vlax-invoke-method shl 'browseforfolder (if (vl-catch-all-error-p hwd) 0 hwd) msg bit dir)
                        )
                        (setq slf (vlax-get-property fld 'self)
                              pth (vlax-get-property slf 'path)
                              pth (vl-string-right-trim "" (vl-string-translate "/" "" pth))
                        ))))))
    (if slf (vlax-release-object slf))
    (if fld (vlax-release-object fld))
    (if shl (vlax-release-object shl))
    (if (vl-catch-all-error-p err)
        (prompt (vl-catch-all-error-message err))
        pth
    ))
(setq path (LM:browseforfolder "Klasor secin" nil 0))
  (if (/= path nil)
    (progn
      (if (= (substr path (strlen path) 1) "")
        (setq path (substr path 1 (1- (strlen path))))
      )
      (princ "\nDS> Building List of Blocks ... ")
      (setq lst nil)
      (setq itm (tblnext "BLOCK" T))
      (while (/= itm nil)
        (setq nam (cdr (assoc 2 itm)))
        (setq pass T)
        (if (/= (cdr (assoc 1 itm)) nil)
          (setq pass nil)
          (progn
            (setq ctr 1)
            (repeat (strlen nam)
              (setq chk (substr nam ctr 1))
              (if (or (= chk "*")(= chk "|"))
                (setq pass nil)
              )
              (setq ctr (1+ ctr))
            )
          )
        )
        (if (= pass T)
          (setq lst (cons nam lst))
        )
        (setq itm (tblnext "BLOCK"))
      )
      (setq lst (acad_strlsort lst))
      (princ "Done.")
      ;
      (foreach blk lst
        (setq fn (strcat path (chr 92) blk))
        (if (findfile (strcat fn ".dwg"))
          (command "_.WBLOCK" fn "_Y" blk)
          (command "_.WBLOCK" fn blk)
        )
      )
    )
  )
  ;
  (setvar "CMDECHO" cmdecho)
  (princ)
)
(PRINC " Lispi calistirmak icin komut satirina 'WBA' yaziniz ")

;****Secilen nesneleri olusturulan klasore orjinal koordinatinda
;      WBlock olarak tek tek save eder..****
(defun c:WBblock (/ dc sl n ss dr i ns)
            (vl-load-com)
  (if (and (setq dc (vla-get-ActiveDocument
             (vlax-get-acad-object))
          sl (vla-get-SelectionSets dc)
            n 0 ss (ssget))
        (setq dr (getfiled "WBlock" "" "" 9)))
    (progn
      (vl-mkdir dr)
      (repeat (setq i (sslength ss))
        (setq i (1- i)
          ns (vla-Add sl "S")
            n (1+ n))
        (vlax-invoke ns 'AddItems (list
          (vlax-ename->vla-object (ssname ss i))))
        (vla-WBlock dc (strcat dr "/" (itoa n) ".dwg")
          (vla-Item sl "S"))
        (vla-Delete ns)
      )
    )
  ) (prin1)
)

;;  tek tek  ayrilan bloklari(wba) bir dwg icine toplar
;;  Block Import Lisp  08/12/2008
;;  CAB at TheSwamp.org
  ;;  Get user selection of folder
  ;;  Get all DWG files in folder
  ;;  INSERT dwg as block @ 0,0
  ;;  get Bounding Box of block
  ;;  Move Insert to right w/ gap between blocks
  ;;  Next Insert
(defun c:BI (/ path LastDist gap space err newblk bname obj ll lr ur
               InsPt dist GetFolder)
  (vl-load-com)
  (defun GetFolder ( / DirPat msg)
   (setq msg "Open a folder and click on SAVE")
   (and
    (setq DirPat (getfiled "Browse for folder" msg " " 1))
    (setq DirPat (substr DirPat 1 (- (strlen DirPat) (strlen msg))))
   )
   DirPat
  )
  (defun activespace (doc)
    (if (or (= acmodelspace (vla-get-activespace doc))
            (= :vlax-true (vla-get-mspace doc)))
        (vla-get-modelspace doc)
        (vla-get-paperspace doc)
    )
  )
  (setq gap 5) ; this is the gap between blocks
  (setq LastDist 0.0) ; this is the cumulative distance
  (if (setq Path (GetFolder))
    (progn
      (setq space (activespace (vla-get-activeDocument (vlax-get-acad-object))))
      (prompt "\n***  Working, Please wait ......\n")
      (foreach bname (vl-directory-files Path "*.dwg" 1)
        ;;  OK, try & insert the Block
        (if (vl-catch-all-error-p
              (setq err (vl-catch-all-apply
                '(lambda () (setq newblk (vla-insertBlock space
                                (vlax-3d-point '(0.0 0.0 0.0)) (strcat path bname) 1.0 1.0 1.0 0.0))
                   ))))
          ;;  Display the error message and block/file name
          (prompt (strcat "\n" bname " " (vl-catch-all-error-message err)))
          ;;  ELSE
          (progn ; INSERT was sucessful, move the block
            ;;  get bounding box
            (if (vl-catch-all-error-p
                  (setq err (vl-catch-all-apply 'vla-getboundingbox (list newblk 'll 'ur))))
               (prompt (strcat "\nBB Error - could not move " bname "\n  " (vl-catch-all-error-message err)))
               (progn
                 (setq ll (vlax-safearray->list ll)
                       ur (vlax-safearray->list ur)
                       lr (list (car ur) (cadr ll))
                       dist (distance ll lr)
                       )
                 ;;  MOVE the block
                 (setq ;InsPt  (vla-get-insertionpoint Newblk)
                       NewPt (polar '(0. 0. 0.) 0.0 (+ LastDist Gap (* dist 0.5)))
                       LastDist (+ LastDist Gap dist)
                       )
                 (vlax-put Newblk 'insertionpoint NewPt)
               )
            )
          )
         )
      )
    )
  )
  (princ)
)
(princ)
(prompt "\nBlock Import Loadd, Enter Bi to run.")

; secilen textler arasinda 4 islem yapip  ekrana yeni text olarak yazdirir
; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-to-subtract-2-given-mtexts/td-p/5131450
(defun c:AV (/) (c:CombineValues))
(defun c:CombineValues (/ *error* AT:ExtractNumbers AT:Str2Lst AT:MText AT:Entsel AT:ListSelect
                        CV:StripFormat _sel dZin f i obj num nStr final pt
                       )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SUBROUTINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; error handler
  (defun *error* (msg)
    (and dZin (setvar 'dimzin dZin))
    (and msg
         (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*"))
         (princ (strcat "\nError: " msg))
    )
  )
;;; Extract numbers from string
;;; #String - String to extract numbers from
;;; Required Subroutines: AT:Str2Lst
;;; Alan J. Thompson, 11.13.09 / 04.08.10
  (defun AT:ExtractNumbers (Str / i l)
    (setq i -1)
    (mapcar
      (function atof)
      (AT:Str2Lst
        (vl-list->string
          (mapcar
            (function (lambda (x)
                        (setq i (1+ i))
                        (cond ;; number
                              ((< 47 x 58) x)
                              ;; - and number following
                              ((and (eq x 45) (< 47 (nth (1+ i) l) 58)) x)
                              ;; . and follows a number
                              ((and (eq x 46) (not (minusp (1- i))) (< 47 (nth (1- i) l) 58)) x)
                              (t 32)
                        )
                      )
            )
            (setq l (vl-string->list (vl-princ-to-string Str)))
          )
        )
        " "
      )
    )
  )
;;; Convert string to list, based on separator
;;; #Str - String to convert
;;; #Sep - Separator to break string into items
;;; Ex. - (AT:Str2Lst "1,2,3" ",") -> '("1" "2" "3")
;;; Alan J. Thompson, 11.11.09
  (defun AT:Str2Lst (#Str #Sep / #Inc #List #Str)
    (while (setq #Inc (vl-string-search #Sep #Str))
      (setq #List (cons (substr #Str 1 #Inc) #List))
      (setq #Str (substr #Str (+ 2 #Inc)))
    ) ;_ while
    (vl-remove "" (append (reverse #List) (list #Str)))
  ) ;_ defun
;;; Add MText to drawing
;;; Pt - MText insertion point
;;; Str - String to place in created MText object
;;; Wd - Width of MText object (if nil, will be 0 width)
;;; Lay - Layer to place Mtext object on (nil for current)
;;; Jus - 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 / 04.09.10
  (defun AT:MText (Pt Str Wd Lay Jus / Wd s o)
    (or Wd (setq Wd 0.))
    (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
    (setq s  (if (or (eq acmodelspace (vla-get-activespace *AcadDoc*))
                     (eq :vlax-true (vla-get-mspace *AcadDoc*))
                 )
               (vla-get-modelspace *AcadDoc*)
               (vla-get-paperspace *AcadDoc*)
             )
          Pt (cond ((vl-consp Pt) (vlax-3d-point Pt))
                   ((eq (type Pt) 'variant) Pt)
             )
    )
    (vla-put-lock (vlax-ename->vla-object (tblobjname "layer" (getvar 'clayer))) :vlax-false)
    (setq o (vla-addMText s Pt Wd (vl-princ-to-string Str)))
    (and Lay (tblsearch "layer" Lay) (vla-put-layer o Lay))
    (cond ((vl-position Jus '(1 2 3 4 5 6 7 8 9))
           (vla-put-AttachmentPoint o Jus)
           (vla-put-InsertionPoint o Pt)
          )
    )
    o
  )
;;; 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
;list select dialog
;create a temp DCL multi-select list dialog from provided list
;value is returned in list form, DCL file is deleted when finished
;example: (setq the_list (AT:listselect "This is my list title" "Select items to make a list" "25" "30" "true" (list "object 1" "object 2" "object 3"))
;if mytitle is longer than defined width, the width will be ignored and it will fit to title string
;if mylabel is longer than defined width, mylabel will be truncated
;myheight and mywidth must be strings, not numbers
;mymultiselect must either be "true" or "false" (true for multi, false for single)
;created by: alan thompson, 9.23.08
;some coding borrowed from http://www.jefferypsanders.com (thanks for the DCL examples)
  (defun AT:ListSelect (mytitle ;title for dialog box
                        mylabel ;label right above list box
                        myheight ;height of dialog box !!*MUST BE STRING*!!
                        mywidth ;width of dialog box !!*MUST BE STRING*!!
                        mymultiselect ;"true" for multiselect, "false" for single select
                        mylist ;list to display in list box
                        / retlist readlist count item savevars fn fo valuestr dcl_id
                       )
    (defun saveVars (/ readlist count item)
      (setq retList (list))
      (setq readlist (get_tile "mylist"))
      (setq count 1)
      (while (setq item (read readlist))
        (setq retlist (append retList (list (nth item myList))))
        (while
          (and
            (/= " " (substr readlist count 1))
            (/= "" (substr readlist count 1))
          )
           (setq count (1+ count))
        )
        (setq readlist (substr readlist count))
      )
    ) ;defun
    (setq fn (vl-filename-mktemp "" "" ".dcl"))
    (setq fo (open fn "w"))
    (setq valuestr (strcat "value = "" mytitle "";"))
    (write-line (strcat "list_select : dialog {
            label = "" mytitle "";") fo)
    (write-line
      (strcat
        "          : column {
            : row {
              : boxed_column {
               : list_box {
                  label ="" mylabel
        "";
                  key = "mylist";
                  allow_accept = true;
                  height = " myheight ";
                  width = " mywidth ";
                  multiple_select = " mymultiselect
        ";
                  fixed_width_font = false;
                  value = "0";
                }
              }
            }
            : row {
              : boxed_row {
                : button {
                  key = "accept";
                  label = " Okay ";
                  is_default = true;
                }
                : button {
                  key = "cancel";
                  label = " Cancel ";
                  is_default = false;
                  is_cancel = true;
                }
              }
            }
          }
}"     )
      fo
    )
    (close fo)
    (setq dcl_id (load_dialog fn))
    (new_dialog "list_select" dcl_id)
    (start_list "mylist" 3)
    (mapcar 'add_list myList)
    (end_list)
    (action_tile "cancel" "(setq ddiag 1)(done_dialog)")
    (action_tile "accept" "(setq ddiag 2)(saveVars)(done_dialog)")
    (start_dialog)
    (if (= ddiag 1)
      (setq retlist nil)
    )
    (unload_dialog dcl_id)
    (vl-file-delete fn)
    retlist
  ) ;defun
  ;;  StripFormat as taken (with permission) from the following:
  ;;  StripMtext Version 5.0b for AutoCAD 2000 and above
  ;;  Copyright© Steve Doman and Joe Burke 2010
  ;; Location: http://www.theswamp.org/index.php?topic=31584.0
  ;; Arguments:
  ;; str - an mtext string.
  ;; formats - a list of format code strings or a string.
  ;; Format code arguments are not case sensitive.
  ;; Examples:
  ;; Remove Font, Overline and Underline formatting.
  ;; (StripFormat <mtext string> (list "f" "O" "U"))
  ;; Or a quoted list:
  ;; (StripFormat <mtext string> '("f" "O" "U"))
  ;; Or a string:
  ;; (StripFormat <mtext string> "fOU")
  ;; Remove all formatting except Overline and Underline.
  ;; (StripFormat <mtext string> (list "*" "^O" "^U"))
  ;; Or a quoted list:
  ;; (StripFormat <mtext string> '("*" "^O" "^U"))
  ;; Or a string:
  ;; (StripFormat <mtext string> "*^O^U")
  ;; Available codes:
  ;; A (^A) - Alignment
  ;; B (^B) - taBs
  ;; C (^C) - Color
  ;; F (^F) - Font
  ;; H (^H) - Height
  ;; L (^L) - Linefeed (newline, line break, carriage return)
  ;; O (^O) - Overline
  ;; Q (^Q) - obliQuing
  ;; P (^P) - Paragraph (embedded justification, line spacing and indents)
  ;; S (^S) - Stacking
  ;; T (^T) - Tracking
  ;; U (^U) - Underline
  ;; W (^W) - Width
  ;; ~ (^~) - non-breaking space
  ;; * - all formats
  (defun CV:StripFormat (str formats / FormatsToList text slashflag lbrace rbrace RE:Replace
                         RE:Execute Alignment Tab Color Font Height Linefeed Overline Paragraph
                         Oblique Stacking Tracking Underline Width Braces HardSpace
                        )
    ;; Argument: either a list of strings or a string.
    ;; Given a list, ensure formats are uppercase.
    ;; Given a formats string, convert it to a list of uppercase strings.
    ;; Examples: (FormatsToList "fOU") > ("F" "O" "U")
    ;;           (FormatsToList "f^OU") > ("F" "^O" "U")
    (defun FormatsToList (arg / lst)
      (cond ((= (type arg) 'LIST) (mapcar 'strcase arg))
            ((= (type arg) 'STR)
             (while (not (eq "" (substr arg 1)))
               (if (eq "^" (substr arg 1 1))
                 (setq lst (cons (strcat "^" (substr arg 2 1)) lst)
                       arg (substr arg 3)
                 )
                 (setq lst (cons (substr arg 1 1) lst)
                       arg (substr arg 2)
                 )
               )
             )
             (mapcar 'strcase (reverse lst))
            )
      )
    ) ; end FormatsToList
    (setq formats (FormatsToList formats))
    ;; Access the RegExp object from the blackboard.
    ;; Thanks to Steve for this idea.
    (or (vl-bb-ref '*REX*) (vl-bb-set '*REX* (vlax-create-object "VBScript.RegExp")))
    (defun RE:Replace (newstr pat string)
      (vlax-put (vl-bb-ref '*REX*) 'Pattern pat)
      (vlax-put (vl-bb-ref '*REX*) 'Global actrue)
      (vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse)
      (vlax-invoke (vl-bb-ref '*REX*) 'Replace string newstr)
    ) ;end
    (defun RE:Execute (pat string / result match idx lst)
      (vlax-put (vl-bb-ref '*REX*) 'Pattern pat)
      (vlax-put (vl-bb-ref '*REX*) 'Global actrue)
      (vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse)
      (setq result (vlax-invoke (vl-bb-ref '*REX*) 'Execute string))
      (vlax-for x result
        (setq match (vlax-get x 'Value)
              idx   (vlax-get x 'FirstIndex)
              ;; position within string - zero based - first position is zero
              lst   (cons (list match idx) lst)
        )
      )
      lst
    ) ;end
    ;; Replace linefeeds using this format "\n" with the AutoCAD
    ;; standard format "\P". The "\n" format occurs when text is
    ;; copied to ACAD from some other application.
    (setq str (RE:Replace "\\P" "\\n" str))
;;;;; Start remove formatting sub-functions ;;;;;
    ;; A format
    (defun Alignment (str) (RE:Replace "" "\\\\A[012];" str))
    ;; B format (tabs)
    (defun Tab (str / lst origstr tempstr)
      (setq lst (RE:Execute "\\\\P\\t|[0-9]+;\\t" str))
      (foreach x lst
        (setq origstr (car x)
              tempstr (RE:Replace "" "\\t" origstr)
              str     (vl-string-subst tempstr origstr str)
        )
      )
      (RE:Replace " " "\\t" str)
    )
    ;; C format
    (defun Color (str)
      ;; True color and color book integers are preceded
      ;; by a lower case "c". Standard colors use upper case "C".
      (RE:Replace "" "\\\\[Cc][0-9]?[.]?[0-9]+;" str)
    )
    ;; F format
    (defun Font (str) (RE:Replace "" "\\\\[Ff].*?;" str))
    ;; H format
    (defun Height (str)
      (RE:Replace "" "\\\\H[0-9]?[.]?[0-9]+x;" str)
      ;; This also works, but it's not as clear as the above.
      ;; (RE:Replace "" "\\\\H\\d\\.?\\d*x;" str)
    )
    ;; L format
    ;; Leading linefeeds are not converted to spaces.
    (defun Linefeed (str / teststr)
      ;; Remove formatting from test string other than linefeeds.
      ;; Seems there's no need to check for stacking
      ;; because a linefeed will always come before stack formatting.
      (setq teststr (Alignment str)
            teststr (Color teststr)
            teststr (Font teststr)
            teststr (Height teststr)
            teststr (Overline teststr)
            teststr (Paragraph teststr)
            teststr (Oblique teststr)
            teststr (Tracking teststr)
            teststr (Underline teststr)
            teststr (Width teststr)
            teststr (Braces teststr)
      )
      ;; Remove leading linefeeds.
      (while (eq "\\P" (substr teststr 1 2))
        (setq teststr (substr teststr 3)
              str     (vl-string-subst "" "\\P" str)
        )
      )
      (RE:Replace " " " \\\\P|\\\\P |\\\\P" str)
    )
    ;; O format
    (defun Overline (str) (RE:Replace "" "\\\\[Oo]" str))
    ;; This option is effectively the same as the Remove Formatting >
    ;; Remove Paragraph Formatting option avaiable in the 2008 Mtext editor.
    (defun Paragraph (str) (RE:Replace "" "\\\\p.*?;" str))
    ;; Q format - numeric value may be negative.
    (defun Oblique (str)
      ;; Any real number including negative values.
      (RE:Replace "" "\\\\Q[-]?[0-9]*?[.]?[0-9]+;" str)
    )
    ;; S format
    (defun Stacking (str / lst tempstr pos origstr teststr testpos numcheck)
      (setq lst (RE:Execute "\\\\S(.*?)(\\;)" str))
      (foreach x lst
        (setq tempstr (car x)
              pos     (cadr x)
              origstr tempstr
        )
        ;; Remove formatting from test string other than stacking.
        (setq teststr (Alignment str)
              teststr (Color teststr)
              teststr (Font teststr)
              teststr (Height teststr)
              teststr (Linefeed teststr)
              teststr (Overline teststr)
              teststr (Paragraph teststr)
              teststr (Oblique teststr)
              teststr (Tracking teststr)
              teststr (Underline teststr)
              teststr (Width teststr)
              teststr (Braces teststr)
        )
        ;; Remove all "{" characters if present. Added JB 2/1/2010.
        (setq teststr (RE:Replace "" "[{]" teststr))
        ;; Get the stacked position within test string.
        (setq testpos (cadar (RE:Execute "\\\\S(.*?)(\\;)" teststr)))
        ;; Avoid an error with substr if testpos is zero.
        ;; A space should not be added given a stacked
        ;; fraction string which is simply like this 1/2" anyway.
        (if (/= 0 testpos)
          (setq numcheck (substr teststr testpos 1))
        )
        ;; Check whether the character before a stacked string/fraction
        ;; is a number. Add a space if it is.
        (if (and numcheck (<= 48 (ascii numcheck) 57))
          (setq tempstr (RE:Replace " " "\\\\S" tempstr))
          (setq tempstr (RE:Replace "" "\\\\S" tempstr))
        )
        (setq tempstr (RE:Replace "/" "[#]" tempstr)
              tempstr (RE:Replace "" "[;]" tempstr)
              tempstr (RE:Replace "" "\\\\A(.*?)[;]" tempstr)
              tempstr (RE:Replace "" "\\^" tempstr)
              str     (vl-string-subst tempstr origstr str pos)
        )
      )
      str
    )
    ;; T format
    (defun Tracking (str) (RE:Replace "" "\\\\T[0-9]?[.]?[0-9]+;" str))
    ;; U format
    (defun Underline (str) (RE:Replace "" "\\\\[Ll]" str))
    ;; W format
    (defun Width (str) (RE:Replace "" "\\\\W[0-9]?[.]?[0-9]+;" str))
    ;; ~ format
    ;; In 2008 a hard space includes font formatting.
    ;; In 2004 it does not, simply this \\~.
    (defun HardSpace (str) (RE:Replace " " "{\\\\[Ff](.*?)\\\\~}|\\\\~" str))
    ;; Remove curly braces. Called after other formatting is removed.
    (defun Braces (str / lst origstr tempstr len teststr)
      (setq lst (RE:Execute "{[^\\\\]+}" str))
      (foreach x lst
        (setq origstr (car x)
              tempstr (RE:Replace "" "[{}]" origstr)
              str     (vl-string-subst tempstr origstr str)
        )
      )
      ;; Added JB 12/20/2009
      ;; Last ditch attempt at remove braces from start and end of string.
      (setq len (strlen str))
      (if (and (= 123 (ascii (substr str 1 1)))
               (= 125 (ascii (substr str len 1)))
               (setq teststr (substr str 2))
               (setq teststr (substr teststr 1 (1- (strlen teststr))))
               (not (vl-string-search "{" teststr))
               (not (vl-string-search "}" teststr))
          )
        (setq str teststr)
      )
      str
    )
;;;;; End remove formatting sub-functions ;;;;;
;;;;; Start primary function ;;;;;
    ;; Temporarily replace literal backslashes with a unique string.
    ;; Literal backslashes are restored at end of function. By Steve Doman.
    (setq slashflag (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) ">"))
    (setq text (RE:Replace slashflag "\\\\\" str))
    ;; Temporarily replace literal left curly brace.
    (setq lbrace (strcat "<L" (substr (rtos (getvar "CDATE") 2 8) 14) ">"))
    (setq text (RE:Replace lbrace "\\\\{" text))
    ;; Temporarily replace literal right curly brace.
    (setq rbrace (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) "R>"))
    (setq text (RE:Replace rbrace "\\\\}" text))
    (if (or (vl-position "A" formats)
            (and (vl-position "*" formats) (not (vl-position "^A" formats)))
        )
      (setq text (Alignment text))
    )
    (if (or (vl-position "B" formats)
            (and (vl-position "*" formats) (not (vl-position "^B" formats)))
        )
      (setq text (Tab text))
    )
    (if (or (vl-position "C" formats)
            (and (vl-position "*" formats) (not (vl-position "^C" formats)))
        )
      (setq text (Color text))
    )
    (if (or (vl-position "F" formats)
            (and (vl-position "*" formats) (not (vl-position "^F" formats)))
        )
      (setq text (Font text))
    )
    (if (or (vl-position "H" formats)
            (and (vl-position "*" formats) (not (vl-position "^H" formats)))
        )
      (setq text (Height text))
    )
    (if (or (vl-position "L" formats)
            (and (vl-position "*" formats) (not (vl-position "^L" formats)))
        )
      (setq text (Linefeed text))
    )
    (if (or (vl-position "O" formats)
            (and (vl-position "*" formats) (not (vl-position "^O" formats)))
        )
      (setq text (Overline text))
    )
    (if (or (vl-position "P" formats)
            (and (vl-position "*" formats) (not (vl-position "^P" formats)))
        )
      (setq text (Paragraph text))
    )
    (if (or (vl-position "Q" formats)
            (and (vl-position "*" formats) (not (vl-position "^Q" formats)))
        )
      (setq text (Oblique text))
    )
    (if (or (vl-position "S" formats)
            (and (vl-position "*" formats) (not (vl-position "^S" formats)))
        )
      (setq text (Stacking text))
    )
    (if (or (vl-position "T" formats)
            (and (vl-position "*" formats) (not (vl-position "^T" formats)))
        )
      (setq text (Tracking text))
    )
    (if (or (vl-position "U" formats)
            (and (vl-position "*" formats) (not (vl-position "^U" formats)))
        )
      (setq text (Underline text))
    )
    (if (or (vl-position "W" formats)
            (and (vl-position "*" formats) (not (vl-position "^W" formats)))
        )
      (setq text (Width text))
    )
    (if (or (vl-position "~" formats)
            (and (vl-position "*" formats) (not (vl-position "^~" formats)))
        )
      (setq text (HardSpace text))
    )
    (setq text (Braces (RE:Replace "\" slashflag text))
          text (RE:Replace "\\{" lbrace text)
          text (RE:Replace "\\}" rbrace text)
    )
    text
  ) ; end StripFormat
  (defun _sel (/ o)
    (if (setq o
               (AT:Entsel t
                          (strcat "\nSelect text object to "
                                  *AV:Fnc*
                                  " or "
                                  (if final
                                    "[Add/Divide/Multiply/Subtract/Type]: "
                                    "[Type]: "
                                  )
                          )
                          '("V" (0 . "AECC_COGO_POINT,AECC_POINT,ATTDEF,ATTRIB,MULTILEADER,MTEXT,TEXT"))
                          (if final
                            "Add Divide Multiply Subtract Type"
                            "Type"
                          )
               )
        )
      (cond ((eq o "Add") (setq f "+") (setq *AV:Fnc* "Add") (_sel))
            ((eq o "Divide") (setq f "/") (setq *AV:Fnc* "Divide") (_sel))
            ((eq o "Multiply") (setq f "*") (setq *AV:Fnc* "Multiply") (_sel))
            ((eq o "Subtract") (setq f "-") (setq *AV:Fnc* "Subtract") (_sel))
            ((eq o "Type") (initget 6) (setq o (getreal (strcat "\nNumber to " *AV:Fnc* ": "))))
            (T o)
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (vl-load-com)
  (or *AV:Fnc* (setq *AV:Fnc* "Add"))
  (and (setq dZin (getvar 'dimzin)) (setvar 'dimzin 0))
  (initget 0 "Add Divide Multiply Subtract")
  (setq
    *AV:Fnc* (cond ((getkword
                      (strcat "\nChoose function [Add/Divide/Multiply/Subtract] <" *AV:Fnc* ">: ")
                    )
                   )
                   (*AV:Fnc*)
             )
  )
  (setq f (cond ((eq *AV:Fnc* "Add") "+")
                ((eq *AV:Fnc* "Divide") "/")
                ((eq *AV:Fnc* "Multiply") "*")
                ((eq *AV:Fnc* "Subtract") "-")
          )
        i 0.
  )
  (while (setq obj (_sel))
    (if
      (cond
        ;; real value
        ((eq (type obj) 'REAL) (setq num obj))
        ;; LDD point
        ((and (eq (vla-get-objectname obj) "AeccDbPoint")
              (not (vl-catch-all-error-p
                     (setq num (vl-catch-all-apply
                                 (function
                                   (lambda () (cadddr (assoc 11 (entget (vlax-vla-object->ename obj)))))
                                 )
                               )
                     )
                   )
              )
         )
         num
        )
        ;; C3D point
        ((and
           (eq (vla-get-objectname obj) "AeccDbCogoPoint")
           (not (vl-catch-all-error-p
                  (setq num (vl-catch-all-apply (function vlax-get-property) (list obj 'Elevation)))
                )
           )
         )
         (setq num (car (AT:ExtractNumbers num)))
        )
        ;; attribute, multileader, mtext, text
        (T
         ;;(T (setq num (apply (function (eval (read f))) (AT:ExtractNumbers (vla-get-textstring obj)))))
         ;;(T (setq num (car (AT:ExtractNumbers (vla-get-textstring obj)))))
         ;|
         (setq num ((lambda (n)
                      (foreach x (AT:ExtractNumbers (StripFormat (vla-get-textstring obj) "*"))
                        (setq n ((eval (read f)) x n))
                      )
                    )
                     0.
                   )
         )
         |;
         (if
           (> (length (setq num (AT:ExtractNumbers (CV:StripFormat (vla-get-textstring obj) "*"))))
              1
           )
            (if (setq num (AT:ListSelect
                            (strcat "Multiple numbers to: " *AV:Fnc*)
                            "Choose numbers:"
                            "10"
                            "5"
                            "true"
                            (mapcar (function vl-princ-to-string) num)
                          )
                )
              (setq i   (+ i (1- (length num)))
                    num ((lambda (n)
                           (foreach x (mapcar (function atof) num)
                             (setq n ((eval (read f)) x n))
                           )
                         )
                          0.
                        )
              )
            )
            (setq num (car num))
         )
        )
      )
       (if final
         (progn (setq final ((eval (read f)) final num)
                      nStr  (strcat nStr " " f " " (vl-princ-to-string num))
                      i     (1+ i)
                )
                (princ (strcat nStr " = " (vl-princ-to-string final)))
         )
         (progn (setq final num
                      nStr  (strcat "\n" (vl-princ-to-string num))
                      i     (1+ i)
                )
                (princ (strcat nStr " " f))
         )
       )
       (princ "\nValue does not contain number!")
    )
  )
  (and nStr
       (> i 1)
       (if (and (eq *AV:Fnc* "Add") (not (wcmatch nStr "*/*,*`**,*-*")))
         (setq pt (initget 0 "Average")
               pt (getpoint (strcat nStr
                                    " = "
                                    (vl-princ-to-string final)
                                    "\nSpecify text placement or [Average]: "
                            )
                  )
         )
         (setq
           pt (getpoint (strcat nStr " = " (vl-princ-to-string final) "\nSpecify text placement: "))
         )
       )
       (if (vl-consp pt)
         (AT:MText (trans pt 1 0) (rtos final) nil nil 5)
         (if (setq pt (getpoint (strcat nStr
                                        " = "
                                        (vl-princ-to-string final)
                                        " / "
                                        (vl-princ-to-string (fix i))
                                        " = "
                                        (vl-princ-to-string (/ final i))
                                        "\nSpecify text placement point: "
                                )
                      )
             )
           (AT:MText (trans pt 1 0) (rtos (/ final i)) nil nil 5)
         )
       )
  )
  (*error* nil)
  (princ)
)