Re: how to edit lisp of material

nychoe1 · ‎04-19-2014

could you do programing in Lisp of that materials, please

all selected -> automaticcally calculate in W/T

-----------------------------------------------------------------------------------------------------------------------
(defun c:ww ()
(defun *error* (msg)(princ "error: ")(princ msg)
(setvar "osmode" os)(setvar "orthomode" ot)
(princ))
;-<*error* end
   (setq os (getvar "osmode") ot (getvar "orthomode")
         ts (getvar "textsize"))
   (setvar "orthomode" 0) (setvar "osmode" 0)

   (setq ss (ssget '((0 . "text"))))
   (setq grpt (grread T))
   (setq pt1 (cadr grpt))
   (setq ssn (sslength ss))
   (setq txnum-lst nil)
   (setq k 0)
   (repeat ssn
      (setq en (ssname ss k))
      (setq tx (cdr (assoc 1 (entget en))))

      (setq pn (vl-string-position (ascii ",") tx));nil
      (while pn
         (setq tx (strcat (substr tx 1 pn) (substr tx (+ pn 2)) ))
         (setq pn (vl-string-position (ascii ",") tx))
      )
      ;-<
      (setq txnum-lst (append (@tx_num_lst tx) txnum-lst))
      (setq k (+ k 1))
   )
   (setq ar1 (apply '* txnum-lst))
   (setq ar2 (rtos ar1 2 dot))
   (if (>= dot 1)
       (setq ar3 (@tx_dot ar2 dot))
       (setq ar3 ar2)

   )
(setq ar7 (* ar1 0.00000785))
(setq dd (rtos ar7 2 1))
(setq t (entsel "\n >>> select text:"))
(setq tt (entget (car t)))
(setq ttt (assoc 1 tt))
(entmod (subst (cons 1 dd) ttt tt))

   (setvar "osmode" os)(setvar "orthomode" ot)
(prin1)
)

(defun @tx_num_lst(tx / txn k tx1 tx2 tx3 txnum-lst)
(setq txn (strlen tx) tx2 "" txnum-lst nil k 1 )
(repeat (+ txn 1)
    (setq tx1 (substr tx k 1))
    (if (or (= 46 (ascii tx1)) (<= 48 (ascii tx1) 57))
        (setq tx2 (strcat tx2 tx1))
        (progn
          (if (/= tx2 "")(setq txnum-lst (append txnum-lst (list (atof tx2)))) )
          (setq tx2 "")
        ) )
    (setq k (1+ k))
)
txnum-lst)

(defun @tx_dot(tx dot / k k1 tx tx1 tx2 tx3)
   (setq k1 (vl-string-position (ascii ".") tx))
   (if (= k1 nil) (setq tx1 (strcat tx ".0")) (setq tx1 tx))
   (setq k (strlen tx1))
   (setq k1 (vl-string-position (ascii ".") tx1))
   (setq tx2 (substr tx1 1 (+ k1 1)))
   (setq tx3 (substr tx1 (+ k1 2)))
   (setq k (strlen tx3))
   (while (< k dot)
      (setq tx3 (strcat tx3 "0"))
      (setq k (strlen tx3))
   )
   (strcat tx2 tx3)
)

devitg · ‎04-19-2014

Please upload the DWG

nychoe1 · ‎04-19-2014

Dwg file...^^

marko_ribar · ‎04-20-2014

Here you go...

(defun c:wt ( / _assoc _vl-remove unique mip-text-entmake LM:ParseNumbers txts txtst osm ss ssel p txt txtl pl xpl ypl txtls nl xn xnl pt k )

  (defun _assoc ( e l f )
    (car (vl-member-if '(lambda ( x ) (equal e (car x) f)) l))
  )

  (defun _vl-remove ( e l f )
    (vl-remove-if '(lambda ( x ) (equal e x f)) l)
  )

  (defun unique ( l )
    (if l (cons (car l) (unique (_vl-remove (car l) (cdr l) 1e-6))))
  )

  (defun mip-text-entmake ( txt pnt height width rotation justification / ent_list )
    ;;; borrowed from ShaggyDoc
    ;;; http://www.caduser.ru/forum/index.php?PAGE_NAME=read&FID=23&TID=30276
    ;;; Draw text with entmake Lisp function
    ;;; Arguments:
    ;;; txt - text string
    ;;; pnt - point in WCS
    ;;; height - text height
    ;;; width - text width
    ;;; rotation - rotation angle
    ;;; justification - justification or nil

    (setq  ent_list (list  '(0 . "TEXT")
       '(100 . "AcDbEntity")
       '(100 . "AcDbText")
       (list 10 (car pnt) (cadr pnt) 0.0)
       (cons 1 txt)
       (cons 40 height)
       (cons 7 (getvar "TEXTSTYLE"))
       (if justification
         (cond
           ((= justification "C")
            '(72 . 1)
           )
           ((= justification "R")
            '(72 . 2)
           )
           ((= justification "A")
            '(72 . 3)
           )
           ((= justification "M")
            '(72 . 4)
           )
           ((= justification "F")
            '(72 . 5)
           )
           (t
            '(72 . 0)
           )
         ) ;_ end of cond
         '(72 . 0)
       ) ;_ end of if
       (cons 50 rotation)
       (cons 41 width)
       (list 11 (car pnt) (cadr pnt) 0.0)
       ) ;_ end of list
     ) ;_ end of setq
     (setq ent_list (entmakex ent_list))
  )

  ;;-------------------=={ Parse Numbers }==--------------------;;
  ;;                                                            ;;
  ;;  Parses a list of numerical values from a supplied string. ;;
  ;;------------------------------------------------------------;;
  ;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
  ;;------------------------------------------------------------;;
  ;;  Arguments:                                                ;;
  ;;  s - String to process                                     ;;
  ;;------------------------------------------------------------;;
  ;;  Returns:  List of numerical values found in string.       ;;
  ;;------------------------------------------------------------;;

  (defun LM:ParseNumbers ( s )
    (
      (lambda ( l )
        (read
          (strcat "("
            (vl-list->string
              (mapcar
                (function
                  (lambda ( a b c )
                    (if
                      (or
                        (< 47 b 58)
                        (and (= 45 b) (< 47 c 58) (not (< 47 a 58)))
                        (and (= 46 b) (< 47 a 58) (< 47 c 58))
                      )
                      b 32
                    )
                  )
                )
                (cons nil l) l (append (cdr l) (list nil))
              )
            )
            ")"
          )
        )
      )
      (vl-string->list s)
    )
  )

  (setq txts (getvar 'textsize))
  (setvar 'textsize 150.0)
  (setq txtst (getvar 'textstyle))
  (setvar 'textstyle "JW")
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (setq ss (ssget '((0 . "TEXT"))))
  (setq ssel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  (foreach ent ssel
    (setq p (cdr (assoc 11 (entget ent)))
          txt (cdr (assoc 1 (entget ent)))
    )
    (setq txtl (cons (cons p txt) txtl))
    (setq pl (cons p pl))
  )
  (setq xpl (vl-sort pl '(lambda ( a b ) (< (car a) (car b)))))
  (setq xpl (mapcar 'car xpl))
  (setq xpl (unique xpl))
  (setq ypl (vl-sort pl '(lambda ( a b ) (> (cadr a) (cadr b)))))
  (setq ypl (mapcar 'cadr ypl))
  (setq ypl (unique ypl))
  (foreach y ypl
    (foreach x xpl
      (setq txtls (cons (cdr (_assoc (list x y 0.0) txtl 1e-6)) txtls))
    )
  )
  (setq txtls (reverse txtls))
  (foreach y ypl
    (foreach x xpl
      (if (/= (atof (car txtls)) 0.0)
        (setq nl (cons (atof (car txtls)) nl))
        (foreach n (LM:ParseNumbers (car txtls))
          (setq nl (cons n nl))
        )
      )
      (setq txtls (cdr txtls))
    )
    (setq xn (apply '* nl))
    (setq xn (* xn 0.00000785))
    (setq xnl (cons xn xnl))
    (setq nl nil)
  )
  (setq xnl (reverse xnl))
  (prompt "\nSpecify position of resulting W/T of materials - middle of W/T column of table...")
  (command "_.xline" "_V" "\\" "")
  (setq pt (cdr (assoc 10 (entget (entlast)))))
  (entdel (entlast))
  (setq k -1)
  (foreach n xnl
    (mip-text-entmake (rtos n 2 1) (list (car pt) (nth (setq k (1+ k)) ypl) 0.0) 0.0 0.8 0.0 "M")
  )
  (setvar 'textsize txts)
  (setvar 'textstyle txtst)
  (setvar 'osmode osm)
  (princ)
)

HTH, M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)

nychoe1 · ‎04-21-2014

hello, I am amply satisfied with your answer, thank you so much... I love it.

marko_ribar · ‎04-21-2014

@nychoe1 wrote:
hello, I am amply satisfied with your answer, thank you so much... I love it.

nychoe1, I am glad it's helpful to you... Thanks for Kudo...

Regards, M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)

nychoe1 · ‎04-21-2014

one more,,, please...

I wish W/T stand right in a column like the image...

.

marko_ribar · ‎04-21-2014

@nychoe1 wrote:
one more,,, please...

I wish W/T stand right in a column like the image...

.

(defun c:wt ( / _assoc _vl-remove unique mip-text-entmake LM:ParseNumbers txts txtst osm ss ssel p txt txtl pl xpl ypl txtls nl xn xnl pt k )

  (defun _assoc ( e l f )
    (car (vl-member-if '(lambda ( x ) (equal e (car x) f)) l))
  )

  (defun _vl-remove ( e l f )
    (vl-remove-if '(lambda ( x ) (equal e x f)) l)
  )

  (defun unique ( l )
    (if l (cons (car l) (unique (_vl-remove (car l) (cdr l) 1e-6))))
  )

  (defun mip-text-entmake ( txt pnt height width rotation justification justification_vertical / ent_list )
    ;;; borrowed from ShaggyDoc
    ;;; http://www.caduser.ru/forum/index.php?PAGE_NAME=read&FID=23&TID=30276
    ;;; Draw text with entmake Lisp function
    ;;; Arguments:
    ;;; txt - text string
    ;;; pnt - point in WCS
    ;;; height - text height
    ;;; width - text width
    ;;; rotation - rotation angle
    ;;; justification - justification or nil
    ;;; justification_vertical - justification_vertical or nil

    (setq  ent_list (list  '(0 . "TEXT")
       '(100 . "AcDbEntity")
       '(100 . "AcDbText")
       (list 10 (car pnt) (cadr pnt) 0.0)
       (cons 1 txt)
       (cons 40 height)
       (cons 7 (getvar "TEXTSTYLE"))
       (if justification
         (cond
           ((= justification "C")
            '(72 . 1)
           )
           ((= justification "R")
            '(72 . 2)
           )
           ((= justification "A")
            '(72 . 3)
           )
           ((= justification "M")
            '(72 . 4)
           )
           ((= justification "F")
            '(72 . 5)
           )
           (t
            '(72 . 0)
           )
         ) ;_ end of cond
         '(72 . 0)
       ) ;_ end of if
       (cons 50 rotation)
       (cons 41 width)
       (list 11 (car pnt) (cadr pnt) 0.0)
       (if justification_vertical
         (cond
           ((= justification_vertical "C")
            '(73 . 0)
           )
           ((= justification_vertical "T")
            '(73 . 1)
           )
           ((= justification_vertical "M")
            '(73 . 2)
           )
           ((= justification_vertical "B")
            '(73 . 3)
           )
           (t
            '(73 . 0)
           )
         ) ;_ end of cond
         '(73 . 0)
       ) ;_ end of if
       ) ;_ end of list
     ) ;_ end of setq
     (setq ent_list (entmakex ent_list))
  )

  ;;-------------------=={ Parse Numbers }==--------------------;;
  ;;                                                            ;;
  ;;  Parses a list of numerical values from a supplied string. ;;
  ;;------------------------------------------------------------;;
  ;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
  ;;------------------------------------------------------------;;
  ;;  Arguments:                                                ;;
  ;;  s - String to process                                     ;;
  ;;------------------------------------------------------------;;
  ;;  Returns:  List of numerical values found in string.       ;;
  ;;------------------------------------------------------------;;

  (defun LM:ParseNumbers ( s )
    (
      (lambda ( l )
        (read
          (strcat "("
            (vl-list->string
              (mapcar
                (function
                  (lambda ( a b c )
                    (if
                      (or
                        (< 47 b 58)
                        (and (= 45 b) (< 47 c 58) (not (< 47 a 58)))
                        (and (= 46 b) (< 47 a 58) (< 47 c 58))
                      )
                      b 32
                    )
                  )
                )
                (cons nil l) l (append (cdr l) (list nil))
              )
            )
            ")"
          )
        )
      )
      (vl-string->list s)
    )
  )

  (setq txts (getvar 'textsize))
  (setvar 'textsize 150.0)
  (setq txtst (getvar 'textstyle))
  (setvar 'textstyle "JW")
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (setq ss (ssget '((0 . "TEXT"))))
  (setq ssel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  (foreach ent ssel
    (setq p (cdr (assoc 11 (entget ent)))
          txt (cdr (assoc 1 (entget ent)))
    )
    (setq txtl (cons (cons p txt) txtl))
    (setq pl (cons p pl))
  )
  (setq xpl (vl-sort pl '(lambda ( a b ) (< (car a) (car b)))))
  (setq xpl (mapcar 'car xpl))
  (setq xpl (unique xpl))
  (setq ypl (vl-sort pl '(lambda ( a b ) (> (cadr a) (cadr b)))))
  (setq ypl (mapcar 'cadr ypl))
  (setq ypl (unique ypl))
  (foreach y ypl
    (foreach x xpl
      (setq txtls (cons (cdr (_assoc (list x y 0.0) txtl 1e-6)) txtls))
    )
  )
  (setq txtls (reverse txtls))
  (foreach y ypl
    (foreach x xpl
      (if (/= (atof (car txtls)) 0.0)
        (setq nl (cons (atof (car txtls)) nl))
        (foreach n (LM:ParseNumbers (car txtls))
          (setq nl (cons n nl))
        )
      )
      (setq txtls (cdr txtls))
    )
    (setq xn (apply '* nl))
    (setq xn (* xn 0.00000785))
    (setq xnl (cons xn xnl))
    (setq nl nil)
  )
  (setq xnl (reverse xnl))
  (prompt "\nSpecify position of resulting W/T of materials - right side of W/T column of table...")
  (command "_.xline" "_V" "\\" "")
  (setq pt (cdr (assoc 10 (entget (entlast)))))
  (entdel (entlast))
  (setq k -1)
  (foreach n xnl
    (mip-text-entmake (rtos n 2 1) (list (car pt) (nth (setq k (1+ k)) ypl) 0.0) 0.0 0.8 0.0 "R" "M")
  )
  (setvar 'textsize txts)
  (setvar 'textstyle txtst)
  (setvar 'osmode osm)
  (princ)
)

M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)

nychoe1 · ‎04-21-2014

so cooooooool~

how to edit lisp of material

how to edit lisp of material

Forums Links

Post to forums