Sum Text Strings to Text Field...

[Lee Mac]

than there is that extra button: Additional Format:

and you can set the conversion factor there...

 

Gotcha, I'm a programmer, not a drafter

[Lee Mac]

Try this:

 

(defun c:a2f (/ *error* Stringify ENT OBJ PT TMP TOBJ TYP UFLAG)
 ;; Lee Mac  ~  13.01.10
 (vl-load-com)

 (defun *error* (msg)
   (and uFlag (vla-EndUndoMark *doc*))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))
 

 (defun Stringify (x / typ)
   (cond (  (eq 'REAL (setq typ (type x)))
            (rtos x))
         (  (eq 'INT typ)
            (itoa x))
         (  (eq 'STR typ) x)
         (t (vl-princ-to-string x))))
 

 (setq *doc* (cond (*doc*) ((vla-get-ActiveDocument
                              (vlax-get-acad-object))))

       *spc* (cond (*spc*) ((if (zerop (vla-get-activespace *doc*))
                              (if (= (vla-get-mspace *doc* :vlax-true))
                                (vla-get-modelspace *doc*)
                                (vla-get-paperspace *doc*))
                              (vla-get-modelspace *doc*)))))

 (or *a2f_Uni (setq *a2f_Uni 2))
 (or *a2f_Pre (setq *a2f_Pre 3))
 (or *a2f_Con (setq *a2f_Con 1.))
 (or *a2f_Hgt (setq *a2f_Hgt (getvar 'TEXTSIZE)))
 (or *a2f_Rot (setq *a2f_Rot 0.))
 (or *a2f_Suf (setq *a2f_Suf "m2"))

 (mapcar (function set) '(*a2f_Uni *a2f_Pre *a2f_Con *a2f_Hgt *a2f_Rot *a2f_Suf)
         (mapcar
           (function
             (lambda (ini foo msg x)
               (and ini (initget ini))
               (cond ((and (setq tmp ((eval foo) (strcat msg " <" (Stringify x) "> : ")))
                           (/= "" tmp)) tmp)
                     (x))))
            
            (list 6 4 6 6 nil nil)
           '(GetInt GetInt GetReal GetDist GetAngle GetString)
           '("Specify Units" "Specify Precision" "Specify Conversion Factor"
             "Specify Text Height" "Specify Text Rotation" "Specify Suffix")
            (list *a2f_Uni *a2f_Pre *a2f_Con *a2f_Hgt *a2f_Rot *a2f_Suf)))
           
 (while
   (progn
     (setq ent (car (entsel "\n>> Pick Hatch, Circle or Closed Polyline >>")))

     (cond (  (eq 'ENAME (type ent))

              (if (vlax-property-available-p
                    (setq obj (vlax-ename->vla-object ent)) 'Area)
                
                (if (setq pt (getpoint "\nPick Point for Field: "))
                  (progn
                    (setq uFlag (not (vla-StartUndoMark *doc*)))

                    (setq tObj
                      (vla-AddMText *spc* (vlax-3D-point pt) 0.0
                        (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                (vl-princ-to-string (vla-get-ObjectId obj))
                                ">%).Area \\f \"%lu" (itoa *a2f_Uni) "%pr"
                                (itoa *a2f_Pre) "%ps[," *a2f_Suf "]%ct8[" (rtos *a2f_Con) "]\">%")))

                    (mapcar
                      (function
                        (lambda (property value)
                          (vlax-put-property tObj property value)))

                      '(Height Rotation Layer Color)
                       (list *a2f_Hgt *a2f_Rot (vlax-get-property obj 'Layer)
                                               (vlax-get-property obj 'Color)))

                    (setq uFlag (vla-EndUndoMark *doc*))

                    t) ;; repeat

                  )

                (princ "\n** Invalid Object Selected **"))))))
 (princ))

[tomjas]

:shock:

 

I'm afraid to ask you for more changes

 

Working great (but not on solid hatch)- any ideas why?

 

Gile's code- excellent but is matching layer of first selected object and other properties (suffix, precision) from object selected as a last

 

Sorry for making so many problems

 

and I've found another BIG issue wit gile's code. You need to select each label individually rather than all of them on one go- you can imagine what will happen if you have 2000 labels with areas!!!!! Any solution?

[Lee Mac]

Working great (but not on solid hatch)- any ideas why?

 

Seems to work ok for me...

 

 

Gile's code- excellent but is matching layer of first selected object and other properties (suffix, precision) from object selected as a last

 

Sorry for making so many problems

 

and I've found another BIG issue wit gile's code. You need to select each label individually rather than all of them on one go- you can imagine what will happen if you have 2000 labels with areas!!!!! Any solution?

 

I don't particularly want to mess with Gile's code too much, as I'd rather let him modify his own routine. :wink: but I can see what I can do

[Lee Mac]

Try this:

 

;; ADDFIELDS (gile)
;; Insert a text field wich value is the sum of selected fields

;; Modified by Lee Mac to Accept SelSet

(defun c:AddFields (/ *error* i ss fObj ent code pos lst res tObj)
 (vl-load-com)

 (defun *error* (msg)
   (or (= msg "Fuction cancelled")
       (princ (strcat "Error: " msg)))
   (princ))
 
 (or *acdoc* (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object))))

 (if (setq i -1 ss (ssget '((0 . "MTEXT,TEXT"))))
   (progn
     (setq fObj (vlax-ename->vla-object (ssname ss 0)))
     
     (while (setq ent (ssname ss (setq i (1+ i))))

       (if (and (setq code (gc:FieldCode ent))
                (setq pos  (vl-string-search "%<" code))
                (setq code (substr code (1+ pos)))
                (setq pos  (vl-string-position 37 code 1 t))
                (setq code (substr code 1 (1+ pos))))

         (if (assoc ent lst)
           (setq lst (vl-remove (assoc ent lst) lst))
           (setq lst (cons (cons ent code) lst)))))

     (if (and lst (setq ins (getpoint "\nPick Point for Field: ")))
       (progn
         (setq code (cdr (last lst))

               res (strcat "%<\\AcExpr "
                           (lst2str (mapcar (function cdr) lst) " + ")
                           " " (if (setq pos (vl-string-position (ascii "\\") code 1 t))
                                 (substr code (1+ pos)) ">%")))

         (setq TObj (vla-addText
                      (if (= 1 (getvar 'cvport))
                        (vla-get-PaperSpace *acdoc*)
                        (vla-get-ModelSpace *acdoc*)) res
                      (vlax-3d-point (trans ins 1 0))
                      (getvar 'textsize)))          
         (mapcar
           (function
             (lambda (x)
               (vlax-put-property tObj x
                 (vlax-get-property fObj x)))) '(Layer Color))))))

 (princ))


;;========================= ROUTINES =========================;;

;; gc:FieldCode (gile)
;; Returns the string value of a text mtext or attribute with field code
;;
;; Argument : the entity name (ENAME)

(defun gc:FieldCode (ent / foo elst xdict dict field str)

 ;;--------------------------------------------------------;;
 (defun foo (field str / pos fldID objID)
   (setq pos 0)
   (if (setq pos (vl-string-search "\\_FldIdx " str pos))
     (while (setq pos (vl-string-search "\\_FldIdx " str pos))
       (setq fldId (entget (cdr (assoc 360 field)))
             field (vl-remove (assoc 360 field) field)
             str   (strcat
                     (substr str 1 pos)
                     (if (setq objID (cdr (assoc 331 fldId)))
                       (vl-string-subst
                         (strcat "ObjId " (itoa (gc:EnameToObjectId objID)))
                         "ObjIdx"
                         (cdr (assoc 2 fldId))
                       )
                       (foo fldId (cdr (assoc 2 fldId)))
                     )
                     (substr str (1+ (vl-string-search ">%" str pos)))
                   )
       )
     )
     str
   )
 )
 ;;--------------------------------------------------------;;
 
 (setq elst (entget ent))
 (if (and
   (member (cdr (assoc 0 elst)) '("ATTRIB" "MTEXT" "TEXT"))
   (setq xdict (cdr (assoc 360 elst)))
   (setq dict (dictsearch xdict "ACAD_FIELD"))
   (setq field (dictsearch (cdr (assoc -1 dict)) "TEXT"))
     )
   (setq str (foo field (cdr (assoc 2 field))))
 )
)

;;============================================================;;

;; gc:EnameToObjectId (gile)
;; Returns the ObjectId from an ename
;;
;; Argument : an ename

(defun gc:EnameToObjectId (ename)
 ((lambda (str)
    (hex2dec
      (substr (vl-string-right-trim ">" str) (+ 3 (vl-string-search ":" str)))
    )
  )
   (vl-princ-to-string ename)
 )
)

;;============================================================;;

;; hex2dec (gile)
;; Converts an hexadecimal (string) to a decimal (int)
;;
;; Argument : a string figuring an hexadecimal

(defun hex2dec (s / r l n)
 (setq    r 0 l (vl-string->list (strcase s)))
 (while (setq n (car l))
   (setq l (cdr l)
         r (+ (* r 16) (- n (if (<= n 57) 48 55)))
   )
 )
)

;;============================================================;;

;; lst2str (gile)
;; Concatenates a list of strings and a separator into a string
;;
;; Arguments
;; lst : the list to convert
;; sep : the separator (string)

(defun lst2str (lst sep)
 (if (cdr lst)
   (strcat (car lst) sep (lst2str (cdr lst) sep))
   (car lst)
 )
)

 

Apologies for messing with your code Gile.

[tomjas]

but I can see what I can do

 

sounds good to me

 

I'm using Civil 3d 2010 at home and is not working with solid hatch!

I'll try at work tomorrow morning with CAD 2009, 2010 and Civil 2009, 2010- will see is there any difference.

 

Have a nice evening!

[gile]

Apologies for messing with your code Gile.

No need to apologize, Lee, I had no time to do it...

[Lee Mac]

I'm using Civil 3d 2010 at home and is not working with solid hatch!

 

When you say it is not working - what happens?? Does it throw an error? Does the field show ####?

[tomjas]

SORTED GUYS!!!

 

I've change some settings with selecting objects and is working GREAT!

 

THANK YOU VERY MUCH!!!

[Lee Mac]

SORTED GUYS!!!

 

I've change some settings with selecting objects and is working GREAT!

 

THANK YOU VERY MUCH!!!

 

Does the Hatch now work? Are you referring to the code I modified above?

[tomjas]

solid hatch is working now (I've change my civil 3d settings)

 

once again thank you very much

[Lee Mac]

solid hatch is working now (I've change my civil 3d settings)

 

once again thank you very much

 

Excellent

[wizman]

Good Job, Lee...'-)

[tomjas]

Is there any easy way to change a2f routine (by Lee) to be able to select only hatch (not circle or closed poliline)?

[Lee Mac]

Good Job, Lee...'-)

 

Thanks Wiz

 

Is there any easy way to change a2f routine (by Lee) to be able to select only hatch (not circle or closed poliline)?

 

Blimey... picky lol

[Lee Mac]

Try this:

 

(defun c:a2f (/ *error* Stringify ENT OBJ PT TMP TOBJ TYP UFLAG)
 ;; Lee Mac  ~  13.01.10
 (vl-load-com)

 (defun *error* (msg)
   (and uFlag (vla-EndUndoMark *doc*))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))
 

 (defun Stringify (x / typ)
   (cond (  (eq 'REAL (setq typ (type x)))
            (rtos x))
         (  (eq 'INT typ)
            (itoa x))
         (  (eq 'STR typ) x)
         (t (vl-princ-to-string x))))
 

 (setq *doc* (cond (*doc*) ((vla-get-ActiveDocument
                              (vlax-get-acad-object))))

       *spc* (cond (*spc*) ((if (zerop (vla-get-activespace *doc*))
                              (if (= (vla-get-mspace *doc* :vlax-true))
                                (vla-get-modelspace *doc*)
                                (vla-get-paperspace *doc*))
                              (vla-get-modelspace *doc*)))))

 (or *a2f_Uni (setq *a2f_Uni 2))
 (or *a2f_Pre (setq *a2f_Pre 3))
 (or *a2f_Con (setq *a2f_Con 1.))
 (or *a2f_Hgt (setq *a2f_Hgt (getvar 'TEXTSIZE)))
 (or *a2f_Rot (setq *a2f_Rot 0.))
 (or *a2f_Suf (setq *a2f_Suf "m2"))

 (mapcar (function set) '(*a2f_Uni *a2f_Pre *a2f_Con *a2f_Hgt *a2f_Rot *a2f_Suf)
         (mapcar
           (function
             (lambda (ini foo msg x)
               (and ini (initget ini))
               (cond ((and (setq tmp ((eval foo) (strcat "\n" msg " <" (Stringify x) "> : ")))
                           (/= "" tmp)) tmp)
                     (x))))
            
            (list 6 4 6 6 nil nil)
           '(GetInt GetInt GetReal GetDist GetAngle GetString)
           '("Specify Units" "Specify Precision" "Specify Conversion Factor"
             "Specify Text Height" "Specify Text Rotation" "Specify Suffix")
            (list *a2f_Uni *a2f_Pre *a2f_Con *a2f_Hgt *a2f_Rot *a2f_Suf)))
           
 (while
   (progn
     (setq ent (car (entsel "\n>> Pick Hatch [And don't you dare pick anything else]  >>")))

     (cond (  (eq 'ENAME (type ent))

              (if (and (eq "AcDbHatch" (vla-get-ObjectName (setq obj (vlax-ename->vla-object ent))))
                       (vlax-property-available-p obj 'Area))
                
                (if (setq pt (getpoint "\nPick Point for Field: "))
                  (progn
                    (setq uFlag (not (vla-StartUndoMark *doc*)))

                    (setq tObj
                      (vla-AddMText *spc* (vlax-3D-point pt) 0.0
                        (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                (vl-princ-to-string (vla-get-ObjectId obj))
                                ">%).Area \\f \"%lu" (itoa *a2f_Uni) "%pr"
                                (itoa *a2f_Pre) "%ps[," *a2f_Suf "]%ct8[" (rtos *a2f_Con) "]\">%")))

                    (mapcar
                      (function
                        (lambda (property value)
                          (vlax-put-property tObj property value)))

                      '(Height Rotation Layer Color)
                       (list *a2f_Hgt *a2f_Rot (vlax-get-property obj 'Layer)
                                               (vlax-get-property obj 'Color)))

                    (setq uFlag (vla-EndUndoMark *doc*))

                    t) ;; repeat

                  )

                (princ "\n** Invalid Object Selected **"))))))
 (princ))

[tomjas]

And don't you dare pick anything else

 

this will help me a LOT!!!

 

Thanks all you guys for your effort!

[Lee Mac]

this will help me a LOT!!!

 

Thanks all you guys for your effort!

 

You're welcome Tom

[Madruga_SP]

@ Mr.Lee

The code on post #45 sounds good for me.

But I need change the formula of the code. Instead of sum , I need divide the objects.

e.g

((158494.64/658900.44)*100)= 24.05

 

Thank in advance.

Regards

[Chetan]

On 1/12/2010 at 10:01 PM, Lee Mac said:

Try this:

 

 

(defun c:FSum2 (/ Units Prec Suff First fObj FldStr pt ss)
 ;; Lee Mac  ~  12.01.10
 (vl-load-com)
 [color=Blue][b](setq Units 2 Prec 3 Suff "m2") ;; Formatting[/b][/color]

 (setq doc (cond (doc) ((vla-get-ActiveDocument
                          (vlax-get-Acad-Object)))))
 
 (setq FldStr "%<\\AcExpr \(")  
 (if (and (ssget '((0 . "TEXT,MTEXT")))
          (setq pt (getpoint "\nSelect Point for Field: ")))
   (progn
     (vlax-for obj (setq ss (vla-Get-ActiveSelectionSet doc))
       (or First (setq First obj))

       (setq FldStr
        (strcat FldStr
          "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-ObjectId Obj)) ">%).TextString>% +")))

     (vla-Delete ss)

     (setq FObj
       (vla-AddMText (vla-get-ModelSpace doc)
         (vlax-3D-point pt) 0. (setq FldStr
           (strcat (substr FldStr 1 (1- (strlen FldStr)))
                    "\) \\f \"%lu" (itoa Units) "%pr" (itoa Prec) "%ps[," Suff "]\">%"))))

     (mapcar
       (function
         (lambda (property)
           (and (vlax-property-available-p First property)
                (vlax-put-property FObj property
                  (vlax-get-property First property)))))

       '(Layer Color StyleName Width))))                  

 (princ))

 

 

Can you please update for me for replace select point to select text