Scripturi in LISP AutoLISP

John Doe · Oct 15, 2011, 11:38 AM

@diagodose2009: nu e chiar programul meu, tin minte ce-am scris in el. Ce as avea de spus:
Aplicatia numeroteaza punctele unui contur. Nu am verificat, probabil ca merge dar punctele par sa fie puse doar la un offset, unele se vor suprapune cu conturul iar daca sunt mai dese se vor suprapune unele cu altele.
Nu am observat sa puna nici distantele dintre puncte, oare nu ar fi bine? Si nici tabelul de coordonate nu-l scoate, nu ar fi misto sa-l puna in desen ca tabel sau intr-un fisier extern, de exemplu CSV ca sa te poti juca cu el in Excel ?
Si ar mai fi ceva: presupun ca conturul este o polilinie. Functie de o variabila (PLINEGEN, cred - nu mai stiu sigur), primul si ultimul punct al unei polilinii pot sa se repete chiar daca polilinia este inchisa, ai tratat aspectul asta?
Oricum, e ceva; si asa, cate putin, se poate construi un set de aplicatii utile usor de implementat in mediul CAD.

In alta ordine de idei: am reusit sa termin aplicatia pentru generarea fisierului CPXML unic pe tarla. Deci se poate. Gasiti un PDF cu mai multe despre la http://dl.transfer.ro/transfer_ro-14oct-619ff1d880eda8a6.zip" target="_blank">http://dl.transfer.ro/transfer_ro-14oct ... eda8a6.zip

raptor · Oct 15, 2011, 10:39 PM

@John Doe : am vizualizat pdf-ul tau si as vrea sa iti adresez o intrebare
Cat ar costa lisp-ul tau?, sau care ar fi conditiile in cara s-ar putea intra in posesia lui?

John Doe · Oct 15, 2011, 11:17 PM

Ti-am trimis mesaj pe privat despre pret si conditii.

bogdan.cadastru · Feb 18, 2012, 04:43 PM

caut un lisp care sa-mi faca suma unor numere in autocad...
similar excelului cand selectezi mai multe casute iti afiseaza undeva in dreapta jos

are cineva asa ceva?
stiu ca face TopoLT dar nu imi merge pe AutoCAD 2012 si sa nu ma mai chinui pt asta sa deschid win virtuas si sa intru in AutoCAD 2009....

bogdan.cadastru · Feb 18, 2012, 06:02 PM

intre timp am reusit sa gasesc unul care face exact ce vroiam eu
chiar mai mult
aduna valorile selectate (suprafetele unui releveu) si nu numai ca afiseaza valoarea dar o si scrie ca text in autocad

---------------------------------------------------

