Add undo function to routine

[C.Utzinger]

HI

I have this code, and i'm looking for an undo function, so i can eliminate the last introduced copied block and continue with the Routine.

(defun Punktkopie ( / ent obj att fieldcode gesch str ulay klay pt inserted)

(defun LM:getattributevalue ( blk tag / enx )
    (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
        (if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
            (cdr (assoc 1 (reverse enx)))
            (LM:getattributevalue blk tag)
        )
    )
)

  (while T
   (if (and (setq ent (entsel "\nGeoreferenzierter Punkt wählen: "))
            (= (vla-get-ObjectName (setq obj (vlax-ename->vla-object (car ent)))) "AcDbBlockReference")
            (= (vla-get-EffectiveName obj) "SPI-Datenextraktionspunkt-CM")
            (setq att (nentselp (cadr ent)))
            (= (vla-get-ObjectName (setq att (vlax-ename->vla-object (car att)))) "AcDbAttribute")
       )
       (progn
         (setq gesch (LM:GetAttributeValue (car ent) "01" )
               str (if (vl-string-search "-" gesch)(vl-string-right-trim "-" (vl-string-right-trim "0123456789" gesch))(vl-string-right-trim "0123456789" gesch))
               ulay (if (= str "")(strcat "-I-Koordinatenpunkte-" str "Unsichtbar")(strcat "-I-Koordinatenpunkte-" str "-Unsichtbar"))
               klay (if (= str "")(strcat "-I-Koordinatenpunkte-" str "Kopie")(strcat "-I-Koordinatenpunkte-" str "-Kopie")))
         (if (wcmatch gesch "*;*")
               (progn 
                  (alert "Punktkopie mit dem alten Textformat nicht möglich!")
                  (exit)))
         (command "_.-layer" "_m" ulay "_co" "251" ulay "_p" "_n" ulay "")
         (vla-put-Layer obj ulay)
         (command "_.-LAYER" "_m" klay "_co" "2" klay "")
         (setq fieldcode (strcat "%<\\AcObjProp Object\(%<\\_ObjId " (itoa (vla-get-objectid att)) ">%\).TextString>%"))

         (setq pt (getpoint (strcat "\nEinfügepunkt für Punktkopie von " gesch " angeben: ")))

                (command "_.-INSERT" "SPI-Punktkopie" "_none" pt 1 1 "" fieldcode ""))
       )
   ) ; end of if
  ) ; end of while
) ; end of defun

Please help

[DannyNL]

If you want to program to exit in a nice way, you need to make sure the while loop doesn't keep running by make the condition is false (nil).

 
(defun Punktkopie ( / run ent obj att fieldcode gesch str ulay klay pt inserted)

(defun LM:getattributevalue ( blk tag / enx )
    (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
        (if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
            (cdr (assoc 1 (reverse enx)))
            (LM:getattributevalue blk tag)
        )
    )
)
  
  (setq run T)
  (while run
   (if (and (setq ent (entsel "\nGeoreferenzierter Punkt wählen: "))
            (= (vla-get-ObjectName (setq obj (vlax-ename->vla-object (car ent)))) "AcDbBlockReference")
            (= (vla-get-EffectiveName obj) "SPI-Datenextraktionspunkt-CM")
            (setq att (nentselp (cadr ent)))
            (= (vla-get-ObjectName (setq att (vlax-ename->vla-object (car att)))) "AcDbAttribute")
       )
       (progn
         (setq gesch (LM:GetAttributeValue (car ent) "01" )
               str (if (vl-string-search "-" gesch)(vl-string-right-trim "-" (vl-string-right-trim "0123456789" gesch))(vl-string-right-trim "0123456789" gesch))
               ulay (if (= str "")(strcat "-I-Koordinatenpunkte-" str "Unsichtbar")(strcat "-I-Koordinatenpunkte-" str "-Unsichtbar"))
               klay (if (= str "")(strcat "-I-Koordinatenpunkte-" str "Kopie")(strcat "-I-Koordinatenpunkte-" str "-Kopie")))
         (if (wcmatch gesch "*;*")
               (progn 
                  (alert "Punktkopie mit dem alten Textformat nicht möglich!")
                  (exit)))
         (command "_.-layer" "_m" ulay "_co" "251" ulay "_p" "_n" ulay "")
         (vla-put-Layer obj ulay)
         (command "_.-LAYER" "_m" klay "_co" "2" klay "")
         (setq fieldcode (strcat "%<\\AcObjProp Object\(%<\\_ObjId " (itoa (vla-get-objectid att)) ">%\).TextString>%"))

         (setq pt (getpoint (strcat "\nEinfügepunkt für Punktkopie von " gesch " angeben: ")))

                (command "_.-INSERT" "SPI-Punktkopie" "_none" pt 1 1 "" fieldcode ""))
       )
       (setq run nil)
   ) ; end of if
  ) ; end of while
) ; end of defun

