Topograf Online

;;;----------------------CARNET  DE  TEREN----------------------
;;;trebuie sa avem pe plan polilinii si punctele de statie si de orientare - entitati POINT, asa s-a setat OSMODE
;;;Genereaza fisierul CARNET.csv in forma:  [PS]  [PV]  [X]  [Y]  [Dx]  [Dy]  [Dist redusa]  [Orientare] , pentru toate vertexurile poliliniilor din desen
 

(command "units" "2" "3" "3" "4" "0.0000" "N")
(graphscr)


(defun C:CARNET ()
(setq msel (ssget "X" (list (cons 0 "LWPOLYLINE"))))
(setq lng (sslength msel))
(setq index 0)
(setq ncor (getint "\nNumerotare puncte începând cu <100>: "))
    (if (= nil ncor)(setq ncor 100))
(setq des "q")
(while (AND (/= des "y")(/= des "Y")(/= des "n")(/= des "N")(/= des ""))
(setq des (getstring "\nScriem numarul punctelor pe desen? Yes/No <Y>:"))
                    );;;while
(if (= des "")(setq des "Y"))
(setq des (strcase des))
(setq fis (open "Fiscord.txt" "w"));;;---asta e temporar, va fi sters la sfarsit

(while (< index lng)
(setq nent (ssname msel index))
(setq index (+ 1 index))
(setq lent (entget nent))
(setq cont 0);;;numar de ordine al componentelor entitatii-lista, si daca da de codul de grup 10  extrage coordonatele
(while (setq entc (nth cont lent))
    (setq cont (+ 1 cont))
    (if (= 10 (car entc))(progn 
        (setq ncor (+ 1 ncor))
        (write-line (itoa ncor) fis)
        (setq x (cadr entc))
        (write-line (rtos x 2 3) fis)
        (setq y (caddr entc))
        (write-line (rtos y 2 3) fis)
    (if (= des "Y")(command "text" (list (+ 1 x) (+ 1 y)) 3 0 ncor))
        
                ));;PROGN si IF
                );;WHILE pe fiecare entitate
        );;;WHILE de la index entitati
(close fis)

;;;------------------Acum avem fisierul de coordonate, il citim si facem carnetul de teren

(setvar "osmode" 8);;;------------pentru "Node"
(setq ps (getpoint "\nSELECTATI PUNCTUL DE STATIE:"))
(setq nps (getstring "\nNUMAR PUNCT STATIE: "))
(setq po (getpoint "\nSELECTATI PUNCTUL DE ORIENTARE:"))
(setq npo (getstring "\nNUMAR PUNCT DE ORIENTARE: "))
(setq ys (nth 0 ps))
(setq xs (nth 1 ps))
(setq yo (nth 0 po))
(setq xo (nth 1 po))
(setq dx (- xo xs));;;---real
(setq dy (- yo ys));;;---real
(setq dist (distance ps po));;;---real
(setq orient (angle ps po))
(setq orient (angtos orient 2 4));;;---string
(setq orient (atof orient))

(if (AND (> dx 0) (> dy 0))(setq orient (- 100 orient)));;;---cadran 1
(if (AND (> dx 0) (< dy 0))(setq orient (- 500 orient)));;;---cadran 2
(if (AND (< dx 0) (< dy 0))(setq orient (- 500 orient)));;;---cadran 3
(if (AND (< dx 0) (> dy 0))(setq orient (- 500 orient)));;;---cadran 4

(setq cale (getvar "dwgprefix"))
(setq fis2 (open (strcat cale "Carnet.csv") "w"))
(write-line (strcat "Punct statie: " nps) fis2)
(write-line (strcat "Punct orientare: " npo ) fis2)
(write-line "" fis2)
(write-line "" fis2)
(write-line "PS,PV,X,Y,Dx,Dy,Dist. red.,Orientare" fis2)
(write-line (strcat nps "," npo "," (rtos xo) "," (rtos yo) "," (rtos dy) "," (rtos dx) "," (rtos dist) "," (rtos orient 2 4) ) fis2)

(setq nfis1 (open "Fiscord.txt" "r" ))

;;;---------------citim pe rand fiecare linie din fisier
(while (setq np (read-line nfis1))
(setq yp (read-line nfis1))
(setq xp (read-line nfis1))
    (setq xp (atof xp))
    (setq yp (atof yp))
    (setq dx (- xp xs))
    (setq dy (- yp ys))
    (setq dist (distance ps (list yp xp)))
    (setq orient (angle ps (list yp xp)))
    (setq orient (angtos orient 2 4));;;string
    (setq orient (atof orient))
    (if (AND (> dx 0) (> dy 0))(setq orient (- 100 orient)));;;---cadran 1
    (if (AND (> dx 0) (< dy 0))(setq orient (- 500 orient)));;;---cadran 2
    (if (AND (< dx 0) (< dy 0))(setq orient (- 500 orient)));;;---cadran 3
    (if (AND (< dx 0) (> dy 0))(setq orient (- 500 orient)));;;---cadran 4

(write-line (strcat "," np "," (rtos xp) "," (rtos yp) "," (rtos dy) "," (rtos dx) "," (rtos dist) "," (rtos orient 2 4) ) fis2)

        );;;while de la citire fisier
        (close nfis1);;;inventarul de coordonate
        (close fis2);;;carnetul de teren

(command "sh" "del Fiscord.txt")
(setq linie (strcat "Fisierul CARNET.csv a fost creat in locatia:  \n" cale ))
(alert linie)
                            );;;defun CARNET



(alert "Pentru generate carnet de teren, dati comanda CARNET")

;;;pentru planse de parcelare OCPI - numeroteaza punctele de contur si face tabelul cu inventarul de coordonate

