Recommended Posts

Witam,

Na wstepie powiem, ze mam znikome pojecie o programowaniu w lispie. Mam pewne podstawy VBA, ale widze, ze lisp to zupelnie inna para kaloszy. Chcialbym zmodyfikowac lekko kod, ktory znalazlem na tej stronie. Ten skrypt generuje tabelke z wartwa i dlugoscia wczesniej wybranych elementow. Dziala bardzo dobrze, jednak ja potrzebuje zamiast dlugosci, kolor objektu. Nie chodzi mi tu o kolor warstwy, a obiektu. 

Zupelnie nie widze w kodzie, ktora czesc odpowiada za zwrocenie dlugosci linii. Czy ktos z szanownych forumowiczow orientuje sie w jaki sposob moglbym dokonac powyzszej zmiany w kodzie? 

(defun C:LAYLENGTH ( / *error* acdoc ss p i e a d l) (vl-load-com)
  (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark acdoc)

  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*,*EXIT*"))
      (princ (strcat "\nError: " msg))
    )
    (if
      (= 8 (logand (getvar 'undoctl) 8))
      (vla-endundomark acdoc)
    )
    (princ)
    )
  
  (if
    (and
      (setq ss (ssget ":L" '((0 . "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE"))))
      (setq p (getpoint "\nTable scale depend on annotation scale.\nSpecify table insert point: "))
      )
    (progn
      (repeat
        (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i)))
              a (cdr (assoc 8 (entget e)))
              d (vlax-curve-getdistatparam e (vlax-curve-getendparam e))
        )
        (if
          (setq o (assoc a l))
          (setq l (subst (list a (+ (cadr o) d)) o l))
          (setq l (cons (list a d) l))
        )
      )
      (setq l (vl-sort l '(lambda (a b) (< (car a) (car b)))))
      (insert_table l p)
      )
    )
  (*error* nil)
  (princ)
  )

(defun insert_table (lst pct / tab row col ht i n space)
  (setq space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
        ht  (/ 2.5 (cond ((getvar 'cannoscalevalue)) (1.0)))
        pct (trans pct 1 0)
        n   (trans '(1 0 0) 1 0 T)
        tab (setq tab (vla-addtable space (vlax-3d-point pct) (+ 2 (length lst)) (length (car lst)) (* 2.5 ht) ht))
        )
  (vlax-put tab 'direction n)
  
  (mapcar
    (function
      (lambda (rowType)
        (vla-SetTextStyle  tab rowType (getvar 'textstyle))
        (vla-SetTextHeight tab rowType ht)
      )
    )
   '(2 4 1)
  )
  
  (vla-put-HorzCellMargin tab (* 0.14 ht))
  (vla-put-VertCellMargin tab (* 0.14 ht))

  (setq lst (cons (mapcar '(lambda (a) (strcat "Col" (itoa (1+ (vl-position a (car lst)))))) (car lst)) lst))

  (setq i 0)
  (foreach col (apply 'mapcar (cons 'list lst))
    (vla-SetColumnWidth tab i
      (apply
        'max
        (mapcar
          '(lambda (x)
             ((lambda (txb) (+ (abs (- (caadr txb) (caar txb))) (* 2.0 ht)))
              (textbox (list (cons 1 (vl-princ-to-string x)) (cons 7 (getvar 'textstyle)) (cons 40 ht)))
              )
             )
          col
          )
        )
      )
    (setq i (1+ i))
    )
  
  (setq lst (cons '("TITLE") lst))
  
  (setq row 0)
  (foreach r lst
    (setq col 0)
    (vla-SetRowHeight tab row (* 1.5 ht))
    (foreach c r
      (vla-SetText tab row col (if (numberp c) (rtos c) (vl-princ-to-string c)))
      (setq col (1+ col))
      )
    (setq row (1+ row))
    )
  )

 

Share this post


Link to post
Share on other sites
    (progn
      (repeat
        (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i)))
              a (cdr (assoc 8 (entget e)))	; odczyt nazwy warstwy obiektu
              d (vlax-curve-getdistatparam e (vlax-curve-getendparam e)) ; odczyt dlugosci obiektu
        )
        (if
          (setq o (assoc a l))	; jezeli warstwa jest juz na liscie
          (setq l (subst (list a (+ (cadr o) d)) o l))	; dodaj dlugosc elementu do lacznej dlugosci obiektow warstwy
          (setq l (cons (list a d) l))	; dodaj pare warstwa dlugosc do listy warstw
        )
      )

problem polega na tym, że długości obiektów na poszczególnych warstwach da się sumować ale nie da się sumować ich kolorów 😉

tak więc prosta przeróbka tego lispa raczej nie wchodzi w grę. Jak miałaby wyglądać ta tabelka?

warstwa1 -> kolor1 -> ilość1
warstwa1 -> kolor3 -> ilość3
warstwa2 -> kolor1 -> ilość1
warstwa2 -> kolor2 -> ilość2
warstwa2 -> kolor5 -> ilość5
etc.

???

Share this post


Link to post
Share on other sites
5 godzin temu, perlon napisał:

problem polega na tym, że długości obiektów na poszczególnych warstwach da się sumować ale nie da się sumować ich kolorów 😉

tak więc prosta przeróbka tego lispa raczej nie wchodzi w grę. Jak miałaby wyglądać ta tabelka?


warstwa1 -> kolor1 -> ilość1
warstwa1 -> kolor3 -> ilość3
warstwa2 -> kolor1 -> ilość1
warstwa2 -> kolor2 -> ilość2
warstwa2 -> kolor5 -> ilość5
etc.

???

Wlasciwie dlugosc calkowita elementow warstwy nie jest i potrzebna. Teraz zauwazylem, ze ten skrypt nie zupelnie odzwierciedla to czego poszukuje. 

Zalezy mi na takiej tabelce:

linia1 - > warstwalinii1 - > kolorlinii1 -> dlugosclinii1 (ewentualnie)

linia2 - > warstwalinii2 - > kolorlinii2 -> dlugosclinii2 (ewentualnie)

linia3 - > warstwalinii3 - > kolorlinii3 -> dlugosclinii3 (ewentualnie)

 

Tak wiec sumowanie nie jest konieczne, choc w ostateczniosci moge stworzyc kazda linie na odrebnej warstwie i wtedy zaproponowana przez Perlona tabelka tez by byla ok. 

Share this post


Link to post
Share on other sites

Jeden wiersz tabeli to jeden obiekt (encja)? Inaczej mówiąc ile kresek w zaznaczonym zbiorze to tyle wierszy w tabelce? A jeżeli na jednej warstwie jest kilka kresek w tym samym kolorze to co ma być w tabelce?

Edited by perlon

Share this post


Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...