(defun C:STX (/ cpent elist en ip newtxt pt ss sum sumtxt txt)
(princ "\n\t\t>>> Select text to get summ >>>"

http://www.3xforum.ro/img/smilies/wink.png">
(if
;;select texts/mtexts on screen :
(setq ss (ssget '((0 . "*TEXT"

http://www.3xforum.ro/img/smilies/wink.png">)))
;; if selected then :
(progn
;; store the first text entity for using 'em further :
(setq cpent (ssname ss 0))
;; set initial sum to zero :
(setq sum 0.)
;; loop trough selected texts/mtexts :
(while
;; get the first text in selection :
(setq en (ssname ss 0))
;; get entity list of them :
(setq elist (entget en))
;; get the textstring by key 1 from entity list :
(setq txt (cdr (assoc 1 elist)))
;; create output string :
(setq sumtxt
;; concatenate strings :
(strcat
;; convert digits to string :
(rtos
;; add to summ the digital value of text :
(setq sum (+ (atof txt) sum))
;; 2 is for metric units (3 for engineering) :
2
;; set precision by current :
(getvar "dimdec"

http://www.3xforum.ro/img/smilies/wink.png">))
)
;; delete entity from selection set :
(ssdel en ss)
)
;; display message in the command line:
(princ (strcat "\nSumm=" sumtxt))
(setq pt (getpoint "\nSpecify the new text location: "

http://www.3xforum.ro/img/smilies/wink.png">)
;; get the insertion point of stored entity :
(setq ip (cdr (assoc 10 (entget cpent))))
;; copy text entity to the new destination point :
(command "_copy" cpent "" ip pt)
;; get the last created entity :
(setq newtxt (entlast))
;; get entity list of them :
(setq elist (entget newtxt))
;; modify entity list with new text string :
(entmod (subst (cons 1 sumtxt)(assoc 1 elist) elist))
;; update changes :
(entupd newtxt)
)
)
(princ)
)
(princ "\nStart command with STX..."

http://www.3xforum.ro/img/smilies/wink.png">
(princ)

---------------------------------------------------

advex · Feb 19, 2012, 05:30 PM

bogdan.cadastru a scris:

caut un lisp care sa-mi faca suma unor numere in autocad...

Daca o sa apelezi la prietenul Google sunt convins ca o sa gasesti o multime de aplicatii care pot sa te ajute.

La http://www.theswamp.org/index.php?topic=32984.msg384478" target="_blank">http://www.theswamp.org/index.php?topic=32984.msg384478 (autor Alan J. Thompson) este disponibil un lisp care rezolva toata gama de operatii aritmetice.

http://www.theswamp.org/screens/alanjt/CombineValues-v1.2.gif" alt="" border="0" align="top">

Code:

;;; ------------------------------------------------------------------------
;;;    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  14) ">"))
    (setq text (RE:Replace slashflag "\\\\\\\\" str))
    ;; Temporarily replace literal left curly brace.
    (setq lbrace (strcat "<L" (substr (rtos (getvar "CDATE") 2  14) ">"))
    (setq text (RE:Replace lbrace "\\\\{" text))
    ;; Temporarily replace literal right curly brace.
    (setq rbrace (strcat "<" (substr (rtos (getvar "CDATE") 2  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)
)

_______________________________________
http://info-topograf.blogspot.ro/" target="_blank">http://info-topograf.blogspot.ro/

zamfy · Feb 20, 2012, 03:55 PM

John Doe a scris:

@diagodose2009: nu e chiar programul meu, tin minte ce-am scris in el. Ce as avea de spus:
Aplicatia numeroteaza punctele unui contur. Nu am verificat, probabil ca merge dar punctele par sa fie puse doar la un offset, unele se vor suprapune cu conturul iar daca sunt mai dese se vor suprapune unele cu altele.
Nu am observat sa puna nici distantele dintre puncte, oare nu ar fi bine? Si nici tabelul de coordonate nu-l scoate, nu ar fi misto sa-l puna in desen ca tabel sau intr-un fisier extern, de exemplu CSV ca sa te poti juca cu el in Excel ?
Si ar mai fi ceva: presupun ca conturul este o polilinie. Functie de o variabila (PLINEGEN, cred - nu mai stiu sigur), primul si ultimul punct al unei polilinii pot sa se repete chiar daca polilinia este inchisa, ai tratat aspectul asta?
Oricum, e ceva; si asa, cate putin, se poate construi un set de aplicatii utile usor de implementat in mediul CAD.

De fapt, era un programel scris de mine, nu de John Doe.
Am luat criticile lui John Doe ca sugestii si intre timp l-am mai modificat, iar acum pune si distantele dintre puncte (cotarile) si scoate si inventarul de coordonate. L-am modificat sa lucreze doar cu polilinii inchise, ca sa nu ia de 2 ori vertecsii extremi. Mai am putin de lucru la ea (cum ar fi numerotarea corecta a conturului, chiar daca a fost desenat in sensul invers al acelor de ceasornic) si mai da erori la polilinii cu foarte multi vertecsi (peste 100), dar in 99% din cazuri functioneaza corect. Oricine se pricepe la LISP poate sa mai imbuntateasca programul.
Ceea ce am vrut de la acest program a fost sa inlocuiesc cu succes cele 3 comenzi din TopoLT: autopct, dimpl si arr2 si am reusit intr-o oarecare masura.
Am vazut ca programul anterior a fost descarcat de un numar destul de mare de oameni (peste 60), asa ca link-ul de download pentru cel nou este:
http://www.fileshare.ro/47184568329.7" target="_blank">http://www.fileshare.ro/47184568329.7

Modificat de zamfy (20-02-2012 13:57:40)

bianca.cad · Feb 20, 2012, 06:54 PM

Mersi.

_______________________________________
http://www.facebook.com/dMine.poezii/" target="_blank">www.facebook.com/dMine.poezii/

John Doe · Feb 20, 2012, 08:58 PM

@zamfy: felicitari. Limbajul DCL te intereseaza?

zamfy · Feb 21, 2012, 10:43 AM

Pentru cei care au probleme cu link-ul de pe fileshare, acesta este un link de pe rapidshare:
https://rapidshare.com/files/2749746465/pune_puncte_pe_contur.lsp" target="_blank">https://rapidshare.com/files/2749746465 ... contur.lsp.
@John Doe, sigur ca ma intereseaza limbajul DCL, dar deocamdata am vrut sa stiu limbajul LISP la un nivel cat de cat mediu si apoi o sa invat si DCL-ul. Oricum, pentru ferestre de dialog este foarte bun si OpenDCL (cu toate ca mai are unele bug-uri).
Oricum, ca interfata, mie imi place foarte mult linia de comanda, mi se pare mai usor sa apas o tasta decat sa caut cu mouse-ul butoane.

John Doe · Feb 21, 2012, 06:32 PM

Pentru scripturi micute, cu putine date de intrare e mult mai comod cum spui tu, dar daca ajungi la aplicatii mai complexe casetele te ajuta enorm, vezi cu ochii tai ce ai introdus sau nu.
Cauta pe Google "AfraLISP" , o sa gasesti printre altele si un manual DCL - numai in lb. engleza, dar e foarte explicit. Sau daca vrei doar manualul asta ti-l trimit eu pe mail.

John Doe · Apr 08, 2012, 02:25 AM

As vrea sa stiu daca ar fi utila cuiva (in afara de mine) o aplicatie (tot in LISP...) care face fisierul CPXML pentru avizarea planurilor parcelare cf. ordinului 415, in baza planului si tabelului parcelar.

raptor · Apr 08, 2012, 02:32 AM

Poi este utila doar ca nu toata lumea care face planuri parcelare foloseste tabel in X-cel cum ai tu definit ( de exemplu stiu pe cineva care a lucrat in word, sau in OpenOffice).
Este o aplicatie utila , cel putin asa mi se pare mie din ce ai prezentat, dar util in momentul in care ai de lucrat mult cu planuri parcelare, si ai tarlale c multi proprietari.
In orice caz , ai un LIKE de la mine

http://www.3xforum.ro/img/smilies/razz.png">

John Doe · Apr 08, 2012, 01:09 PM

@raptor: Tabelul de unde isi ia datele aplicatia este exact anexa care se depune la OCPI, salvata in format CSV din Excel sau Open Office.

Ideea este ca nu toata lumea face neaparat planuri parcelare, dar cine totusi a facut a observat ca stai cateva ore ca sa faci un CPXML cu o suta de parcele cu "GenerareCP". Daca totusi sunt topografi interesati, o sa revin cu amanunte.

Atopor · Apr 09, 2012, 07:04 PM

John, eu ma folosesc de un tabel excell pentru a-mi genera anexele automat in Word, dar nu si CP-ul. Ma ajuti sa-l generez si pe acesta? Sau, daca fac CP-ul cum pot face baza de date in Excell, pentru ca apoi sa-mi generez anexele? Multumesc.