(defun C:TAB ()
(setq osn_old (getvar "osmode"))
(setvar "osmode" 0)
(command "pdmode" 35)
(command "pdsize" 1.5)
(command "ortho" "off")
(command "units" "2" "3" "3" "4" "0.0000" "N")
(graphscr)
(command "-style" "Arial" "Arial.ttf" 0 1 0 "N" "N")

(setq pi2 (/ pi 2))
(setq 5pi2 (/ (* 5 pi) 2))
(setq 2pi (* pi 2))
(setq 3pi2 (/ (* pi 3) 2))
(setq mselt (ssadd))


(setq sel (car(entsel "\nSelectati conturul:")));;;----obiect
(setq msel (entget  sel));;;-----lista
(setq lng (length msel))

;;;---------------ar trebui sa vedem cate vertexuri are, ca se suprapune ultimul cu primul
(setq index1 0)
(setq nmax 0)
(while (< index1 lng)
    (setq nent1 (nth index1 msel))
    (setq index1 (+ 1 index1))
    (setq cod1 (car nent1))
    (if (= 10 cod1)(setq nmax (+ 1 nmax)));;;asta e nr. maxim de puncte
                );;;while
(setq nmax (- nmax 1))
;;;-------------acuma le luam pe rand si scriem
(setq index 0)
(setq ncor 0)
(while (< index lng)
(setq nent (nth index msel));;;element de lista
(setq index (+ 1 index))
(setq cod (car nent))
        (if (AND (= 10 cod)(<= ncor nmax))(progn 
            (setq ncor (+ 1 ncor))
            (setq y (cadr nent))
            (setq x (caddr nent))
            (command "point" (list y x));;;parantezele se inchid mai incolo

        (if (= ncor 1)(progn
            (command "text" (list (+ 1 y) (+ 1 x)) 3 0 ncor)
            (setq pant (list y x))
                    ));;;PROGN+IF ncor=1
        (if (> ncor 1)(progn
            (setq alfa (angle pant (list y x)))
            (setq dist (distance pant (list y x)))
            (setq ofs 3)
            (if (<= alfa pi2)(setq alfa1 (- alfa 5pi2)))
            (if (> alfa pi2)(setq alfa1 (- alfa pi2)))
            (if (< dist 5)(setq alfap 1)(setq alfap 0))
            (if (AND (< distant 5)(= alfant 1))(setq alfap 0))
            (setq alfa1 (+ alfa1 (* alfap pi)))
            (setq aabs (abs alfa1))
            (if (> aabs 2pi)(setq aabs (- aabs 2pi)))
            (if (AND (>= aabs 0)(< aabs pi2))(setq jt "BL"))
            (if (AND (>= aabs pi2)(< aabs pi))(setq jt "BR"))
            (if (AND (>= aabs pi)(< aabs 3pi2))(setq jt "TR"))
            (if (AND (>= aabs 3pi2)(< aabs 2pi))(setq jt "TL"))
            (setq dx (* ofs (cos alfa1)))
            (setq dy (* ofs (sin alfa1)))
            (command "text" "J" jt (list (+ y dx) (+ x dy)) 3 0 ncor)
            (setq pant (list y x))
            (setq distant dist)
            (setq alfant alfap)
                        ));;;PROGN+IF ncor>1
;;;=================pentru liniile cap de tabel===========================luam X, Y pentru tabel de aici
            (if (= ncor 1)(progn 
                (setq xs y)
                (setq ys x)
                (setq ps (list y x))
                (command "text" (list xs (+ ys 5)) 3 0 "Nr            X                 Y")
                (setq mselt (ssadd (entlast) mselt))
                (command "line" (list (- xs 1) (+ ys 4)) (list (+ xs 55) (+ ys 4)) "");;;linia de sub Nr....X....Y
                (setq mselt (ssadd (entlast) mselt))
                (command "line" (list (- xs 1) (+ ys 9)) (list (+ xs 55) (+ ys 9)) "");;;linia de deasupra Nr...X...Y
                (setq mselt (ssadd (entlast) mselt))
                                ));;;PROGN si IF ncor=1
;;;==================================================================================
            (if (< ncor 10)(setq sp "     "))
            (if (AND (< ncor 100)(>= ncor 10))(setq sp "   "))
            (if (>= ncor 100)(setq sp " "))
            (setq lin (strcat (itoa ncor) sp (rtos x 2 3) " " (rtos y 2 3)))
            (setq yc (- ys (* (- ncor 1) 4.8)))
                    (command "text" (list xs yc) 3 0 lin)
                    (setq mselt (ssadd (entlast) mselt))
                    (command "line" (list (- xs 1) (- yc 1)) (list (+ xs 55) (- yc 1)) "")
                    (setq mselt (ssadd (entlast) mselt))
                                        ));;PROGN si IF  cod=10
                                        );;;WHILE de la index lista entitati

;;;---------- liniile verticale
(command "line" (list (- xs 1) (+ ys 9)) (list (- xs 1) (- yc 1)) "");;;verticala din stanga
(setq mselt (ssadd (entlast) mselt))
(command "line" (list (+ xs 7.7) (+ ys 9)) (list (+ xs 7.7) (- yc 1)) "");;;verticala dintre numar si X
(setq mselt (ssadd (entlast) mselt))
(command "line" (list (+ xs 30.85) (+ ys 9)) (list (+ xs 30.85) (- yc 1)) "");;;verticala dintre X si Y
(setq mselt (ssadd (entlast) mselt))
(command "line" (list (+ xs 55) (+ ys 9)) (list (+ xs 55) (- yc 1)) "");;;ultima
(setq mselt (ssadd (entlast) mselt))

;;;-----------acuma sa vedem ce suprafata are
(command "area" "ob" sel)
(setq supraf (getvar "area"))
(setq sint (fix supraf))
(setq dif (- supraf sint))
(if (>= dif 0.5)(setq supraf (+ 1 sint)))
(setq supraf (rtos supraf 2 0))
(command "text" (list (+ xs 12) (- yc 5)) 3 0 (strcat "S=" supraf " mp"))
(setq mselt (ssadd (entlast) mselt))


;;;-------------acum sa facem conturul gros de 0.8 ca se vede mai bine
(command "pedit" sel "W" 0.8 "")

;;;=================================aici avem mai multe optiuni===============================
;;;OPTIUNEA 1: facem bloc, si il inseram dupa aia
(if (= nil bn)(setq bn 1)(setq bn (+ 1 bn)))
(setq bname (strcat "b" (itoa bn)));;;construim numele blocului, ca sa nu se suprapuna cu altele
(command "-block" bname ps mselt "");;;il ascunde cu totul si trebe inserat dupa aia
(command "insert" bname pause 1 1 0)
(command "scale" "l" "" ps 1.2);;;scara 1:2000 nu se prea vede, scalam

;;;OPTIUNEA 2: se poate lua in memorie, si paste dupa aia
;;(command "_cutclip" mselt "")
;;(command "_pasteclip")

;;;OPTIUNEA 3: se face tabelul normal, si pe urma se muta direct ca il face langa punctul nr. 1
;;;(command "move" mselt "" ps)
;;;==================================================================================
(setvar "osmode" osn_old);;;revenim la osnapul dinainte

                            );;;DEFUN

(alert "Lansare cu comanda TAB")

;;; ------------------------------------------------------------------------
;;;    CombineValues.lsp v1.2
;;;
;;;    Copyright© 04.09.10
;;;    Alan J. Thompson (alanjt)
;;;
;;;    Contact: alanjt @ TheSwamp.org, CADTutor.net
;;;
;;;    Permission to use, copy, modify, and distribute this software
;;;    for any purpose and without fee is hereby granted, provided
;;;    that the above copyright notice appears in all copies and
;;;    that both that copyright notice and the limited warranty and
;;;    restricted rights notice below appear in all supporting
;;;    documentation.
;;;
;;;    The following program(s) are provided "as is" and with all faults.
;;;    Alan J. Thompson DOES NOT warrant that the operation of the program(s)
;;;    will be uninterrupted and/or error free.
;;;
;;;    Allows user to combine extracted numerical values of selected Attribute,
;;;    Civil 3D Point, Land Desktop Point, MText, MultiLeader, Text or typed value.
;;;
;;;    Combine options include: Add, Divide, Multiply, Subtract (can be changed at any time).
;;;    If user only adds values, an option to average is available.
;;;    Upon completion, user is prompted to specify placement point MText with final value.
;;;
;;;    Revision History:
;;;
;;;    v1.1 (04.11.10) 1. Updated subroutine: AT:ExtractNumbers
;;;
;;;    v1.2 (04.13.10) 1. Reworked AT:ExtractNumbers subroutine.
;;;            2. Added subroutine AT:ListSelect to select numbers when multiple exist in string.
;;;            3. If multiple numbers exist in string, user is prompted with list box
;;;               to select each desired number. If multiple numbers are selected, they are
;;;               combined and added to display.
;;;            4. Added CV:StripFormat subroutine, as taken from StripMText 5.0b,
;;;               Copyright© Steve Doman and Joe Burke 2010 (with permission), to avoid any
;;;               issues with extracting numbers out text formatting. (Thank you Joe & Steve)
;;;
;;; ------------------------------------------------------------------------

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