Now if you do not select an object in (setq ent (entsel "\nGeoreferenzierter Punkt wählen: ") the IF statement will be false and RUN will be set to nil.

The condition for the WHILE loop is now false and the routine will exit. This will hopefully eliminate the need for an undo.

Does this solve the problem?

[ВeekeeCZ]

I think this could work...

You should add the cmdecho off...  at least.

(defun c:Punktkopie ( / adoc ent obj att fieldcode gesch str ulay klay pt inserted enl)
  
  (defun LM:getattributevalue ( blk tag / enx )
    (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
      (if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
	(cdr (assoc 1 (reverse enx)))
	(LM:getattributevalue blk tag))))
  
  (vla-endundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (vla-startundomark adoc)
  
  (while
    (and (not (initget "Undo"))
	 (setq ent (entsel "\nGeoreferenzierter Punkt wählen [Undo] <exit>: "))
	 (cond ((= ent "Undo")
		(setq enl (entlast))
		(vl-cmdf "_.UNDO" "1")
		(if (equal enl (entlast))
		  (vl-cmdf "_.UNDO" "1"))
		T)
	       ((not ent))
	       ((and
		  ent
		  (= (vla-get-ObjectName (setq obj (vlax-ename->vla-object (car ent)))) "AcDbBlockReference")
		  (= (vla-get-EffectiveName obj) "SPI-Datenextraktionspunkt-CM")
		  (setq att (nentselp (cadr ent)))
		  (= (vla-get-ObjectName (setq att (vlax-ename->vla-object (car att)))) "AcDbAttribute")
		  (setq gesch (LM:GetAttributeValue (car ent) "01" ))
		  (or (not (wcmatch gesch "*;*"))
		      (alert "Punktkopie mit dem alten Textformat nicht möglich!"))
		  (setq fieldcode (strcat "%<\\AcObjProp Object\(%<\\_ObjId " (itoa (vla-get-objectid att)) ">%\).TextString>%"))
		  (setq gesch (LM:GetAttributeValue (car ent) "01"))
		  (setq pt (getpoint (strcat "\nEinfügepunkt für Punktkopie von " gesch " angeben: ")))
		  )
		(setq str (vl-string-right-trim "-0123456789" gesch)
		      str (if (= "" str) "" (strcat str "-"))
		      ulay (strcat "-I-Koordinatenpunkte-" str "Unsichtbar")
		      klay (strcat "-I-Koordinatenpunkte-" str "Kopie"))
		(command "_.UNDO" "_Mark")
		(or (tblsearch "LAYER" ulay)
		    (command "_.-layer" "_m" ulay "_co" "251" ulay "_p" "_n" ulay ""))
		(vla-put-Layer obj ulay)
		(command "_.-LAYER" "_m" klay "_co" "2" klay "")
		(command "_.-INSERT" "SPI-Punktkopie" "_none" pt 1 1 "" fieldcode "")
		T))))
  (vla-endundomark adoc)
  (princ)
  )

BTW

This craziness

(if (vl-string-search "-" gesch)
(vl-string-right-trim "-" (vl-string-right-trim "0123456789" gesch))
(vl-string-right-trim "0123456789" gesch))

you should replace with 
(vl-string-right-trim "-0123456789" gesch) 

EDIT: code updated

[C.Utzinger]

Hi

Nice hint, I use that! But that's not what i'm looking for.

I want to copy some Points, but if i copy a wrong one, i want to go one back and not finish the Routine and start it again.

Thank you

[C.Utzinger]

HI

the craziness is because when I have a value like OG1-001, i want to keep OG1 and not just OG.

But if there is another way...?

Kind regards.

[ВeekeeCZ]

---

@C.Utzinger wrote:

HI

the craziness is because when I have a value like OG1-001, i want to keep OG1 and not just OG

But if there is another way...?

Kind regards.

---

Try just this: (vl-string-right-trim "-" (vl-string-right-trim "0123456789" gesch)) - if there is no dash nothing wrong happens.

BUT (not sure because I don't know all the varieties... - if you have letters then a dash is always included, right?)

If you will cut just numbers... (vl-string-right-trim "0123456789" gesch) then keep the dash, because you don't need to test and add it later.

I think (setq str (vl-string-right-trim "0123456789" gesch)) is just enough. Remove the second line (if (= str "")... from my code.

[C.Utzinger]

Thats the Problem

I can have:

001

EG-001

EG001

So i have it like this now:

 (setq str (vl-string-right-trim "0123456789" gesch)
       str (if (and (/= str "")(not (wcmatch str "*-*")))(strcat str "-") str))

Kind regards

[ВeekeeCZ]

In that case I would go for the trimming the dash first, then test just "". I looks cleaner to me than your (if (and (not (not...

Anyway, in your expression you should have just "*-" (no second *)

[C.Utzinger]

Thank you

If I trimm the dash like "-0123456789", then i have a Problem with values OG1-001.

I think this one is clean enougth.

(setq str (vl-string-right-trim "0123456789" gesch)
      str (cond ((= str "") str)
                ((wcmatch str "*-") str)
                (T (strcat str "-"))))

[ВeekeeCZ]

I meant the way in post #6. But take your preferences.

(defun c:Punktkopie ( / adoc ent obj att fieldcode gesch str ulay klay pt inserted enl)
  
  (defun LM:getattributevalue ( blk tag / enx )
    (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
      (if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
	(cdr (assoc 1 (reverse enx)))
	(LM:getattributevalue blk tag))))
  
  (vla-endundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (vla-startundomark adoc)
  
  (while
    (and (not (initget "Undo"))
	 (setq ent (entsel "\nGeoreferenzierter Punkt wählen [Undo] <exit>: "))
	 (cond ((= ent "Undo")
		(setq enl (entlast))
		(vl-cmdf "_.UNDO" "1")
		(if (equal enl (entlast))
		  (vl-cmdf "_.UNDO" "1"))
		T)
	       ((not ent))
	       ((and
		  ent
		  (= (vla-get-ObjectName (setq obj (vlax-ename->vla-object (car ent)))) "AcDbBlockReference")
		  (= (vla-get-EffectiveName obj) "SPI-Datenextraktionspunkt-CM")
		  (setq att (nentselp (cadr ent)))
		  (= (vla-get-ObjectName (setq att (vlax-ename->vla-object (car att)))) "AcDbAttribute")
		  (setq gesch (LM:GetAttributeValue (car ent) "01" ))
		  (or (not (wcmatch gesch "*;*"))
		      (alert "Punktkopie mit dem alten Textformat nicht möglich!"))
		  (setq fieldcode (strcat "%<\\AcObjProp Object\(%<\\_ObjId " (itoa (vla-get-objectid att)) ">%\).TextString>%"))
		  (setq gesch (LM:GetAttributeValue (car ent) "01"))
		  (setq pt (getpoint (strcat "\nEinfügepunkt für Punktkopie von " gesch " angeben: ")))
		  )
		(setq str (vl-string-right-trim "-" (vl-string-right-trim "0123456789" gesch))
		      str (if (= "" str) "" (strcat str "-"))
		      ulay (strcat "-I-Koordinatenpunkte-" str "Unsichtbar")
		      klay (strcat "-I-Koordinatenpunkte-" str "Kopie"))
		(command "_.UNDO" "_Mark")
		(or (tblsearch "LAYER" ulay)
		    (command "_.-layer" "_m" ulay "_co" "251" ulay "_p" "_n" ulay ""))
		(vla-put-Layer obj ulay)
		(command "_.-LAYER" "_m" klay "_co" "2" klay "")
		(command "_.-INSERT" "SPI-Punktkopie" "_none" pt 1 1 "" fieldcode "")
		T))))
  (vla-endundomark adoc)
  (princ)
  )