(defun c:ax (/ ent1 ent2 i len pt p1 ptlst)
 (vl-load-com)

 (if (and (setq ent1 (car (entsel "\nSelecteaza prima polilinie: ")))
 (wcmatch (cdr (assoc 0 (entget ent1))) "*POLYLINE"))
 (if (and (setq ent2 (car (entsel "\nSelecteaza a doua polilinie: ")))
 (wcmatch (cdr (assoc 0 (entget ent2))) "*POLYLINE"))
 (progn
 (command "area" "o" ent1)
  (setq l1 (getvar "perimeter"))
(setq div (/ (* l1 10) 100))
 (setq i -1 len (/ (vla-get-Length
 (vlax-ename->vla-object ent1)) div))
 (while (setq pt (vlax-curve-getPointatDist ent1 (* (setq i (1+ i)) len)))
 (setq p1 (vlax-curve-getClosestPointto ent2 pt t)
 ptlst (cons (polar pt (angle pt p1) (/ (distance pt p1) 2.)) ptlst)))
 (setq ptlst (apply 'append
 (mapcar
 (function
 (lambda (x)
 (list (car x) (cadr x)))) ptlst)))
 (vla-AddLightWeightPolyline
 (vla-get-ModelSpace
 (vla-get-ActiveDocument
 (vlax-get-acad-object)))
 (vlax-make-variant
 (vlax-safearray-fill
 (vlax-make-safearray
 vlax-VBDouble (cons 0 (1- (length ptlst)))) ptlst))))))

 (princ))

(defun c:cl ()
(setvar "CMDECHO" 0)
(if (not(setq startset(cadr(ssgetfirst))))    
        (setq startset(ssget)))
        (setq i -1
                filterlist nil)         ;need?
    (repeat(sslength startset)
        (setq i(1+ i))
        (setq ent(entget(ssname startset i)))
(setq lyr (cdr(assoc 8 ent)))
(setq clyr (getvar "CLAYER"))
(if (= lyr clyr)
(progn
(command "LAYER" "MAKE" "xtcnv" "C" "140" "" "")
(setvar "CLAYER" "xtcnv")
(command "layer" "off" (strcat lyr) "")
(setvar "CLAYER" lyr)
(command "laydel" "n" "xtcnv" "" "y")
)
)
(command "layer" "off" (strcat lyr) "")
)
(princ)
)

;---------------------------------------------------------------------------
; Modified by GLStephens to eliminate "Undo" "mark"! which should not be 
; implemented within programs - user function only - use "Undo" "begin/end"
; and to modify the error routine so that it is local rather than over-
; writing the global routine.  Oct 2003
;---------------------------------------------------------------------------
;                 Modified by David Garrigues
;                          of the 
;                         CADapult 
;                http://home1.gte.net/davidgus 
;                       E-mail 
;                        Version ?.?
;                      October 19, 1997

;Objective - to add verticies to all polylines/splines except 3D polylines

;Summary of additions
;can do spline or fitted polylines
;can do splines
;keeps pline at original elevation

;Function and reasoning -
;To make it work with R14 and light weight polylines and the new variable PLINETYPE.  
;I also had to take into account what the plinetype setting was so that
;I also could change lines into polylines or lwpolylines.  I also added 
;the capability to add verticies in plines where they are splined or fitted
;without turning them into 50,000 segments while still maintaining the 
;spline or fit option. Works in 14 on all Polylines, LWPolylines, Splines, and Lines.
;Due the nature of the FIT option on a polyline I decided to ask the user if the wish to RE-FIT
;after the insertion of a new vertex.  While testing this I found areas and instances
;where I thought this might be benificial to the user. The original program performed a loop
;while that is nice I decided I liked it better if did not (just hit enter with your mouse
;button). I added error handlers that will set back the line the way it was after aproaching the
;error.  Last but not least I made sure that this will maintain all elevations as they are
;just for us CIVILized people


;***************************************************************************
;Original header
;  ADVERT.LSP    Add a Vertex   (c)1995, Steve Houghton
;revised 3/23/95 to ensure new vertex is at crosshairs
;thanks to Patrick Wheatley

;Inserts a vertex in a polyline.  If a line is selected, it offers to convert
;it to a polyline and then insert the vertex.
;Will report: At least one break point must be on polyline. if the end of
;a polyline is chosen
;***************************************************************************

(defun C:iv ( / *Error* POLYLINE POLYNAME PICKPOINT POLYDXF ENTTYPE FTSP ZPT 
                    LASTENT NEWVERT OLDERR ANSWER)
                    (while


 (defun *Error* (msg)
  (while (> (getvar "CmdActive") 0) (command)) ; if command not ended, then end it

    ; now restore environment
    (setvar "blipmode" adv:blip)
    (setvar "cmdecho" adv:cmd)
    (setvar "menuecho" adv:echo)
    (setvar "orthomode" adv:ortho)
    (setvar "highlight" adv:highlt)
    (setvar "texteval" adv:txeval)
    (setvar "osmode" adv:snap)

  (princ msg)
  (princ)
 ) ; end defun error



;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
;
;  This section remmed out by GLS - reworked as local *Error*
;
;  
;
;  (setq OLDERR *error*) ;current error handling subroutine
;  (defun *error* (errmes)
;    (princ (strcat "\nExecution of ADVERT.LSP halted by the following error: " ERRMES))
;    (command "undo" "b");if this program fails or you cancel out of the program this will 
;                        ;put the entity back to its original condition
;
;    (setvar "blipmode" blipmode)
;    (setvar "cmdecho" cmdecho)
;    (setvar "menuecho" menuecho)
;    (setvar "orthomode" orthomode)
;    (setvar "highlight" highlight)
;    (setvar "texteval" texteval)
;    (setvar "osmode" oldsnap)
;    
;    (setq *error* OLDERR)
;    (prin1) ;exit quitley
;  )
;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

; Initial section of Main code follows


  ; set ex sysvars to variables to later restore
  (setq adv:blip (getvar "blipmode"))
  (setq adv:cmd (getvar "cmdecho"))
  (setq adv:echo (getvar "menuecho"))
  (setq adv:ortho (getvar "orthomode"))
  (setq adv:highlt (getvar "highlight"))
  (setq adv:txeval (getvar "texteval"))
  (setq adv:snap (getvar "osmode"))

   ; set sysvars to values for this routine
   (setvar "OSMODE" 0)   ;osmode to avoid conflicts with the osnap
   (setvar "BLIPMODE" 0) ;so no nasty blips hanging around
   (setvar "HIGHLIGHT" 0);so it runs faster on BIG polylines
   (setvar "CMDECHO" 0)  ;so you don't see the baggage

 (command "._Undo" "_End") ; end any previously active group
 (command "._Undo" "_Begin") ; starts new undo group for this command - Advert

; begin main program

   (princ "\nAlege o polilinie, linie sau spline ca sa adaugi vertexul: ")

(setq POLYLINE  (entsel)                     ;asks you to select the entity
      POLYNAME  (car POLYLINE)               ;gets the handle name
      PICKPOINT (osnap (cadr POLYLINE) "nea");using the osnap we get a point on the entity
      POLYDXF   (entget POLYNAME)            ;get association list
      ENTTYPE   (cdr (assoc 0 POLYDXF))      ;finding out what kind of entity it is
      FTSP      (cdr (assoc '70 polydxf))    ;is it fitted or splined
      ZPT       (CADDR PICKPOINT)            ;elevation point "Z" only
 )  
(cond
  ((or (= ftsp 2)(= ftsp 4))
    (fitit)
  )
  ((= enttype "LWPOLYLINE")
     ;vertex insert routine for lwpolylines
      (command "break" POLYNAME PICKPOINT PICKPOINT)
      ;lwplolylines do not change handle names so there is no need to entmake
      (command "PEDIT" polyname "join" (entlast) "" "x")
      ;moving the  vertex is easy on a line taht has not been splined or fitted
      ;because you can always depend on the point not moving.  When we are dealing
      ;with a spine or a fit the vertex could move slightly. This slight movement forces
      ;me helpless to try and find that point then aid the user in trying to stretch it.
      ;I could write more code and find the point but all I would be doing is the same as
      ;you just picking on the entity and using your grips to place the new vertex where
      ;you want it to go. 
      (setvar "osmode" adv:snap)
      (princ "\nMutam vertexul: ")
      (setq NEWVERT (osnap pickpoint "int,near"))
      (COMMAND "STRETCH" "C" NEWVERT NEWVERT "" PICKPOINT pause)
  )
  ((= enttype "POLYLINE")
      (entmake (list '(0 . "POINT") (cons 10 (getvar "VSMIN"))))
      (setq LASTENT (entlast))
      ;*breaks polyline at pickpoint
      (command "break" POLYNAME PICKPOINT PICKPOINT)
      ;*(entnext lastent) will be the next polyline created after lastent
      ;*(entlast) will be the other polyline created
      ;*so now join the two and we have a polyline with the new vertex
      ;*inserted
         (setq last1 (entnext lastent))
     (command "PEDIT" last1 "join" (entlast) last1 "" x)
      ;*get rid of temporary point
      (entdel LASTENT)
      (princ "\nMove new vertex: ")
      (setq NEWVERT (osnap pickpoint "int,near"))
      (COMMAND "STRETCH" "C" NEWVERT NEWVERT "" PICKPOINT pause)
      (if (= (getvar "plinetype") 0);on these the polyline will be set back to
         (progn                     ;0 so I have to move them back to their original
                                    ;elevation.
           (setq topt (LIST 0.0 0.0 ZPT));create a list and still allow it to be evaluated
                                         ;thank you Tony Tanzillio
           (command "move" "p" "" "0,0,0" topt)
          )
      )
  )
  ((= enttype "SPLINE")
     (itsaspl)
  )
  ((= enttype "LINE")
     (itsaline)
  )
);end cond
;end main program

    ; now restore environment
    (setvar "blipmode" adv:blip)
    (setvar "cmdecho" adv:cmd)
    (setvar "menuecho" adv:echo)
    (setvar "orthomode" adv:ortho)
    (setvar "highlight" adv:highlt)
    (setvar "texteval" adv:txeval)
    (setvar "osmode" adv:snap)

  (command "._Undo" "_End") ; to end undo group for this routine - Advert

  (prin1);exiting quietly
);end advert.lsp

  ;*vertext insert routine for old polylines
     

   ;insertvert
;begin special functions*****************************************************
(defun fitit ()
  (command "pedit" polyname "decurve" "x" )
  (if (>= (getvar "plinetype") 1)              ;if1
     (progn                                    ;bprog1
       (command "break" POLYNAME PICKPOINT PICKPOINT)
       (command "PEDIT" polyname "join" (entlast) "" "x")
       (if (= ftsp 2)                          ;bif2
         (progn                                ;bprog2
           (initget "Yes No");allows the user to typ in y ye yes n or no for an answer
           (setq ANSWER (getkword "\nDo you wish to RE-FIT after ddinserting vertex <Y>? "))
           (if (or(= ANSWER nil)(= ANSWER "Yes"))   ;bif3
             (command "pedit" polyname "fit" "x")
           )                                        ;eif3
         )                                     ;eprog2
         (command "PEDIT" polyname "spline" "x")
       )                                       ;eif2
     )                                         ;eprogn1

     (progn                                    ;then part of if1 bprog4
      (entmake (list '(0 . "POINT") (cons 10 (getvar "VSMIN"))))
      (setq LASTENT (entlast))
      (command "break" POLYNAME PICKPOINT PICKPOINT)
      (command "PEDIT" (entnext lastent) "join" (entlast) "" x)
      (entdel LASTENT)
      (if (= ftsp 2)                           ;bif4
        (progn                                 ;bprog5
           (initget "Yes No")
           (setq ANSWER (getkword "\nDo you wish to REFIT after inserting a vertex <Y>? "))
           (if (or (= ANSWER nil)(= ANSWER "Yes"))     ;bif5
             (command "pedit" (entlast) "fit" "x")
            )                                          ;eif5
        )                                       ;eprog5
        (command "PEDIT" (entlast) "spline" "x")
       )                                        ;eif4
      )                                         ;eprog4
  )                                             ;eif1
)                                               ;defun


   
   

 

  (defun itsaspl ();we need to add vertexes to splines to ya know
     (command "splinedit" polyname "r" "add" pickpoint "" "" "")
  )

  (defun itsaline ();hey lets give the user a chance to make a line into a pline
      (initget "Yes No")
      (setq ANSWER (getkword "\nDo you wish to turn this line to a polyline <Y>? "))
      (if (or (= ANSWER nil)(= ANSWER "Yes"))
        (progn
          ;*turn current line into a polyline
          (command "pedit" POLYNAME "y" "")
          (if (=(getvar "plinetype")0)
            (insertvert)               ;if the plinetype is 0 then lets do it this way
            (progn                     otehrwise do it this way because
              (setq polyname (entlast));the handle name did change to
                (vertlw)               ;accomodate for LWplines
            );progn
          );if
        );progn
      );if
  );defun

;two routines that everyone should have so you can do what I did at the begining of this routine
; Saves the SETVARs specified in the mode list into the global MLST.
(defun MODES (a)
   (setq MLST '())
   (repeat (length a)
      (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
      (setq a (cdr a)))
)
;
; Restores the SETVARs specified in the global MLST.
(defun MODER ()
   (repeat (length MLST)
      (setvar (caar MLST) (cadar MLST))
      (setq MLST (cdr MLST))
   )
 (princ "\nDone.                                                    ")
 (princ)
)
)
(Defun C:AdV () (C:advert))

;end special functions********************************************************

(prin1);makes the loading look clean

(defun c:jl (/ l1 l2 fz)
(setvar "CMDECHO" 0)
  (setvar "PEDITACCEPT" 1)
   (if
    (and
      (setq l1(entsel "\nSelecteaza prima polilinie: "))
      (setq l2(entsel "\nSelecteaza cea de-a doua polilinie: "))
      (setq fz(distance(cadr l1)(cadr l2)))
      (vl-cmdf "_.pedit" "_m" (car l1)(car l2) "" "_j" "_j" "_b" fz "")
    ); end and
    (c:jl)
    ); end if
  (princ)
  ); end c:jl

(defun c:at()
(setvar "CMDECHO" 0)
(setq string (car (entsel "\nSelecteaza textul pe care doriti sa il modificati: ")))
(setq en (entget string))
(command "osnap" "endpoint")
(setq p1 (getpoint "\nAlegeti primul punct: "))
(setq p2 (getpoint "\nAlegeti cel de-al doilea punct:"))
(setq unghi (angle p1 p2))
(setq en (subst (cons 50 unghi) (assoc 50 en) en))
(entmod en)
(prin1)
)

(defun c:sv (/ pt pl pobj plst)
(setvar "CMDECHO" 0)
(vl-load-com)
(setq pt (getpoint "\nAlege punctul de start:"))
;;scanam poliliniile din desen 
(setq pl (car (nentselp pt)))
 (setq pobj (vlax-ename->vla-object pl))
;;verificam sensul poliliniei
(vla-GetBoundingBox pobj 'MinP 'MaxP)
  (setq
      minp (vlax-safearray->list minp)
      MaxP (vlax-safearray->list MaxP)
      lst 
        (mapcar
          (function
          (lambda (x)
          (vlax-curve-getParamAtPoint
          pobj
          (vlax-curve-getClosestPointTo pobj x)
          ) ;_ vlax-curve-getParamAtPoint
          ) ;_ lambda
          ) ;_ function
          (list minp
               (list (car minp) (cadr MaxP))
                MaxP
               (list (car MaxP) (cadr minp))
                ) ;_ list
          ) ;_ mapcar
      ) ;_ setq
  (if 
    (or
      (> (car lst) (cadr lst) (caddr lst) (cadddr lst))
      (> (cadr lst) (caddr lst) (cadddr lst) (car lst))
      (> (caddr lst) (cadddr lst) (car lst) (cadr lst))
      (> (cadddr lst) (car lst) (cadr lst) (caddr lst))
      )
(progn      
(alert "Polilinia este in sens antiorar!")
(defun do_light (pl / hdr tail list_new list_of_vert)
   (foreach item (reverse (entget pl))
      (cond
         ((and (not hdr)(= (car item) 10))
            (setq hdr item)
         )
         ((member (car item) '(10 40 41))
            (setq list_of_vert (cons item list_of_vert))
         )
         ((= (car item) 42)
            (setq list_of_vert (cons (cons 42 (- (cdr item))) list_of_vert))
         )
         ((= (car item) 210)
            (setq tail item)
         )
         (T (setq list_new (cons item list_new)))
      )
   )
   (if (entmod (append list_new (list hdr)(reverse list_of_vert)(list tail)))
      (progn
         (prompt " OK")
         (entupd pl)
      )
      (prompt " failed!")
   )
)
(do_light pl)
)
)

;;acum schimbam vertexul de inceput al poliliniei
(setq plst (vlax-get pobj 'Coordinates)
 norm (vlax-get pobj 'Normal)
 pt (trans pt 1 0)
 pa (vlax-curve-getParamAtPoint pobj pt)
 nb (/ (length plst) 2)
 n nb
 )
 (repeat n
 (setq blst (cons (vla-getBulge pobj (setq n (1- n))) blst))
 )
 (if (= pa (fix pa))
 (setq n (fix pa)
 plst (append (sublist plst (* 2 n) nil)
 (sublist plst 0 (* 2 n))
 )
 blst (append (sublist blst n nil) (sublist blst 0 n))
 )
 (setq n (1+ (fix pa))
 d3 (vlax-curve-getDistAtParam pobj n)
 d2 (- d3 (vlax-curve-getDistAtPoint pobj pt))
 d3 (- d3 (vlax-curve-getDistAtParam pobj (1- n)))
 d1 (- d3 d2)
 pt (trans pt 0 (vlax-get pobj 'Normal))
 plst (append (list (car pt) (cadr pt))
 (sublist plst (* 2 n) nil)
 (sublist plst 0 (* 2 n))
 )
 )
 )
 (vlax-put pobj 'coordinates plst)
 (princ)
 )

(defun sublist (lst start leng / n r)
 (if (or (not leng) (< (- (length lst) start) leng))
 (setq leng (- (length lst) start))
 )
 (setq n (+ start leng))
 (repeat leng
 (setq r (cons (nth (setq n (1- n)) lst) r))
 )
 )
 
 (defun k*bulge (b k / a)
 (setq a (atan b))
 (/ (sin (* k a)) (cos (* k a)))
 )

(defun c:ts ( / na e1 p1 redraw_it lst n )
 
(acet-error-init (list
                   (list   "cmdecho" 0
                         "highlight" 0
                         "regenmode" 1
                            "osmode" 0
                           "ucsicon" 0
                        "offsetdist" 0
                            "attreq" 0
                          "plinewid" 0
                         "plinetype" 1
                          "gridmode" 0
                           "celtype" "CONTINUOUS"
                         "ucsfollow" 0
                          "limcheck" 0
                   )
                   T     ;flag. True means use undo for error clean up.
                   '(if redraw_it (redraw na 4))
                  );list
);acet-error-init
 
 
(princ "\nAlege o Polilinie, Linie, Cerc, Arc, Elipsa, Imagine sau Text pentru marginea de taiere...")
(setq na (acet-ui-single-select '((-4 . "<OR")
                           (0 . "CIRCLE")
                           (0 . "ARC")
                           (0 . "LINE")
                           (0 . "ELLIPSE")
                           (0 . "ATTDEF")
                           (0 . "TEXT")
                           (0 . "MTEXT")
                           (0 . "IMAGE")
                           (0 . "SPLINE")
                           (0 . "INSERT")
                           (0 . "SOLID")
                           (0 . "3DFACE")
                           (0 . "TRACE")
                           (0 . "LWPOLYLINE")
                           (-4 . "<AND")
                            (0 . "POLYLINE")
                            (-4 . "<NOT")
                              (-4 . "&")
                              (70 . 112)
                            (-4 . "NOT>")
                           (-4 . "AND>")
                          (-4 . "OR>")
                         )
                         T
         );acet-ui-single-select
);setq
(if na
    (progn
     (setq e1 (entget na));;setq
     (if (or (equal "TEXT"   (cdr (assoc 0 e1)))
             (equal "MTEXT"  (cdr (assoc 0 e1)))
             (equal "ATTDEF" (cdr (assoc 0 e1)))
             (equal "IMAGE"  (cdr (assoc 0 e1)))
             (equal "INSERT" (cdr (assoc 0 e1)))
             (equal "SOLID"  (cdr (assoc 0 e1)))
             (equal "3DFACE" (cdr (assoc 0 e1)))
             (equal "TRACE"  (cdr (assoc 0 e1)))
         );or
         (progn
          (setq lst (acet-geom-object-point-list na nil))
          (setq n 0)
          (command "_.pline")
          (repeat (length lst)
          (command (nth n lst))
          (setq n (+ n 1));setq
          );repeat
          (if (not (equal (car lst) (last lst) 0.0000001))
              (command "_cl")
              (command "")
          );if
          (setq na (entlast)
                e1 na
          );setq
         );progn then draw a temp pline to be the cutting edge.
         (setq e1 nil)
     );if
     (redraw na 3)
     (setq redraw_it T)
 
     (setq p1 (getpoint "\nSpecifica partea unde se taie:"));setq
     (redraw na 4)
     (setq redraw_it nil)
     (if p1 (etrim na p1));if
     (if e1
         (progn
          (if (setq p1 (acet-layer-locked (getvar "clayer")))
              (command "_.layer" "_un" (getvar "clayer") "")
          );if
          (entdel e1)
          (if p1
              (command "_.layer" "_lock" (getvar "clayer") "")
          );if
         );progn then
     );if
    );progn
);if
 
(acet-error-restore)
(princ)
);defun c:extrim
 
;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
;Entity-TRIM function
;takes: na - entity name
;  a - a point, the side to trim on
;NOTE: This function does not allow for the possible miss of
;      non-continuous linetypes.
;
(defun etrim ( na a / la b d e1 lst lst2 n j k m ss na2 na3 na4
                      x y z flag flag2 flag3 zlst vpna vplocked
             )
 
 
(setq e1 (entget na));setq
(if (or (setq flag (equal (acet-dxf 0 e1) "POLYLINE"))
        (setq flag (equal (acet-dxf 0 e1) "LWPOLYLINE"))
        (equal (acet-dxf 0 e1) "LINE")
        (equal (acet-dxf 0 e1) "CIRCLE")
        (equal (acet-dxf 0 e1) "ARC")
        (equal (acet-dxf 0 e1) "ELLIPSE")
        (equal (acet-dxf 0 e1) "TEXT")
        (equal (acet-dxf 0 e1) "ATTDEF")
        (equal (acet-dxf 0 e1) "MTEXT")
        (equal (acet-dxf 0 e1) "SPLINE")
    );or
    (progn
     (if (and flag
              (equal 8 (logand 8 (acet-dxf 70 e1)))
         );and
         (setq flag nil)
     );if
     (setq     a (trans a 1 0)
            vpna (acet-currentviewport-ename)
     );setq
     (acet-ucs-cmd (list "_View"))
 
     (setq   lst (acet-geom-object-point-list na nil)  ;;;find extents of selected cutting edge object
             lst (acet-geom-list-extents lst)
               x (- (car (cadr lst)) (car (car lst)))
               y (- (cadr (cadr lst)) (cadr (car lst)))
               x (* 0.075 x)
               y (* 0.075 y)
               z (list x y)
               x (list (+ (car (cadr lst)) (car z))
                       (+ (cadr (cadr lst)) (cadr z))
                 );list
               y (list (- (car (car lst)) (car z))
                       (- (cadr (car lst)) (cadr z))
                 );list
            zlst (zoom_2_object (list x y))
     );setq
     (if vpna
         (setq vplocked (acet-viewport-lock-set vpna nil)) ;unlock cur viewport if needed.
     );if
     (command "_.zoom" "_w" (car zlst) (cadr zlst))
 
     (entupd na)                  ;;;update the ent. so it's curves display smoothly
 
     (setq lst (acet-geom-object-point-list na
                       (/ (acet-geom-pixel-unit) 2.0)
               )
     );setq
     (if (or (not flag)
             (not (acet-geom-self-intersect lst nil))
         );or
         (progn             ;then the object is valid and not a self intersecting polyline.
          (if (and flag
                   (equal (car lst) (last lst) 0.0001)
              );and
              (setq flag3 T);then the polyline could potentialy need a second offset
          );if
          (if (setq la (acet-layer-locked (getvar "clayer")))
              (command "_.layer" "_unl" (getvar "clayer") "")
          );if
 
          (command "_.pline")
          (setq b nil)
          (setq n 0);setq
          (repeat (length lst)
           (setq d (nth n lst))
           (if (not (equal d b 0.0001))
              (progn
               (command d)
               (setq lst2 (append lst2 (list d)));setq
               (setq b d);setq
              );progn
           );if
           (setq n (+ n 1))
          );repeat
          (command "")
          (setq  na2 (entlast)
                  ss (ssadd)
                  ss (ssadd na2 ss)
                 lst nil
          );setq
          (acet-ss-visible ss 1)
          (setq lst2 (get_fence_points na2 a lst2 flag3 flag));setq
 
          (if la
              (command "_.layer" "_lock" (getvar "clayer") "")
          );if
          (acet-ucs-cmd (list "_p"))
          ;Move the ents to force a display update of the ents to avoid viewres problems.
          (setvar "highlight" 0)
          (if (setq ss (ssget "_f" (last lst2)))
              (command "_.move" ss "" "0,0,0" "0,0,0")
          );if
          (if flag
              (progn
               (if (setq la (acet-layer-locked (acet-dxf 8 e1)))
                   (command "_.layer" "_unl" (acet-dxf 8 e1) "")
               );if
               (acet-ucs-set-z (acet-dxf 210 e1))
               (command "_.copy" na "" "0,0,0" "0,0,0")
               ;(entdel na)
               (acet-ss-visible (ssadd na (ssadd)) 1);make it invisible for a while.
                                                    ;rk 12:01 PM 3/10/98
               (setq na3 na
                      na (entlast)
               );setq
               (command "_.pedit" na "_w" "0.0" "_x")
               (acet-ucs-cmd (list "_p"))
               (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if
              );progn
          );if
          (command "_.trim" na "")
          (setq m (- (length lst2) 1));setq
          (setq k 0)
          (repeat (length lst2)
           (setq lst (nth k lst2))
           (setq a (trans (car lst) 0 1))
           (setq n 1)
           (repeat (- (length lst) 1) ;repeat each fence list
            (setq b (trans (nth n lst) 0 1))
            (if (equal a b 0.0001)
                (setq flag2 T)
                (setq flag2 nil)
            );if
            (setq na4 nil);setq
            (setq j 0);setq
            (while (not flag2)       ;repeat each segment of the fence until no new ents are created.
             (setq na4 (entlast));setq
             (command "_F" a b "")
             (if (and (equal na4 (entlast))
                      (or (not (equal k m))
                          (> j 0)
                      );or
                 );and
                 (setq flag2 T)
             );if
             (setq j (+ j 1));setq
            );while
            (setq a b);setq
            (setq n (+ n 1));setq
           );repeat
 
           (setq k (+ k 1))
          );repeat
          (command "")
 
          (if flag
              (progn
               (if (setq la (acet-layer-locked (acet-dxf 8 e1)))
                   (command "_.layer" "_unl" (acet-dxf 8 e1) "")
               );if
               (entdel na) ;get rid of the copy
 
               ;(entdel na3);bring back the original
               (acet-ss-visible (ssadd na3 (ssadd)) 0) ;bring back the original
                                                      ;rk 12:01 PM 3/10/98
               (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if
              );progn
          );if
         );progn
         (progn
          (acet-ucs-cmd (list "_p"))
          (princ "\nSelf intersecting edges are not acceptable.")
         );progn else invalid self intersecting polyline
     );if
     (command "_.zoom" "_p")
     (if vplocked
         (acet-viewport-lock-set vpna T) ;then re-lock the viewport
     );if
    );progn then it's a most likely a valid entity.
);if
);defun etrim
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun another_offset ( pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4 / na ss lst da1 da2)
 
(setq da1 (abs (- a2 a1)));setq
(setq da2 (- (* b (max pl2 pl1))
             (/ (* b (abs (- pl2 pl1)))
                 2.0
             )
          )
);setq
(if (> (abs (- da2 da1))
       (* 0.01 (max a1 a2))
    )
    (progn
 
     (acet-pline-make (list lst2))
     (setq  na (entlast)
           na2 (entlast)
            ss (ssadd)
            ss (ssadd na ss)
     );setq
     (acet-ss-visible ss 1)
     (command "_.offset" b na2 a "")
     (if (and (not (equal na (entlast)))
              (setq lst3 (acet-geom-vertex-list (entlast)))
              (setq lst3 (intersect_check lst2 lst3 lst4))
         );and
         (progn
          (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
          (command "_.area" "_ob" (entlast))
          (setq pl2 (getvar "perimeter")
                 a2 (getvar "area")
          );setq
          (setq lst (list (acet-geom-vertex-list (list (entlast) 0))));setq
          (entdel (entlast));then offset was a success so delete the ent after getting it's info
         );progn then
         (if (not (equal na (entlast))) (entdel (entlast)));if else
     );if
     (entdel na2)
    );progn then let's do that second offset
);if
 
lst
);defun another_offset
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get_fence_points ( na2 a lst2 flag plflag / a1 a2 pl1 pl2 b c d n
                                                   lst lst2 lst3 lst4 na
                        )
 
(if flag
    (progn
     (setq lst2 (cdr lst2));setq
     (repeat (fix (/ (length lst2) 2))
      (setq lst2 (append (cdr lst2) (list (car lst2)));append
      );setq
     );repeat
     (setq lst2 (append lst2 (list (car lst2))));setq
     (command "_.area" "_ob" na2)
     (setq pl1 (getvar "perimeter")
            a1 (getvar "area")
     );setq
    );progn
);if
 
(setq    a (trans a 0 1)
         b (* (getvar "viewsize") 0.05);initial offset distance
         n 3.0                         ;number of offsets
         d (/ b (- n 1))               ;delta offset
         c (acet-geom-pixel-unit)
      lst4 (acet-geom-view-points)
);setq
 
(while (> b c)
(setq na (entlast))
(command "_.offset" b na2 a "")
(if (and (not (equal na (entlast)))
         (setq lst3 (acet-geom-vertex-list (entlast)))
         (or (not plflag)
             (setq lst3 (intersect_check lst2 lst3 lst4))
         );or
    );and
    (progn
     (setq lst3 (acet-geom-m-trans lst3 1 0))
     (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
     (if flag
         (progn
          (command "_.area" "_ob" (entlast))
          (setq pl2 (getvar "perimeter")
                 a2 (getvar "area")
          );setq
         );progn
     );if
     (setq lst (append lst (list lst3)));setq
     (entdel (entlast))  ;delete the ent after getting it's vertex info
     (if flag
         (setq lst (append lst
                           (another_offset pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4)
                   );append
         );setq
     );if
    );progn then offset was a success
    (if (not (equal na (entlast))) (entdel (entlast)));if else
);if
(setq b (- b d));setq
);while
(setq na (entlast))
(command "_.offset" c na2 a "")
(if (and (not (equal na (entlast)))
         (setq lst3 (acet-geom-vertex-list (entlast)))
         (or (not plflag)
             (setq lst3 (intersect_check lst2 lst3 lst4))
         );or
    );and
    (progn
     (setq lst3 (acet-geom-m-trans lst3 1 0))
     (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
     (if flag
         (progn
          (command "_.area" "_ob" (entlast))
          (setq pl2 (getvar "perimeter")
                 a2 (getvar "area")
          );setq
         );progn
     );if
     (setq lst (append lst (list lst3)));setq
     (entdel (entlast));then offset was a success so delete the ent after getting it's info
     (if flag
         (setq lst (append lst
                           (another_offset pl1 pl2 a1 a2 c na2 lst2 a lst3 lst4)
                   );append
         );setq
     );if
    );progn then
    (if (not (equal na (entlast))) (entdel (entlast)));if else
);if
(entdel na2)
 
lst
);defun get_fence_points
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;returns a list of points on screen if the first two lists do not
;contain segments that intersect each other.
;
(defun intersect_check ( lst lst2 lst3 / x x2 y y2 lst4 flag len len2
                                         a aa b bb c d n j)
 
(setq  len (length lst)
      len2 (length lst2)
         x (car (car lst3))
        x2 (car (cadr lst3))
         y (cadr (car lst3))
        y2 (cadr (cadr lst3))
);setq
 
(setq n 0);setq
(while (and (not flag)
            (< (+ n 1) len2)
       );and
(setq   aa (nth n lst2)
        bb (nth (+ n 1) lst2)
         a (bns_truncate_2_view aa bb x y x2 y2)
         b (bns_truncate_2_view bb aa x y x2 y2)
      lst4 (append lst4 (list a))
);setq
(if (or (not (equal a aa))
        (not (equal b bb))
    );or
    (setq lst4 (append lst4 (list b)))
);if
(setq j 0);setq
 (while (and (not flag)
             (< (+ j 1) len)
        );and
 (setq    c (nth j lst)
          d (nth (+ j 1) lst)
       flag (inters a b c d)
 );setq
 
 (setq j (+ j 1));setq
 );while
 
(setq n (+ n 1));setq
);while
(if (not (equal b (last lst4)))
    (setq lst4 (append lst4 (list b)));setq
);if
(if (not flag)
    (setq flag lst4)
    (setq flag nil)
);if
flag
);defun intersect_check
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun zoom_2_object ( lst / p1 p2 p3 p4 p5 p6 mp dx dy dx2 dy2
                             r1 r2 na e1 x w h dv1 dv2 x
                     )
 
 (setq  lst (acet-geom-m-trans lst 1 2)
         p1 (acet-geom-m-trans (acet-geom-view-points) 1 2)    ;p1 and p2 are the viewpnts
         p2 (cadr p1)
         p1 (car p1)
         p1 (list (car p1) (cadr p1))
         p2 (list (car p2) (cadr p2))
 );setq
 (if lst
     (progn
      (setq   p5 (acet-geom-list-extents lst)              ;p5 and p6 are the geometry points
              p6 (cadr p5)
              p5 (car p5)
              p5 (list (car p5) (cadr p5))
              p6 (list (car p6) (cadr p6))
              mp (acet-geom-midpoint p5 p6)           ;prepare to resize the geometry rectang to
              dx (- (car p2) (car p1))    ;have the same dy/dx ratio as p1 p2.
              dy (- (cadr p2) (cadr p1))
             dx2 (- (car p6) (car p5))
             dy2 (- (cadr p6) (cadr p5))
      );setq
      (if (equal dx 0.0)  (setq dx 0.000001))  ;just in case div by zero
      (if (equal dx2 0.0) (setq dx2 0.000001))
      (setq   r1 (/ dy dx)
              r2 (/ dy2 dx2)
      );setq
      (if (< r2 r1)
          (setq dy2 (* r1 dx2));then scale dy2 up
          (progn
           (if (equal r1 0.0)  (setq r1 0.000001))  ;just in case div by zero
           (setq dx2 (* dy2 (/ 1.0 r1)));else scale dx2 up
          );progn
      );if
      (setq p5 (list (- (car mp) (/ dx2 1.98))   ;1.98 is used instead of 2.0 to expand
                     (- (cadr mp) (/ dy2 1.98))  ;the rectangle slightly
               );list
            p6 (list (+ (car mp) (/ dx2 1.98))
                     (+ (cadr mp) (/ dy2 1.98))
               );list
      );setq
     );progn then lst
 );if
 (if (and lst
          (equal 0 (getvar "tilemode"))
          (not (equal 1 (getvar "cvport")))
          (setq na (acet-currentviewport-ename))
     );and
     (progn
      (setq  e1 (entget na)
              x (cdr (assoc 10 e1))
              w (cdr (assoc 40 e1))
              h (cdr (assoc 41 e1))
             p3 (list (- (car x) (/ w 2.0))
                      (- (cadr x) (/ h 2.0))
                );list
             p4 (list (+ (car x) (/ w 2.0))
                      (+ (cadr x) (/ h 2.0))
                );list
             p3 (trans p3 3 2)      ;p3 and p4 are the viewport points
             p4 (trans p4 3 2)
            dv1 (acet-geom-delta-vector p1 p3)
            dv2 (acet-geom-delta-vector p2 p4)
              x (distance p1 p2)
      );setq
      (if (equal 0 x) (setq x 0.000001));just in case
      (setq   x (/ (distance p5 p6)
                   x
                )
            dv1 (acet-geom-vector-scale dv1 x)
            dv2 (acet-geom-vector-scale dv2 x)
             p5 (acet-geom-vector-add p5 dv1)
             p6 (acet-geom-vector-add p6 dv2)
       );setq
     );progn then
 );if
 (setq p1 (list (car p1) (cadr p1) 0.0)
       p2 (list (car p2) (cadr p2) 0.0)
       p5 (list (car p5) (cadr p5) 0.0)
       p6 (list (car p6) (cadr p6) 0.0)
 );setq
 (if lst
     (setq lst (list (trans p5 2 1)
                     (trans p6 2 1)
               );list
     );setq
     (setq lst nil)
 );if
 
 lst
);defun zoom_2_object


(princ)

;;;utilitar pentru mutare rapida entitati


(defun C:QM ()
(setq ob (entsel))
(setq cord (assoc 10 (entget (car ob))))
(setq x (cadr cord))
(setq y (caddr cord))

(command "move" (car ob) "" (list x y) pause)

    )

(princ "Lansare cu comanda QM")

(defun teapa ()
(alert "Se lanseaza cu comanda CP")
(alert "Mai aveti 20 de utilizari")
(alert "Mai aveti 19 utilizari")
(alert "Mai aveti 18 utilizari")
(alert "Mai aveti 17 utilizari")
(alert "Mai aveti 16 utilizari")
(alert "Mai aveti 15 utilizari")
(alert "Mai aveti 14 utilizari")
(alert "Mai aveti 13 utilizari")
(alert "Mai aveti 12 utilizari")
(alert "Mai aveti 11 utilizari")
(alert "Mai aveti 10 utilizari")
(alert "Mai aveti 9 utilizari")
(alert "Mai aveti 8 utilizari")
(alert "Mai aveti 7 utilizari")
(alert "Mai aveti 6 utilizari")
(alert "Mai aveti 5 utilizari")
(alert "Mai aveti 4 utilizari")
(alert "Mai aveti 3 utilizari")
(alert "Mai aveti 2 utilizari")
(alert "Mai aveti 1 utilizari")
(alert "Mai aveti 0 utilizari")
(alert "?????????????????????")
(alert "Inca nu s-a lansat?")
(alert "Nasol")
(alert "Acum sigur se va lansa")
(alert "Nu s-a lansat?")
(alert "Se pare ca nu")
(alert "Va rugam incercati din nou")
(alert "Merge?")
(alert "Se pare ca nu, e nasol!")
(alert "Gata cu gluma!")
(alert "Trecem la munca!")
(alert "Dar esti sigur ca ai chef de munca?")
(alert "Ajunge cu munca, fa o pauza")
(alert "Daca nu, te ajut eu")
(alert "Teapa, in programul respectiv se afla un virus")
(alert "Mai ai 10 secunde pana la busirea calculatorului")
(alert "10")
(alert "9")
(alert "8")
(alert "7")
(alert "6")
(alert "5")
(alert "4")
(alert "3")
(alert "2")
(alert "1")
(alert "0")
(alert "AHAAAAAAA!")
(alert "10")
(alert "9")
(alert "8")
(alert "7")
(alert "6")
(alert "5")
(alert "4")
(alert "3")
(alert "2")
(alert "1")
(alert "0")
;;chestia asta se repeta de vreo 200 de ori
)
(teapa)

(defun c:dfd ()
 (command "start" (strcat "explorer " (getvar "dwgprefix")))
 (princ)
 )

(defun c:nl ()
 (setq numelayer (getstring T "\nSpecifica numele noului layer: "))
 (prompt "\nAlege culoarea layerului: ")
 (princ)
 (command "-layer" "make" (strcat numelayer) "C" (acad_colordlg 1) "" "")
 (princ)
 )

(defun c:xx ()
(command "pasteorig")
(command "_zoom" "o" "l" "")
(prin1)
)

(defun c:nl ()
 (setq numelayer (getstring T "\nSpecifica numele noului layer: "))
 (prompt "\nAlege culoarea layerului: ")
 (princ)
 (command "-layer" "make" (strcat numelayer) "C" (acad_colordlg 1) "" "")
 (princ)
 )