kruszynski

Witam Sprawdziłem temat przyciągania w blokach i potwierdzam wystąpienie problemu. Oczywiście przekażę to do ZWSOFT. Problem występuje tylko na elementach typu polilinie 2d w blokach. Zastanawia mnie jak zostały stworzone te polilinie w Pana rysunku. Funkcje _rectang i _pline tworzą elementy typu Polilinia a nie polilinia2d. Czy to powstało w jakieś nakładce albo jakiejś starej wersji CADa? Temat grup jest mi znany i został zgłoszony do ZWSOFT już jakiś czas temu. API wciąż jest rozwijane. Obecna wersja ma już coś (podstawowa funkcjonalność LISP, ZRX) , ale do osiągnięcia pełnej zgodności łatwości uruchomienia aplikacji dodatkowych, API wymaga jeszcze trochę pracy i czasu . Pozdrawiam

Korzystając z LISP spróbowałem odczytać nazwę bloku dynamicznego którego reprezentacją jest blok * Ux. Wymaga to kilku kroków. Może nie będę zanudzał szczegółami, ale w skrócie powiem, że informacja o oryginalnym bloku dynamicznym, nie jest zapisana bezpośrednio w bloku Ux, ale w bloku są odwołania do innych miejsc z bazy danych rysunku, przez które trzeba przejść żeby zidentyfikować bazowy blok dynamiczny. W ZWCAD+ 2015 udaje się to bez problemu, natomiast uruchamiając ten sam program na ZWCAD Classic w pewnym miejscu pojawia się tzw obiekt proxy. W tym przypadku jest to poważny problem, bo żeby móc przetłumaczyć proxy na blok dynamiczny sam ZWCAD musi mieć obsługę tych bloków. Niestety na chwilę obecną nie daje nam to możliwości odczytania nazwy oryginalnego bloku dynamicznego w ZWCAD Classic. Natomiast z deklaracji ZWSOFT wynika, że w ZWCAD 2017 obsługa bloków dynamicznych ma być analogiczna jak w ZWCAD+ 2015.

W ZWCAD+ 2015 można utworzyć styl multilinii korzystając z funkcji entmakex: (defun AddMLeaderStyle ( stylename data / dict item ) (cond ( (not (setq dict (cdr (assoc -1 (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE"))))) nil ) ( (setq item (dictsearch dict stylename)) (entmod (cons (assoc -1 item) data)) ) ( (setq item (entmakex data)) (dictadd dict stylename item) ) ) ) (AddMLeaderStyle "test" '( (0 . "MLEADERSTYLE") (100 . "AcDbMLeaderStyle") (179 . 2) (170 . 2) (171 . 1) (172 . 0) (90 . 2) (40 . 0.0) (41 . 0.0) (173 . 1) (91 . -1023410173) (92 . -2) (290 . 1) (42 . 1.0) (291 . 1) (43 . 1.0) (3 . "Standard") (44 . 1.0) (300 . "") (174 . 1) (178 . 1) (175 . 1) (176 . 0) (93 . -1073741824) (45 . 1.0) (292 . 0) (297 . 0) (46 . 0.18) (94 . -1056964608) (47 . 1.0) (49 . 1.0) (140 . 1.0) (293 . 1) (141 . 0.0) (294 . 1) (177 . 0) (142 . 1.0) (295 . 0) (296 . 0) (143 . 1.0) (271 . 0) (272 . 9) (273 . 9) ) ) Znaczenie poszczególnych kodów DXF opisane jest np tutaj: http://help.autodesk.com/view/ACD/2016/ENU/?guid=GUID-0E489B69-17A4-4439-8505-9DCE032100B4 Postaram się dowiedzieć jak dodać style w ZWCAD Classic i jakie są plany odnośnie ZWCAD 2017 AddMLeaderStyle.lsp

Witam Przygotowałem program pozwalający wczytywać właściwości rysunku z pliku jaki Pan przesłał. Nazwy właściwości powinny być w pierwszym wierszu w kolejnych kolumnach, wartości w wierszu drugim, tak jak na Pana przykładzie w pierwszym arkuszu Pozdrawiam. ImportWlasciwosci.zel

Witam Właściwości rysunku można czytać przez lisp . Author = "zxczxc" Comments = "zcxzxczxczcz" HyperlinkBase = "czc" Keywords = "zxcz" LastSavedBy = "kruszynski" RevisionNumber = "" Subject = "sddd" Title = "asd" Po świętach postaram się przygotować programik, który będzie zapisywał właściwości do pliku CSV i zapisywał właściwości z CSV do rysunku ZWCAD. Czy może Pan przesłać przykładowe dane w Excelu, jakie chce Pan importować? Pozdrawiam

Witam. Ten format pliku shp który ja znam, to czcionki. Oczywiście nie zaprzeczam, że dane GIS można zapisywać w formacie, który ma taką samą nazwę. Sam ZWCAD nie posiada funkcjonalności, pozwalającej bezpośrednio wczytać taki plik. Pozdrawiam

W tej wersji nie ma jeszcze VBA.

Pod względem składni LISP do ZWCADa i do AutoCADa jest taki sam. Natomiast ze względu na ochronę praw autorskich programy LISP zwykle są kompilowane (AutoCAD) lub szyfrowane (ZWCAD). Jeśli się nie mylę to zaszyfrowanego w ZWCAD plik LSP lub ZEL nie można wczytać w AutoCadzie.

Proszę zobaczyć jak działa program z załącznika. Cały trik oparty jest na takiej sztuczce, że uruchamiając polecenie refedit zapisujemy uchwyt elementu ostatnio zapisanego do bazy, następnie w funkcji odfiltrowujemy wszystkie elementy, których uchwyty, zostały dodane przed rozpoczęciem działania funkcji refedit. (setq g_lastHandle nil g_tmpHandel nil) (defun callbackStart(obj lst) (if (= "REFEDIT" (car lst)) (setq g_lastHandle (cdr (assoc 5 (entget (entlast))))) ) ) (defun callbackEnd(obj lst) (if (= "REFCLOSE" (car lst)) (progn (setq g_tmpHandel g_lastHandle) (setq g_lastHandle nil) ) ) ) (defun callbackAbort(obj lst) (if (= "REFEDIT" (car lst)) (setq g_lastHandle nil) ) (if (= "REFCLOSE" (car lst)) (setq g_lastHandle g_tmpHandel) ) ) (if (null refeditDetect) (setq refeditDetect (vlr-command-reactor nil '((:vlr-commandWillStart . callbackStart) (:vlr-commandEnded . callbackEnd) (:vlr-commandCancelled . callbackAbort) (:vlr-commandFailed . callbackAbort))))) (defun getRefeditSS( / elst en i len ss) (setq ss (ssget)) (if g_lastHandle (progn (setq i 0 len (sslength ss)) (setq elst nil) (while (< i len) (setq en (ssname ss i)) (setq elst (cons en elst)) (setq i (1+ i)) ) (foreach en elst (if (<= (cdr (assoc 5 (entget en))) g_lastHandle) (ssdel en ss) ) ) ) ) ss ) (defun c:foo() (print (sslength (getRefeditSS) )) (princ) ) ssget_refedit.lsp

Witam Nie znam jakiegoś prostego , oczywistego sposobu ograniczenia wyboru elementów w edytowanym bloku Proszę powiedzieć coś więcej. może przykład użycia ssget jaki Pan stosuje ? postaram się coś wymyślić albo dowiedzieć. Pozdarawiam

OK, teraz rozumiem. Przekazałem temat do ZWSOFT

Dzień dobry Staram się powtórzyć takie działanie programu, ale na ZWCAD+ 2015 i ZWCAD Classic przy domyślnych ustawieniach takie objawy nie powtórzyły się. Czy może Pan przesłać przykładowy plik, na którym można to sprawdzić? Być może jest to kwestia ustawień np wyrównanie tekstu, a może coś ze stylem tekstu. Jaka jest rola LISP w tym zagadnieniu? czy chodzi tylko o to, że LISPem odczytuje Pan punkt wstawienia tekstu? czy jest różnica kiedy mirror wykonywany jest przez polecenie ZWCADa? czy LISPem? Pozdrawiam

Dzisiaj otrzymałem informacje z pierwszej ręki. Poza tym co powyżej (siatka AutoCADowa , praca na platformach Max, Linux, Apple, Render ) w wersji 2017 ma być - Annotation Scale - Selection preview - Współpraca ze stylami STB Może nie wszystko uda się w pierwszej oficjalnej wersji, ale w wersji 2017 powinno być. Być może uda się opracować jeszcze coś więcej.

Użyłem tego sposobu bo z niego korzystam i sprawdza się. Skoro są inne nie zabraniam ich przedstawienia. Chce natomiast wskazać na to że jakoś to trzeba ogarnąć. Można użyć entsel i musieć pamiętać, że w przyszłości trzeba będzie tą wisienkę na tort położyć albo użyć Biblioteka:Entsel i mieć temat załatwiony. A w kwestii czytelności to właśnie o to chodzi że tylko w drugim przypadku trzeba prześledzić kod i na jego podstawie wyciągać wnioski. Korzystając z nazwanej funkcji można śledzić ten kod jeśli to właśnie jego dotyczy zmiana, którą chcemy wprowadzić, albo szukać innej części kodu, gdzie chcemy coś zmienić. Na początku powołałem się na Roberta C. Martina. Jakiś czas temu czytałem :http://helion.pl/ksiazki/agile-programowanie-zwinne-zasady-wzorce-i-praktyki-zwinnego-wytwarzania-oprogramowania-w-c-robert-c-martin-micah-martin,agile.htm I inne tego samego autora. Przykłady są akurat w C#, ale to zupełnie nieistotne koncepcje są uniwersalne. Ta lektura zmieniła moje spojrzenie na programowanie. Polecam każdemu kto zajmuje się, lub chciałby w przyszłości zajmować się programowaniem. Ważna kwestia jest taka, że pisząc kod musimy tak samo analizować HasArcSegment i (zerop (apply '+ (mapcar 'abs (cd:DXF_massoc 42 EntityList)))) Ale kod pisze się tylko raz, a czyta wiele razy. I właśnie wtedy jasne stają się korzyści z funkcji i z używania dobrze dobranych nazw funkcji. Wyobraźmy sobie funkcję na 300, 1000 linii kodu (sam takie pisałem i pisali takie też Ci od których się uczyłem). Trzeba w takim kodzie, dokonać prostej zmiany, możemy przeczytać i przeanalizować dużą część zanim znajdziemy to co potrzeba, jeśli tą samą funkcję podzielimy na kilka mniejszych, wyszukanie tej linijki kodu, którą trzeba zmienić trwa dużo krócej właśnie dlatego, że nie trzeba śledzić każdej linijki, a tylko te, które są bezpośrednio powiązane z celem zmiany. Oczywiście możemy przyjąć że znamy program i pamiętamy gdzie co jest i nie musimy czytać żeby znaleźć. Ja nie mam tak dobrej pamięci. Przyznaję, że jeśli muszę coś zmienić w kodzie który pisałem lata temu, muszę to analizować i często robi mi się przykro że wtedy nie pisałem tak jak teraz. Cały rozdział jest też poświęcony komentarzom w kodzie, polecam.

Dlaczego jeszcze za wcześnie na obsługę sytuacji wyjątkowych? Zaprezentowałem przykład, jeśli Iskra czy ktokolwiek zechce z niego skorzystać to zapraszam, jeśli nie zrozumie na bazie przykładu , chętnie wyjaśnię wszelkie wątpliwości. Chyba że to jakiś kurs z narzuconym harmonogramem, to w takim razie nie wcinam się więcej ;) Akurat w temacie obsługi spontaniczności Użytkowników pozostanę przy swoim radykalnym zawsze i absolutnie zachęcając do przyswojenia sobie tego nawyku jak najwcześniej przez opakowanie go w funkcję biblioteczną , oczywiście polecam CAD-Pack nie nawołuję do odkrywania koła na nowo, natomiast pozostawienie funkcji przekazujących działanie Użytkownikowi bez przechwycenia sytuacji niepożądanych kojarzy mi się ze strzelaniem z dowolnej broni z zamkniętymi oczami. Nie jest moim celem propagowanie funkcji lokalnych używam ich rzadko stawiając na biblioteki. Sama funkcja IsPolyline jest nieszczęśliwa wcale jej nie bronię. GetTypeObj jest znacznie lepsza. Ale już ocenę czytelności np HasArcSegment vs. (zerop (apply '+ (mapcar 'abs (cd:DXF_massoc 42 EntityList)))) i kolejnych pozostawmy tym, którzy to będą czytali. Jak każdy twórcy mam zbyt osobisty stosunek do swoich tworów by ocenić to obiektywnie. Budujemy prostą funkcję, OK. Jest już zrozumiała, również OK. Potrzebowaliśmy prostej informacji i ja otrzymaliśmy. Może właśnie teraz przejdźmy dalej wskazując jaki kierunek może mieć rozwój tej funkcji. Czy to już zbyt szybko czy nie również pozostawiam ocenie tych, którym okaże się to przydatne, lub nie.

No to żeby nie było że tak proste zadanie można rozwiązać tak szybko dodam jeszcze swoje uwagi: 1. Co się stanie jeśli Użytkownik zamiast posłusznie wskazać prostokąt naciśnie na klawiaturze [ESC]? Zawsze, ale to absolutnie zawsze jeśli pozwalamy Użytkownikowi zrobi cokolwiek należy użyć obsługi wyjątków vl-catch-all-apply 2. Będąc pod wpływem idei Roberta C. Martina dotyczącej czystości kodu chciałbym jeszcze zwrócić uwagę na czytelność kodu. - Dziś wiemy że DXF 70 pozwala sprawdzić czy polilinia jest zamknięta. ale czy będzie to dla nas jasne za kilka czy kilkanaście miesięcy, jeśli cały ten czas będziemy pracować w LISP to pewnie tak, ale być może kiedyś wrócimy do dawno zapomnianego kodu, który działał ale musimy w nim coś zmienić będziemy się zastanawiac "o co chodziło z tym 129". A może po kilku miesiącach musimy dodać obsługę okręgów. Nie wiem czy okrąg ma DXF 70 i jakie jest jego znaczenie , ale skoro jest okręgiem to na pewno jest zamknięty i nie ma potrzeby sprawdzanie tego warunku. Warto w takiej sytuacji mieć dokładnie jedno miejsce gdzie tego szukać. Dlatego sugeruję opakować każdy warunek funkcją. - być może w przyszłości to nie twórca programu a jego współpracownik, następca, pomocnik, uczeń czy ktokolwiek będzie czytał ten sam kod i będzie zastanawiał się czy funkcja "dia" ma porównywać długości przekątnych, czy jaka jest jej rola. Przeczyta i zrozumie, ale na ten czas odwróci swoją uwagę od czegoś co było ważniejsze bo miał zadanie sprawdzić/dodać cośtam co nie ma się nijak do przekątnych Dlatego lepiej jest nazywać funkcje i zmienne w taki sposób, żeby czytając jasne było co ma się dziać w kodzie. zainteresowany szczegółami implementacji może sobie znaleźć definicję funkcji i ją przeanalizować. 3. Rozumiem że dla uproszczenia przykładu można użyć (princ "\nŹle. "), ale przestrzegam przed używaniem takiego rozwiązania w kodzie produkcyjnym . Lepiej jest stałe tekstowe przechowywać gdzieś indziej, i tylko odwoływać się do nich w kodzie po symbolu. Wszytko jest OK, puki pracujemy na swoim komputerze, na znanej stabilnej wersji programu. Aż tu nagle niespodzianie pewnego dnia ktoś nam proponuje żeby uruchomić ten kod na innej maszynie, cieszy oczywiście że nasza praca jest przez kogoś doceniona, ale tylko do czasu kiedy zamiast "Wskaż prostokąt: " zobaczymy "WskaĹĽ prostokÄ…t: " poprostu niektóre systemy działają na Unicode, ale inne NIE. Oczywiście zawsze możemy zmienić każdy krzaczek na poprawną literkę, ale wtedy mamy już 2 wersje kodu do utrzymania i musimy o tym pamiętać przy każdej zmianie wprowadzonej do kodu. Być może pewnego dnia zechcemy nasz program udostępnić (być może za niewielką opłatą ;) ) komuś kto nie zna naszego języka, wówczas tłumaczymy 1 plik z tekstami a nie musimy wyszukiwać w kodzie wszystkich tekstów. Podobnie można przejechać się na formatowaniu daty, ale to już temat na inną pogadankę. Moja propozycja kodu źródłowego jest taka: (defun SelRect (/ select SelectedEntity IsRectangle e d dia OutVal) (defun IsRectangle (Entity / EntityList IsPolyline IsClosed DiagonalsAreEqual AreaIsCorrect NumberOfVertex ) (setq EntityList (entget Entity) ) (progn ; Locals (defun IsPolyline (Entity / ) (= (cdr (assoc 0 Entity)) "LWPOLYLINE") ) (defun IsClosed (EntityList / ) (= 1 (logand 1 (cdr (assoc 70 EntityList)))) ) (defun NumberOfVertex (EntityList / ) (cdr (assoc 90 EntityList)) ) (defun HasArcSegment (EntityList / ) (zerop (apply '+ (mapcar 'abs (cd:DXF_massoc 42 EntityList)))) ) (defun DiagonalsAreEqual (Entity / p ) (setq p (cd:DXF_massoc 10 Entity ) ) (if (and (not (zerop (distance (car p)(cadddr p)))) (equal (distance (car p)(caddr p)) (distance (cadr p)(cadddr p)) 0.001 ) ) ) ) (defun AreaIsCorrect (Entity / p ) (setq p (cd:DXF_massoc 10 Entity ) ) (equal (* (distance (car p)(cadr p))(distance (cadr p)(caddr p))) (vla-get-Area (vlax-ename->vla-object Entity)) 0.001 ) ) ) (if (and (IsPolyline EntityList) (IsClosed EntityList) (= (NumberOfVertex EntityList ) 4) (not (HasArcSegment EntityList)) (DiagonalsAreEqual Entity) (AreaIsCorrect Entity) ) ) ) (setq select (vl-catch-all-apply 'entsel (list "\nWskaż prostokąt: "))) ; przechwytuję błąd jeśli Użytkownik wciśnie [ESC] (if (not (vl-catch-all-error-p select)) ; sprawdzam czy wybór jest poprawny (progn (setq SelectedEntity (car select )) (if (IsRectangle SelectedEntity) (setq OutVal 'IsRectangle ) (setq OutVal 'NOTRectangle ) ) ) (setq OutVal 'NothingSelected ) ) OutVal ) Przepraszam jeśli nie działa, zmiany wprowadzałem w samym tekście bo przyznam że nie mam zainstalowanego CADPacka . Obiecuje że zainstaluje i sprawdzę kiedy będę miał trochę więcej czasu.

Witam Korzystając z samych odcinków prostych pomysł z łączeniem punktów w pary jest bardzo trafny, natomiast nie sprawdzi się w przypadku segmentów łukowych. Obiekty graficzne w CAD mają metodę: GetBoundingBox np: (vl-load-com) (setq util (vla-get-utility (vla-get-activedocument (vlax-get-acad-object)))) (vla-getentity util 'obj 'ip "\nSelect Object: ") (vla-GetBoundingBox obj 'minpoint 'maxpoint) (princ (vlax-safearray->list minpoint ) ) (terpri) (princ vlax-safearray->list maxpoint) Metoda GetBoundingBox przekazuje to zmiennych minpoint i maxpoint odpowiedni lewy dolny i prawy górny narożnik prostokąta obejmującego element Jest tylko jeden problem: GetBoundingBox wylicza prostokąt obejmujący w układzie globalnym więc zwykle uzyskany prostokąt nie będzie najmniejszym. Myślę, że jeśli mamy obracać układem współrzędnych równie dobrze możemy pokręcić samym mierzonym elementem, albo jego kopią. Może i uzyskany prostokąt nie będzie najmniejszy z możliwych, ale przyjmując jakąś rozsądną relację wydajności do dokładności możemy obracać np 90 razy co 1 stopień, lub 180 razy co 0.5 stopnia aż do uzyskania wystarczająco dokładnego efektu w akceptowalnie długim czasie wykonania. Pozdrawiam

Dla tej wersji aktualizacja automatyczna nie jest dostępna. Należy odinstalować posiadaną i zainstalować nową. Jeśli licencja jest zabezpieczona kodem programowym (bez klucza sprzętowego) proszę ją zwrócić przed odinstalowaniem programu i aktywować po instalacji nowej wersji. Ustawienia i aliasy powinny być zachowane, ale dla pewności może Pan wykonać Migrację ustawień niestandardowych. Aby to zrobić proszę zamknąć ZWCADA, kliknąć logo Windows->Programy->ZWSoft->ZWCAD+2015->Migracja ustawień niestandardowych, Export. Jeśli ustawienia nie zostaną zapamiętana proszę analogicznie wykonać import po przeinstalowaniu.

Gotowe. Proszę sprawdzić AreaCal V1.1ZWCAD.lsp

Witam Myślę że nie będzie z tym problemu. Jutro postaram się to dodać. Pozdrawiam.

Problem został rozwiązany. W liście warstw wyświetlają się tylko te, które są w aktywnym filtrze. Wersja w której to już działa dostępna jest do pobrania tutaj: wersja polska: http://jakicad.pl/pobierz/287/ZWCAD+_2015_SP3__2015_08_15__PL.exe wersja angielska http://jakicad.pl/pobierz/288/ZWCAD+_2015_SP3__2015_08_15__EN.exe

Dzień dobry - Wszystkie znaki na słupku połączone są w grupę. Można przełączyć zaznaczanie grupowe funkcją _PICKSTYLE, po ustawieniu jej na wartość 0 będzie możliwe zaznaczanie pojedynczych elementy i np usunięcie ich bez konieczności usuwania pozostałych. - Bibliotekę znaków można swobodnie rozbudowywać dodając nowe znaki do katalogu nakładki. Domyślnie jest to: C:\Szansa\ZWTraffic\2015\Templates\Vertical traffic signs\ Po dodaniu tam znaków będą one dostępne z poziomu nakładki. Oczywiście możemy też dodać je do aktualizacji by były dostępne dla wszystkich, proszę o informację których szablonów brakuje. - Tabliczki można tworzyć funkcją D_InfoTab (biała ikonka Info). Można tam określić wielkość i kolor tabliczki i wpisać dowolny tekst. - Kilka osób wskazywało już potrzebę dodania takiej funkcjonalności, natomiast jej opracowanie wymaga ustalenia pewnych szczegółów. Jeśli to nie kłopot poproszę o kontakt np na priv albo mailowo na pomoc@dobrycad.pl .

Witam. Jakiś czas temu Klient podsunął nam możliwość tworzenia zestawień długości elementów z rysunku korzystając a narzędzia LenCal autorstwa Lee McDonnell. Narzędzie jest bardzo przydatne w pracy kosztorysantów , tworzy zestawienie w postaci tabelki z elementów pogrupowanych według koloru czy warstwy. http://www.cadtutor.net/forum/showthread.php?42734-Line-Length-Calculator Na prośbę Klienta przerobiliśmy program na zliczający powierzchnie z kreskowań. Poniżej oba programy: LenCal: ;;;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;;; ;;;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;;; ;; ;; ;; ;; ;; --=={ Length Calculator }==-- ;; ;; ;; ;; This program will calculate the total length of user specified objects ;; ;; with an optional filter. The Filter may be used to select only those objects ;; ;; that are on a certain layer, or perhaps have a certain linetype or colour. ;; ;; ;; ;; The objects included in the calculation can be changed in the 'Options' ;; ;; dialog, along with the calculation precision and output type. ;; ;; ;; ;; The user can choose between three output options: ACAD Table, Txt file, or ;; ;; CSV file. If the output is set to ACAD Table, the user may select the ;; ;; Table-Style from the Drop-down in the main Dialog. ;; ;; ;; ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;; ;; ;; ;; FUNCTION SYNTAX: LenCal ;; ;; ;; ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;; ;; ;; ;; AUTHOR: ;; ;; ;; ;; Copyright © Lee McDonnell, June 2009. All Rights Reserved. ;; ;; ;; ;; { Contact: Lee Mac @ TheSwamp.org, CADTutor.net } ;; ;; ;; ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;; ;; ;; ;; VERSION: ;; ;; ;; ;; ř 1.0 ~¤~ 22nd June 2009 ~¤~ ş First Release ;; ;;...............................................................................;; ;; ř 1.1 ~¤~ 22nd June 2009 ~¤~ ;; ;;...............................................................................;; ;; ř 1.2 ~¤~ 23rd June 2009 ~¤~ ;; ;;...............................................................................;; ;; ř 1.3 ~¤~ 23rd June 2009 ~¤~ ş Fixed bugs. ;; ;;...............................................................................;; ;; ř 1.4 ~¤~ 10th December 2009 ~¤~ ş Fixed bugs. ;; ;;...............................................................................;; ;; ř 1.5 ~¤~ 21st December 2009 ~¤~ ş Updated Version Checking code. ;; ;;...............................................................................;; ;; ř 1.6 ~¤~ 22nd December 2009 ~¤~ ş Added option to choose objects ;; ;;...............................................................................;; ;; ř 1.7 ~¤~ 24th December 2009 ~¤~ ş Improved Options Dialog (with ;; ;; thanks to CAB for dialog bar). ;; ;; ş Added Precision Options ;; ;; ş Added alternative Output ;; ;; Options ;; ;;...............................................................................;; ;; ;; ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;; ;; ;; ;;;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;;; ;;;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;;; (defun c:LenCal (/ ;; --=={ Local Functions }==-- *error* AcCm-Color DCL_Write ErrChk Get_Tbl_Styl GetObjString List_Upd Obj_Settings Pad StrBrk ;; --=={ Local Variables }==-- BPT COL DCTAG DCTITLE DOC ELST ENT FILE FLST FNAME I LAYLST LAYSTR LENLST LEN_SUB LST LT OFILE OILST OLST OPTITLE OULST SLST SPC SS TBLOBJ TDEF TMP UFLAG WC Z ;; --=={ Global Variables }==-- ; *pop:def* ~ Popup_List Default ; *lst:def* ~ List_Box Default ; *tbl:stl* ~ Table Style Default ; *obj:set* ~ Object Settings Default [bit-coded] ; *len:pre* ~ Length Precision Setting ; *len:out* ~ Output Mode Setting ) (vl-load-com) (setq fname "LMAC_LenCal_V1.7.dcl" dcTitle "Length Calculator V1.7" opTitle "Options") (or *pop:def* (setq *pop:def* "0")) (or *lst:def* (setq *lst:def* "0")) (or *tbl:stl* (setq *tbl:stl* "0")) (or *obj:set* (setq *obj:set* 7 )) (or *len:pre* (setq *len:pre* (getvar "LUPREC"))) (or *len:out* (setq *len:out* "0")) ; 1 = Line ; 2 = Lw Polyline ; 4 = Polyline ; 8 = Arc ; 16 = Circle ; 32 = Spline ; 64 = Ellipse (defun *error* (msg) (and uFlag (vla-EndUndoMark doc)) (and dcTag (unload_dialog dcTag)) (and ofile (close ofile)) (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **"))) (princ)) (defun Pad (str chc len) (while (< (strlen Str) len) (setq str (strcat str (chr chc)))) str) (defun StrBrk (str chrc / pos lst) (while (setq pos (vl-string-position chrc str)) (setq lst (cons (substr str 1 pos) lst) str (substr str (+ pos 2)))) (reverse (cons str lst))) (defun Get_Tbl_Styl (/ tbl lst) (if (not (vl-catch-all-error-p (setq tbl (vl-catch-all-apply 'vla-item (list (vla-get-Dictionaries (cond (doc) ((vla-get-ActiveDocument (vlax-get-acad-object))))) "acad_tablestyle"))))) (vlax-for styl tbl (setq lst (cons (vla-get-name styl) lst)))) (reverse lst)) (defun errchk (lst / olst) (setq *pop:def* (get_tile "sel_fil") *tbl:stl* (get_tile "tbl_styl")) (if (not (eq "" (setq *lst:def* (get_tile "sel_sel")))) (progn (setq olst (mapcar (function (lambda (x) (nth x lst))) (mapcar 'atoi (strbrk *lst:def* 32)))) (done_dialog)) (progn (set_tile "error" "** Nothing Selected **") (setq olst nil))) olst) (defun list_upd (code / lst wc col ss) (setq doc (cond (doc) ((vla-get-ActiveDocument (vlax-get-acad-object))))) (cond ( (eq code 0) (vlax-for l (vla-get-layers doc) (setq lst (cons (vla-get-Name l) lst)))) ( (eq code 1) (vlax-for l (vla-get-linetypes doc) (setq lst (cons (vla-get-Name l) lst))) (setq lst (vl-remove-if (function (lambda (x) (vl-position (strcase x) '("BYLAYER" "BYBLOCK")))) lst))) ( (eq code 2) (vlax-for l (vla-get-layers doc) (if (not (vl-position (setq col (vla-get-color l)) lst)) (setq lst (cons col lst)))) (if (setq ss (ssget "_X" '((-4 . "<NOT") (-4 . "<OR") (62 . 256) (62 . 0) (-4 . "OR>") (-4 . "NOT>")))) (foreach x (mapcar (function (lambda (x) (cdr (assoc 62 (entget x))))) (mapcar 'cadr (ssnamex ss))) (if (not (or (null x) (vl-position x lst))) (setq lst (cons x lst))))) (setq lst (vl-remove-if (function (lambda (x) (vl-position (strcase x) '("BYLAYER" "BYBLOCK")))) (mapcar 'itoa lst))))) (if (not (eq "" (setq wc (get_tile "wc_str")))) (progn (setq lst (vl-remove-if-not (function (lambda (x) (wcmatch x wc))) lst)) (and (not lst) (setq lst '("-- No Matches --"))))) (start_list "sel_sel") (mapcar 'add_list (setq lst (acad_strlsort lst))) (end_list) lst) (defun AcCm-Color (/ acVer ac) (setq acVer (substr (getvar "ACADVER") 1 2)) (if (not (vl-catch-all-error-p (setq ac (vl-catch-all-apply 'vla-GetInterfaceObject (list *acad (strcat "AutoCAD.AcCmColor." acVer)))))) ac nil)) (defun dcl_write (fname / pat path ofile) (if (not (findfile fname)) (if (setq pat (findfile "ACAD.PAT")) (progn (setq path (vl-filename-directory pat)) (or (eq "\\" (substr path (strlen path))) (setq path (strcat path "\\"))) (setq ofile (open (strcat path fname) "w")) (foreach str '("//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;//" "//;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;//" "// //" "// --=={ Length Calculator }==-- //" "// //" "// LenCal.dcl for use in conjunction with LenCal.lsp //" "// Copyright © June 2009, by Lee McDonnell (Lee Mac) //" "// //" "//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;//" "//;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;//" "" "// Sub-Assembly Definitions" "" "butt12 : button { width = 12; fixed_width = true; alignment = centered; }" "pop15 : popup_list { width = 15; fixed_width = true; alignment = centered; }" "tog : toggle { alignment = centered; fixed_width = false; }" "bar : image { width = 33.26; height = 0.74; color = -15; alignment = centered; }" "" "// Main Dialog" "" "lencal : dialog { key = \"dctitle\";" " : text { value = \"Copyright (c) 2009 Lee McDonnell\"; alignment = right; }" " " " : boxed_column { label = \"Filter\"; fixed_width = true; width = 45;" " : popup_list { key = \"sel_fil\";alignment = centered; }" " spacer_1; " " }" " " " : boxed_column { label = \"Selection\";" " : list_box { key = \"sel_sel\"; multiple_select = true; alignment = centered; }" " : edit_box { key = \"wc_str\" ; label = \"Filter String:\"; edit_limit = 50;" " value = \"*\"; alignment = centered; }" " spacer_1; " " }" " " " : boxed_column { label = \"Table Style\";" " : popup_list { key = \"tbl_styl\"; alignment = centered; }" " spacer_1; " " }" " " " : errtile { width = 34; }" " : row {" " : butt12 { key = \"opt\"; label = \"Options\"; }" " : butt12 { key = \"accept\"; label = \"OK\"; is_default = true; }" " : butt12 { key = \"cancel\"; label = \"Cancel\"; is_cancel = true; }" " }" "}" "" "" "lencal_opt : dialog { key = \"stitle\";" " spacer;" " : row { alignment = centered; " " spacer;" " : column { alignment = centered;" " : tog { key = \"li\"; label = \"Line\"; }" " : tog { key = \"pl\"; label = \"Polyline\"; }" " }" "" " : column { alignment = centered;" " : tog { key = \"el\"; label = \"Ellipse\";}" " : tog { key = \"ar\"; label = \"Arc\"; }" " }" "" " : column { alignment = centered;" " : tog { key = \"lw\"; label = \"LW Polyline\"; }" " : tog { key = \"ci\"; label = \"Circle\"; }" " }" "" " : column { alignment = centered;" " : tog { key = \"sp\"; label = \"Spline\"; }" " : tog { key = \"al\"; label = \"Select All\"; }" " }" " }" " : row {" " : spacer { width = 0.1; fixed_width = true; }" " : bar { key = \"sep1\"; }" " : spacer { width = 0.1; fixed_width = true; }" " }" "" " : row { alignment = centered; children_alignment = centered;" "" " spacer;" " : column { " " : spacer { height = 0.1; fixed_height = true; }" " : text { label = \"Precision:\"; }" " }" " : pop15 { key = \"prec\"; }" "" " spacer;" "" " : column {" " : spacer { height = 0.1; fixed_height = true; }" " : text { label = \"Output:\"; }" " }" " : pop15 { key = \"outp\"; }" " spacer;" "" " }" "" " spacer;" " : row {" " : spacer { width = 0.1; fixed_width = true; }" " : bar { key = \"sep2\"; }" " : spacer { width = 0.1; fixed_width = true; }" " }" "" " ok_cancel;" "}" "" "/*" "//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;" "" " End of Program Code" "" "//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;" "*/") (write-line str ofile)) (setq ofile (close ofile)) t) nil) t)) (defun GetObjString (code / n x str) (setq n -1 str "") (foreach x '("LINE" "LWPOLYLINE" "POLYLINE" "ARC" "CIRCLE" "SPLINE" "ELLIPSE") (if (not (zerop (logand code (expt 2 (setq n (1+ n)))))) (setq str (strcat str x (chr 44))))) (vl-string-right-trim "," str)) (defun Obj_Settings (dcTag / Set_tiles Tile_Bit tmp) (defun Set_tiles (code / n x) (setq n -1) (foreach x '("li" "lw" "pl" "ar" "ci" "sp" "el") (if (not (zerop (logand code (expt 2 (setq n (1+ n)))))) (set_tile x "1") (set_tile x "0")))) (defun Tile_Bit (key value) (* (if (eq value "0") (progn (set_tile "al" "0") -1) 1) (expt 2 (vl-position key '("li" "lw" "pl" "ar" "ci" "sp" "el"))))) (cond ( (not (new_dialog "lencal_opt" dcTag)) (princ "\n** Options Dialog Could not be Loaded **")) (t (set_tile "stitle" opTitle) (foreach x '("sep1" "sep2") (start_image x) (mapcar (function vector_image) '(0 0) '(6 5) '(300 300) '(6 5) '(8 7)) (end_image)) (Set_tiles *obj:set*) (setq tmp *obj:set*) ;; For Cancel (start_list "prec") (mapcar 'add_list '("0" "0.0" "0.00" "0.000" "0.0000" "0.00000" "0.000000" "0.0000000" "0.00000000")) (end_list) (set_tile "prec" (itoa *len:pre*)) (start_list "outp") (mapcar 'add_list '("ACAD Table" "TXT File" "CSV File")) (end_list) (set_tile "outp" *len:out*) (action_tile "prec" "(setq *len:pre* (atoi $value))") (action_tile "outp" "(setq *len:out* $value)") (action_tile "li" "(setq tmp (+ tmp (Tile_Bit \"li\" $value)))") (action_tile "lw" "(setq tmp (+ tmp (Tile_Bit \"lw\" $value)))") (action_tile "pl" "(setq tmp (+ tmp (Tile_Bit \"pl\" $value)))") (action_tile "ar" "(setq tmp (+ tmp (Tile_Bit \"ar\" $value)))") (action_tile "ci" "(setq tmp (+ tmp (Tile_Bit \"ci\" $value)))") (action_tile "sp" "(setq tmp (+ tmp (Tile_Bit \"sp\" $value)))") (action_tile "el" "(setq tmp (+ tmp (Tile_Bit \"el\" $value)))") (action_tile "al" "(if (eq \"1\" $value) (progn (setq tmp 127) (Set_Tiles tmp)))") (action_tile "accept" (vl-prin1-to-string (quote (progn (cond ( (zerop tmp) (alert "Please Select at Least One Object")) (t (setq *obj:set* tmp) (done_dialog))))))) (action_tile "cancel" "(done_dialog)") (start_dialog)))) ;; --=={ Main Function }==-- (setq laystr "") (setq doc (vla-get-ActiveDocument (setq *acad (vlax-get-Acad-Object))) 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))) (cond ( (not (>= (distof (substr (getvar "ACADVER") 1 4)) 16.1)) ;; ACAD 2005 (princ "\n** Table Object Not Available in this Version **")) ( (eq 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar "CLAYER")))))) (princ "\n** Current Layer Locked **")) ( (not (dcl_write fname)) (princ "\n** DCL File Could not be Written **")) ( (<= (setq dcTag (load_dialog fname)) 0) (princ "\n** Error Loading DCL **")) ( (not (new_dialog "lencal" dcTag)) (princ "** Error Loading Length Calculator Dialog **")) ( (not (setq sLst (get_tbl_styl))) (princ "\n** Error Loading TableStyles **")) (t (start_list "tbl_styl") (mapcar 'add_list (setq sLst (acad_strlsort sLst))) (end_list) (setq fLst '("Layer" "Linetype" "Colour")) (start_list "sel_fil") (mapcar 'add_list fLst) (end_list) (set_tile "dctitle" dcTitle) (set_tile "sel_fil" *pop:def*) (set_tile "sel_sel" *lst:def*) (set_tile "tbl_styl" *tbl:stl*) (setq lst (list_upd (atoi *pop:def*))) (if (eq "0" *len:out*) (mode_tile "tbl_styl" 0) (mode_tile "tbl_styl" 1)) (action_tile "sel_fil" (vl-prin1-to-string (quote (progn (setq lst (list_upd (atoi $value))) (set_tile "error" "") (setq *lst:def* (set_tile "sel_sel" "0")))))) (action_tile "wc_str" (vl-prin1-to-string (quote (progn (setq lst (list_upd (atoi (get_tile "sel_fil")))))))) (action_tile "opt" (vl-prin1-to-string (quote (progn (Obj_Settings dcTag) (if (eq "0" *len:out*) (mode_tile "tbl_styl" 0) (mode_tile "tbl_styl" 1)))))) (action_tile "accept" "(setq olst (errchk lst))") (action_tile "cancel" "(done_dialog)") (start_dialog) (setq dcTag (unload_dialog dcTag)) ;; --=={ Alternative Pre-DCL Selection Method }==-- ;| (while (progn (initget 128 "Select List All Done") (setq lt (getkword "\nSpecify Linetype to List [Select/List/All] <Done>: ")) (cond ((not lt) nil) ; Enter ((eq "Done" lt) nil) ((eq "Select" lt) (if (setq ent (car (nentsel "\nSelect Object: "))) (progn (setq lt (strcase (vla-get-linetype (setq Obj (vlax-ename->vla-object ent))))) (cond ((eq lt "BYLAYER") (if (vl-catch-all-error-p (vl-catch-all-apply (function (lambda ( ) (setq lt (strcase (vla-get-linetype (vla-item (vla-get-Layers doc) (vla-get-layer Obj))))))))) (princ "\n<< Error Retrieving Linetype >>") (if ltlst (if (vl-position lt ltlst) (princ (strcat "\n<< " lt " Linetype Already Listed >>")) (progn (setq ltlst (cons lt ltlst)) (princ (strcat "\n<< " lt " Linetype Added to List >>")))) (progn (setq ltlst (cons lt ltlst)) (princ (strcat "\n<< " lt " Linetype Added to List >>")))))) (t (if ltlst (if (vl-position lt ltlst) (princ (strcat "\n<< " lt " Linetype Already Listed >>")) (progn (setq ltlst (cons lt ltlst)) (princ (strcat "\n<< " lt " Linetype Added to List >>")))) (progn (setq ltlst (cons lt ltlst)) (princ (strcat "\n<< " lt " Linetype Added to List >>"))))))) t)) ; Stay in Loop ((eq "List" lt) (if ltlst (progn (foreach lt ltlst (princ (strcat "\n" (Pad lt 46 30)))) (textscr) t) ; Stay in Loop (princ "\n<< No List Created >>"))) ((eq "All" lt) (setq ltlst nil) (while (setq l (tblnext "LTYPE" (not l))) (setq ltlst (cons (cdr (assoc 2 l)) ltlst))) nil) ; Exit Loop ((and (snvalid lt) (tblsearch "LTYPE" lt)) (setq ltlst (cons (strcase lt) ltlst))) (t (princ "\n<< Linetype not Found in Drawing >>"))))) |; ;; --===============================================================-- (if (and olst (not (vl-position "-- No Matches --" olst))) (progn (cond ( (eq "0" *pop:def*) ;; Layer Filtering (foreach lay olst (if (setq z -1 len_sub 0. ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*)) (cons 8 lay)))) (progn (while (setq ent (ssname ss (setq z (1+ z)))) (setq len_sub (+ len_sub (vlax-curve-getDistatParam ent (vlax-curve-getEndParam ent))))) (setq lenlst (cons (list lay len_sub) lenlst))) (princ (strcat "\n** No Objects Found on Layer: " lay " **"))))) ( (eq "1" *pop:def*) ;; Linetype Filtering (foreach lt (setq oulst (mapcar (function strcase) olst)) (while (setq tdef (tblnext "LAYER" (not tdef))) (if (eq lt (strcase (cdr (assoc 6 tdef)))) (setq laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr) laylst (cons (cdr (assoc 2 tdef)) laylst)))) (setq laystr (vl-string-right-trim (chr 44) laystr)) (if (setq ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*)) (cons -4 "<OR") (cons 6 lt) (cons 8 laystr) (cons -4 "OR>")))) (progn (setq Elst (vl-remove-if (function (lambda (x / l) (and (vl-position (cdr (assoc 8 (entget x))) laylst) (setq l (cdr (assoc 6 (entget x)))) (not (eq (strcase l) lt))))) (mapcar 'cadr (ssnamex ss)))) (setq lenlst (cons (list lt (apply (function +) (mapcar (function (lambda (x) (vlax-curve-getDistatParam x (vlax-curve-getEndParam x)))) Elst))) lenlst))) (princ (strcat "\n** No Objects Found With Linetype " lt " **"))) (setq tdef nil laystr "" laylst nil ss nil))) ( (eq "2" *pop:def*) ;; Colour Filtering (foreach col (setq oilst (mapcar 'atoi olst)) (while (setq tdef (tblnext "LAYER" (not tdef))) (if (eq col (cdr (assoc 62 tdef))) (setq laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr) laylst (cons (cdr (assoc 2 tdef)) laylst)))) (setq laystr (vl-string-right-trim (chr 44) laystr)) (if (setq ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*)) (cons -4 "<OR") (cons 62 col) (cons 8 laystr) (cons -4 "OR>")))) (progn (setq Elst (vl-remove-if (function (lambda (x / c) (and (vl-position (cdr (assoc 8 (entget x))) laylst) (setq c (cdr (assoc 62 (entget x)))) (not (eq c col))))) (mapcar 'cadr (ssnamex ss)))) (setq lenlst (cons (list (itoa col) (apply (function +) (mapcar (function (lambda (x) (vlax-curve-getDistatParam x (vlax-curve-getEndParam x)))) Elst))) lenlst))) (princ (strcat "\n** No Objects Found With Colour " (itoa col) " **"))) (setq tdef nil laystr "" laylst nil)))) (if lenlst (cond ( (and (eq "0" *len:out*) (setq bPt (getpoint "\nSelect Point for Table: "))) (setq uflag (not (vla-StartUndoMark doc)) i 2) (setq tblObj (vla-addTable spc (vlax-3D-point bPt) (+ 2 (length lenlst)) 2 (* 1.5 (getvar "DIMTXT")) (* (apply 'max (mapcar 'strlen (append (list (strcat (nth (atoi *pop:def*) fLst) " Name")) (apply 'append (mapcar (function (lambda (x) (list (car x) (rtos (cadr x) 2 *len:pre*)))) lenlst))))) 1.5 (getvar "DIMTXT")))) ;;; (if (setq ac (AcCm-Color)) ;;; (progn ;;; (vla-setRGB ac 76 153 76) ;;; (vla-put-TrueColor tblObj ac))) (vla-put-StyleName tblObj (nth (atoi *tbl:stl*) sLst)) (vla-setText tblObj 0 0 "Length Calculation") (vla-setText tblObj 1 0 (strcat (nth (atoi *pop:def*) fLst) " Name")) (vla-setText tblObj 1 1 "Length") (foreach x (reverse lenlst) (vla-setText tblObj i 0 (car x)) (vla-setText tblObj i 1 (rtos (cadr x) 2 *len:pre*)) (setq i (1+ i))) (setq uflag (vla-EndUndoMark doc))) ( (and (eq "1" *len:out*) (setq file (getfiled "Select Output File" "" "txt" 9))) (setq ofile (open file "a")) (write-line "\nLength Calculation" ofile) (write-line (strcat (Pad (strcat "\n" (nth (atoi *pop:def*) fLst) " Name") 32 31) "Length\n") ofile) (mapcar (function (lambda (x) (write-line (strcat (Pad (car x) 32 30) (rtos (cadr x) 2 *len:pre*)) ofile))) (reverse lenlst)) (setq ofile (close ofile))) ( (and (eq "2" *len:out*) (setq file (getfiled "Select Output File" "" "csv" 9))) (setq ofile (open file "a")) (write-line "Length Calculation" ofile) (write-line (strcat (nth (atoi *pop:def*) fLst) " Name,Length") ofile) (mapcar (function (lambda (x) (write-line (strcat (car x) (chr 44) (rtos (cadr x) 2 *len:pre*)) ofile))) (reverse lenlst)) (setq ofile (close ofile)))))) (princ "\n*Cancel*")))) (princ)) (princ "\nř¤ş°`°ş¤ř LenCal.lsp ~ Copyright © by Lee McDonnell ř¤ş°`°ş¤ř") (princ "\n ~¤~ ...Type \"LenCal\" to Invoke... ~¤~ ") (princ) ;;;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;;; ;; ;; ;; End of Program Code ;; ;; ;; ;;;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;;; AreaCal: ;;;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;;; ;;;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;;; ;; ;; ;; ;; ;; --=={ Area Calculator }==-- ;; ;; ;; ;; This program will calculate the total area of user specified objects ;; ;; with an optional filter. The Filter may be used to select only those objects ;; ;; that are on a certain layer, or perhaps have a certain linetype or colour. ;; ;; ;; ;; The objects included in the calculation can be changed in the 'Options' ;; ;; dialog, along with the calculation precision and output type. ;; ;; ;; ;; The user can choose between three output options: ACAD Table, Txt file, or ;; ;; CSV file. If the output is set to ACAD Table, the user may select the ;; ;; Table-Style from the Drop-down in the main Dialog. ;; ;; ;; ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;; ;; ;; ;; FUNCTION SYNTAX: AreaCal ;; ;; ;; ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;; ;; ;; ;; AUTHOR: ;; ;; ;; ;; Copyright © Lee McDonnell, June 2009. All Rights Reserved. ;; ;; ;; ;; { Contact: Lee Mac @ TheSwamp.org, CADTutor.net } ;; ;; ;; ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;; ;; ;; ;; VERSION: ;; ;; ;; ;; ř 1.0 ~¤~ 22nd June 2009 ~¤~ ş First Release ;; ;;...............................................................................;; ;; ř 1.1 ~¤~ 22nd June 2009 ~¤~ ;; ;;...............................................................................;; ;; ř 1.2 ~¤~ 23rd June 2009 ~¤~ ;; ;;...............................................................................;; ;; ř 1.3 ~¤~ 23rd June 2009 ~¤~ ş Fixed bugs. ;; ;;...............................................................................;; ;; ř 1.4 ~¤~ 10th December 2009 ~¤~ ş Fixed bugs. ;; ;;...............................................................................;; ;; ř 1.5 ~¤~ 21st December 2009 ~¤~ ş Updated Version Checking code. ;; ;;...............................................................................;; ;; ř 1.6 ~¤~ 22nd December 2009 ~¤~ ş Added option to choose objects ;; ;;...............................................................................;; ;; ř 1.7 ~¤~ 24th December 2009 ~¤~ ş Improved Options Dialog (with ;; ;; thanks to CAB for dialog bar). ;; ;; ş Added Precision Options ;; ;; ş Added alternative Output ;; ;; Options ;; ;;...............................................................................;; ;; ;; ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;; ;; ;; ;;;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;;; ;;;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;;; (defun c:AreaCal (/ ;; --=={ Local Functions }==-- *error* AcCm-Color DCL_Write ErrChk Get_Tbl_Styl GetObjString List_Upd Obj_Settings Pad StrBrk ;; --=={ Local Variables }==-- BPT COL DCTAG DCTITLE DOC ELST ENT FILE FLST FNAME I LAYLST LENLST LEN_SUB LST LT OFILE OILST OLST OPTITLE OULST SLST SPC SS TBLOBJ TDEF TMP UFLAG WC Z ;; --=={ Global Variables }==-- ; *pop:def* ~ Popup_List Default ; *lst:def* ~ List_Box Default ; *tbl:stl* ~ Table Style Default ; *obj:set* ~ Object Settings Default [bit-coded] ; *len:pre* ~ Length Precision Setting ; *len:out* ~ Output Mode Setting ) (vl-load-com) (setq fname "AreaCal_V1.0.dcl" dcTitle "Area Calculator V1.0" opTitle "Options") (defun GetFilterList ( / ) (list "Layer" "Hatch Pattern" "Colour") ) (or *pop:def* (setq *pop:def* "0")) (or *lst:def* (setq *lst:def* "0")) (or *tbl:stl* (setq *tbl:stl* "0")) (or *obj:set* (setq *obj:set* 7 )) (or *len:pre* (setq *len:pre* (getvar "LUPREC"))) (or *len:out* (setq *len:out* "0")) ; 1 = Line ; 2 = Lw Polyline ; 4 = Polyline ; 8 = Arc ; 16 = Circle ; 32 = Spline ; 64 = Ellipse (defun *error* (msg) (and uFlag (vla-EndUndoMark doc)) (and dcTag (unload_dialog dcTag)) (and ofile (close ofile)) (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **"))) (princ)) (defun Pad (str chc len) (while (< (strlen Str) len) (setq str (strcat str (chr chc)))) str) (defun StrBrk (str chrc / pos lst) (while (setq pos (vl-string-position chrc str)) (setq lst (cons (substr str 1 pos) lst) str (substr str (+ pos 2)))) (reverse (cons str lst))) (defun Get_Tbl_Styl (/ tbl lst) (if (not (vl-catch-all-error-p (setq tbl (vl-catch-all-apply 'vla-item (list (vla-get-Dictionaries (cond (doc) ((vla-get-ActiveDocument (vlax-get-acad-object))))) "acad_tablestyle"))))) (vlax-for styl tbl (setq lst (cons (vla-get-name styl) lst)))) (reverse lst)) (defun errchk (lst / olst) (setq *pop:def* (get_tile "sel_fil") *tbl:stl* (get_tile "tbl_styl")) (if (not (eq "" (setq *lst:def* (get_tile "sel_sel")))) (progn (setq olst (mapcar (function (lambda (x) (nth x lst))) (mapcar 'atoi (strbrk *lst:def* 32)))) (done_dialog)) (progn (set_tile "error" "** Nothing Selected **") (setq olst nil))) olst) (defun Hatch:GetUsedPatterns ( / hatches i hatch hatchObj pattern patterns) (setq hatches (ssget "_X" (list (cons 0 "HATCH") ) ) ) (setq i 0 ) (repeat (sslength hatches) (setq hatch (ssname hatches i)) (setq hatchObj (vlax-ename->vla-object hatch )) (setq pattern (vlax-get-property hatchObj 'PatternName ) ) (if (not (member pattern patterns) ) (setq patterns (append patterns (list pattern ) ) ) ) (setq i (1+ i ) ) ) patterns ) (defun list_upd (code / lst wc col ss) (setq doc (cond (doc) ((vla-get-ActiveDocument (vlax-get-acad-object))))) (cond ( (eq code 0) ; ByLayer Selected (vlax-for l (vla-get-layers doc) (setq lst (cons (vla-get-Name l) lst)))) ( (eq code 1) ; ByHatchPattern Selected (setq lst (Hatch:GetUsedPatterns )) ) ( (eq code 2) ; ByColor selected (vlax-for l (vla-get-layers doc) (if (not (vl-position (setq col (vla-get-color l)) lst)) (setq lst (cons col lst)))) (if (setq ss (ssget "_X" '((-4 . "<NOT") (-4 . "<OR") (62 . 256) (62 . 0) (-4 . "OR>") (-4 . "NOT>")))) (foreach x (mapcar (function (lambda (x) (cdr (assoc 62 (entget x))))) (mapcar 'cadr (ssnamex ss))) (if (not (or (null x) (vl-position x lst))) (setq lst (cons x lst))))) (setq lst (vl-remove-if (function (lambda (x) (vl-position (strcase x) '("BYLAYER" "BYBLOCK")))) (mapcar 'itoa lst))))) (if (not (eq "" (setq wc (get_tile "wc_str")))) (progn (setq lst (vl-remove-if-not (function (lambda (x) (wcmatch x wc))) lst)) (and (not lst) (setq lst '("-- No Matches --"))))) (start_list "sel_sel") (mapcar 'add_list (setq lst (acad_strlsort lst))) (end_list) lst) (defun AcCm-Color (/ acVer ac) (setq acVer (substr (getvar "ACADVER") 1 2)) (if (not (vl-catch-all-error-p (setq ac (vl-catch-all-apply 'vla-GetInterfaceObject (list *acad (strcat "AutoCAD.AcCmColor." acVer)))))) ac nil)) (defun dcl_write (fname / pat path ofile) (if (not (findfile fname)) (if (setq pat (findfile "ZWCAD.PAT")) (progn (setq path (vl-filename-directory pat)) (or (eq "\\" (substr path (strlen path))) (setq path (strcat path "\\"))) (setq ofile (open (strcat path fname) "w")) (foreach str '("//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;//" "//;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;//" "// //" "// --=={ Area Calculator }==-- //" "// //" "// AreaCal.dcl for use in conjunction with AreaCal.lsp //" "// Copyright © June 2009, by Lee McDonnell (Lee Mac) //" "// //" "//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;//" "//;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;//" "" "// Sub-Assembly Definitions" "" "butt12 : button { width = 12; fixed_width = true; alignment = centered; }" "pop15 : popup_list { width = 15; fixed_width = true; alignment = centered; }" "tog : toggle { alignment = centered; fixed_width = false; }" "bar : image { width = 33.26; height = 0.74; color = -15; alignment = centered; }" "" "// Main Dialog" "" "areacal : dialog { key = \"dctitle\";" " : text { value = \"Copyright (c) 2009 Lee McDonnell\"; alignment = right; }" " " " : boxed_column { label = \"Filter\"; fixed_width = true; width = 45;" " : popup_list { key = \"sel_fil\";alignment = centered; }" " spacer_1; " " }" " " " : boxed_column { label = \"Selection\";" " : list_box { key = \"sel_sel\"; multiple_select = true; alignment = centered; }" " : edit_box { key = \"wc_str\" ; label = \"Filter String:\"; edit_limit = 50;" " value = \"*\"; alignment = centered; }" " spacer_1; " " }" " " " : boxed_column { label = \"Table Style\";" " : popup_list { key = \"tbl_styl\"; alignment = centered; }" " spacer_1; " " }" " " " : errtile { width = 34; }" " : row {" " : butt12 { key = \"opt\"; label = \"Options\"; }" " : butt12 { key = \"accept\"; label = \"OK\"; is_default = true; }" " : butt12 { key = \"cancel\"; label = \"Cancel\"; is_cancel = true; }" " }" "}" "" "" "areacal_opt : dialog { key = \"stitle\";" " spacer;" " : row { alignment = centered; " " spacer;" " : column { alignment = centered;" " : tog { key = \"ha\"; label = \"Hatch\"; }" ; " : tog { key = \"pl\"; label = \"Polyline\"; }" " }" "" ; " : column { alignment = centered;" ; " : tog { key = \"el\"; label = \"Ellipse\";}" ; " : tog { key = \"ar\"; label = \"Arc\"; }" ; " }" ; "" ; " : column { alignment = centered;" ; " : tog { key = \"lw\"; label = \"LW Polyline\"; }" ; " : tog { key = \"ci\"; label = \"Circle\"; }" ; " }" ; "" ; " : column { alignment = centered;" ; " : tog { key = \"sp\"; label = \"Spline\"; }" ; " : tog { key = \"al\"; label = \"Select All\"; }" ; " }" " }" " : row {" " : spacer { width = 0.1; fixed_width = true; }" " : bar { key = \"sep1\"; }" " : spacer { width = 0.1; fixed_width = true; }" " }" "" " : row { alignment = centered; children_alignment = centered;" "" " spacer;" " : column { " " : spacer { height = 0.1; fixed_height = true; }" " : text { label = \"Precision:\"; }" " }" " : pop15 { key = \"prec\"; }" "" " spacer;" "" " : column {" " : spacer { height = 0.1; fixed_height = true; }" " : text { label = \"Output:\"; }" " }" " : pop15 { key = \"outp\"; }" " spacer;" "" " }" "" " spacer;" " : row {" " : spacer { width = 0.1; fixed_width = true; }" " : bar { key = \"sep2\"; }" " : spacer { width = 0.1; fixed_width = true; }" " }" "" " ok_cancel;" "}" "" "/*" "//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;" "" " End of Program Code" "" "//;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;" "*/") (write-line str ofile)) (setq ofile (close ofile)) t) nil) t)) (defun GetObjString (code / n x str) (setq n -1 str "") ; (foreach x '("LINE" "LWPOLYLINE" "POLYLINE" "ARC" "CIRCLE" "SPLINE" "ELLIPSE") (foreach x '("HATCH" ) ; w przyszłości może jeszcze region (if (not (zerop (logand code (expt 2 (setq n (1+ n)))))) (setq str (strcat str x (chr 44))))) (vl-string-right-trim "," str) ) (defun DCL:FillList (id values / ) (start_list id ) (mapcar 'add_list values) (end_list) ) (defun Obj_Settings (dcTag / Set_tiles Tile_Bit tmp) (defun Set_tiles (code / n x) (setq n -1) ;(foreach x '("li" "lw" "pl" "ar" "ci" "sp" "el") (foreach x '("ha") (if (not (zerop (logand code (expt 2 (setq n (1+ n)))))) (set_tile x "1") (set_tile x "0") ) ) ) (defun Tile_Bit (key value) (* (if (eq value "0") (progn (set_tile "al" "0") -1) 1) ; (expt 2 (vl-position key '("li" "lw" "pl" "ar" "ci" "sp" "el"))))) (expt 2 (vl-position key '("ha")))) ) (cond ( (not (new_dialog "areacal_opt" dcTag)) (princ "\n** Options Dialog Could not be Loaded **")) (t (set_tile "stitle" opTitle) (foreach x '("sep1" "sep2") (start_image x) (mapcar (function vector_image) '(0 0) '(6 5) '(300 300) '(6 5) '(8 7)) (end_image)) (Set_tiles *obj:set*) (setq tmp *obj:set*) ;; For Cancel ( DCL:FillList "prec" (list "0" "0.0" "0.00" "0.000" "0.0000" "0.00000" "0.000000" "0.0000000" "0.00000000") ) (set_tile "prec" (itoa *len:pre*)) ( DCL:FillList "outp" (list "ACAD Table" "TXT File" "CSV File" ) ) (set_tile "outp" *len:out*) (action_tile "prec" "(setq *len:pre* (atoi $value))") (action_tile "outp" "(setq *len:out* $value)") (action_tile "ha" "(setq tmp (+ tmp (Tile_Bit \"ha\" $value)))") ; (action_tile "li" "(setq tmp (+ tmp (Tile_Bit \"li\" $value)))") ; (action_tile "lw" "(setq tmp (+ tmp (Tile_Bit \"lw\" $value)))") ; (action_tile "pl" "(setq tmp (+ tmp (Tile_Bit \"pl\" $value)))") ; (action_tile "ar" "(setq tmp (+ tmp (Tile_Bit \"ar\" $value)))") ; (action_tile "ci" "(setq tmp (+ tmp (Tile_Bit \"ci\" $value)))") ; (action_tile "sp" "(setq tmp (+ tmp (Tile_Bit \"sp\" $value)))") ; (action_tile "el" "(setq tmp (+ tmp (Tile_Bit \"el\" $value)))") (action_tile "al" "(if (eq \"1\" $value) (progn (setq tmp 127) (Set_Tiles tmp)))") (action_tile "accept" (vl-prin1-to-string (quote (progn (cond ( (zerop tmp) (alert "Please Select at Least One Object")) (t (setq *obj:set* tmp) (done_dialog))))))) (action_tile "cancel" "(done_dialog)") (start_dialog))) ) ;; --=={ Main Function }==-- (defun GetActiveDoc ( / ) (vla-get-ActiveDocument(setq *acad (vlax-get-Acad-Object))) ) (defun GetActiveSpace ( / doc ) (setq doc (GetActiveDoc) ) (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)) ) (defun ByLayerSelected ( / ) (eq "0" *pop:def*) ) (defun ByLinetypeSelected ( / ) (eq "1" *pop:def*) ) (defun ByColorSelected ( / ) (eq "2" *pop:def*) ) (defun SelectByLayer (olst / lay z len_sub ss ent lenlst) (foreach lay olst (if (setq z -1 len_sub 0. ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*)) (cons 8 lay) )) ) (progn (while (setq ent (ssname ss (setq z (1+ z)))) (setq len_sub (+ len_sub (vlax-get-property (vlax-ename->vla-object ent ) 'Area ))) ) (setq lenlst (cons (list lay len_sub) lenlst)) ) (princ (strcat "\n** No Objects Found on Layer: " lay " **")) ) ) lenlst ) (defun SelectByLinetype (olst / lt oulst tdef ssc Elst lenlst ) ; (setq olst (list "Continuous" )) (foreach lt (setq laystr "" ) (setq oulst (mapcar (function strcase) olst)) (while (setq tdef (tblnext "LAYER" (not tdef))) (if (eq lt (strcase (cdr (assoc 6 tdef)))) (setq laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr) laylst (cons (cdr (assoc 2 tdef)) laylst)) ) ) (setq laystr (vl-string-right-trim (chr 44) laystr)) (if (setq ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*)) (cons -4 "<OR") (cons 6 lt) (cons 8 laystr) (cons -4 "OR>")))) (progn (setq Elst (vl-remove-if (function (lambda (x / l) (and (vl-position (cdr (assoc 8 (entget x))) laylst) (setq l (cdr (assoc 6 (entget x)))) (not (eq (strcase l) lt))))) (mapcar 'cadr (ssnamex ss)))) (setq lenlst (ReadAreas Elst lt)) (princ (strcat "\n** No Objects Found With Linetype " lt " **")) ) (setq tdef nil laylst nil ss nil) ) ) lenlst ) (defun SelectByColor (olst / Elst x c ss tdef col lenlst ) ; (setq olst (list "140" "102" "37" ) ) ; (setq col (car oilst )) ; (setq laystr "" ) (setq oilst (mapcar 'atoi olst)) (foreach col oilst (setq laystr "") (while (setq tdef (tblnext "LAYER" (not tdef))) (if (eq col (cdr (assoc 62 tdef))) (setq laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr) laylst (cons (cdr (assoc 2 tdef)) laylst)) ) ) (setq laystr (vl-string-right-trim (chr 44) laystr)) (if (setq ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*)) (cons -4 "<OR") (cons 62 col) (cons 8 laystr) (cons -4 "OR>")))) (progn (setq Elst (vl-remove-if (function (lambda (x / c) (and (vl-position (cdr (assoc 8 (entget x))) laylst) (setq c (cdr (assoc 62 (entget x)))) (not (eq c col))))) (mapcar 'cadr (ssnamex ss)) ) ) (setq lenlst (append lenlst (ReadAreas Elst (itoa col)))) ) (princ (strcat "\n** No Objects Found With Colour " (itoa col) " **")) ) (setq tdef nil laylst nil) ) lenlst ) (defun SelectByHatchPattern (olst / lt oulst ss arealst ) (foreach hp olst (if (setq ss (ssget "_X" (list (cons 0 (GetObjString *obj:set*)) (cons 2 hp) ))) (progn (setq z -1 len_sub 0. ) (while (setq ent (ssname ss (setq z (1+ z)))) (setq len_sub (+ len_sub (vlax-get-property (vlax-ename->vla-object ent ) 'Area ))) ) (setq arealst (cons (list hp len_sub) arealst)) ) (princ (strcat "\n** No Objects Found With HatchPattern " hp " **")) ) (setq ss nil) ) arealst ) (defun ReadAreas (Elst param / lenlst x ) (setq lenlst (cons (list param (apply (function +) (mapcar (function (lambda (x) (vlax-get-property (vlax-ename->vla-object x ) 'Area ) ) ) Elst ) ) ) lenlst ) ) lenlst ) (setq doc (GetActiveDoc) spc (GetActiveSpace) ) (defun SaveAsTable (lenlst insertionPoint tbsStyle header / doc spc uflag tblObj i ) ; (setq lenlst (SelectByLayer (list "Kafelki" "Panele podłogowe" "Patio" "Wykładzina" )) insertionPoint (list 0 0 0 )) (setq doc (GetActiveDoc) spc (GetActiveSpace) ) (defun CalColumnWidth (lenlst header / ) (* (apply 'max (mapcar 'strlen (append (list header ) (apply 'append (mapcar (function (lambda (x) (list (car x) (rtos (cadr x) 2 *len:pre*)))) lenlst)))) ) 1.5 (getvar "DIMTXT") ) ) (setq uflag (not (vla-StartUndoMark doc)) i 2) (setq tblObj (vla-addTable spc (vlax-3D-point insertionPoint) (+ 2 (length lenlst)) 2 (* 1.5 (getvar "DIMTXT")) (CalColumnWidth lenlst header) )) (vla-put-StyleName tblObj tbsStyle) (vla-setText tblObj 0 0 "Area Calculation") (vla-setText tblObj 1 0 header) (vla-setText tblObj 1 1 "Area") (foreach x (reverse lenlst) (vla-setText tblObj i 0 (car x)) (vla-setText tblObj i 1 (rtos (cadr x) 2 *len:pre*)) (setq i (1+ i))) (setq uflag (vla-EndUndoMark doc)) ) (cond ( (not (>= (distof (substr (getvar "ACADVER") 1 4)) 16.1)) ;; ACAD 2005 (princ "\n** Table Object Not Available in this Version **")) ( (eq 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar "CLAYER")))))) (princ "\n** Current Layer Locked **")) ( (not (dcl_write fname)) (princ "\n** DCL File Could not be Written **")) ( (<= (setq dcTag (load_dialog fname)) 0) (princ "\n** Error Loading DCL **")) ( (not (new_dialog "areacal" dcTag)) (princ "** Error Loading Area Calculator Dialog **")) ( (not (setq sLst (get_tbl_styl))) (princ "\n** Error Loading TableStyles **")) (t (DCL:FillList "tbl_styl" (setq sLst (acad_strlsort sLst)) ) (DCL:FillList "sel_fil" (GetFilterList) ) (set_tile "dctitle" dcTitle) (set_tile "sel_fil" *pop:def*) (set_tile "sel_sel" *lst:def*) (set_tile "tbl_styl" *tbl:stl*) (setq lst (list_upd (atoi *pop:def*))) (if (eq "0" *len:out*) (mode_tile "tbl_styl" 0) (mode_tile "tbl_styl" 1)) (action_tile "sel_fil" (vl-prin1-to-string (quote (progn (setq lst (list_upd (atoi $value))) (set_tile "error" "") (setq *lst:def* (set_tile "sel_sel" "0")))))) (action_tile "wc_str" (vl-prin1-to-string (quote (progn (setq lst (list_upd (atoi (get_tile "sel_fil")))))))) (action_tile "opt" (vl-prin1-to-string (quote (progn (Obj_Settings dcTag) (if (eq "0" *len:out*) (mode_tile "tbl_styl" 0) (mode_tile "tbl_styl" 1)))))) (action_tile "accept" "(setq olst (errchk lst))") (action_tile "cancel" "(done_dialog)") (start_dialog) (setq dcTag (unload_dialog dcTag)) ;; --=={ Alternative Pre-DCL Selection Method }==-- ;| (while (progn (initget 128 "Select List All Done") (setq lt (getkword "\nSpecify Linetype to List [Select/List/All] <Done>: ")) (cond ((not lt) nil) ; Enter ((eq "Done" lt) nil) ((eq "Select" lt) (if (setq ent (car (nentsel "\nSelect Object: "))) (progn (setq lt (strcase (vla-get-linetype (setq Obj (vlax-ename->vla-object ent))))) (cond ((eq lt "BYLAYER") (if (vl-catch-all-error-p (vl-catch-all-apply (function (lambda ( ) (setq lt (strcase (vla-get-linetype (vla-item (vla-get-Layers doc) (vla-get-layer Obj))))))))) (princ "\n<< Error Retrieving Linetype >>") (if ltlst (if (vl-position lt ltlst) (princ (strcat "\n<< " lt " Linetype Already Listed >>")) (progn (setq ltlst (cons lt ltlst)) (princ (strcat "\n<< " lt " Linetype Added to List >>")))) (progn (setq ltlst (cons lt ltlst)) (princ (strcat "\n<< " lt " Linetype Added to List >>")))))) (t (if ltlst (if (vl-position lt ltlst) (princ (strcat "\n<< " lt " Linetype Already Listed >>")) (progn (setq ltlst (cons lt ltlst)) (princ (strcat "\n<< " lt " Linetype Added to List >>")))) (progn (setq ltlst (cons lt ltlst)) (princ (strcat "\n<< " lt " Linetype Added to List >>"))))))) t)) ; Stay in Loop ((eq "List" lt) (if ltlst (progn (foreach lt ltlst (princ (strcat "\n" (Pad lt 46 30)))) (textscr) t) ; Stay in Loop (princ "\n<< No List Created >>"))) ((eq "All" lt) (setq ltlst nil) (while (setq l (tblnext "LTYPE" (not l))) (setq ltlst (cons (cdr (assoc 2 l)) ltlst))) nil) ; Exit Loop ((and (snvalid lt) (tblsearch "LTYPE" lt)) (setq ltlst (cons (strcase lt) ltlst))) (t (princ "\n<< Linetype not Found in Drawing >>")) ) ) ) |; ;; --===============================================================-- (if (and olst (not (vl-position "-- No Matches --" olst))) (progn (cond ( (ByLayerSelected) (setq lenlst(SelectByLayer olst )) ) ( (ByLinetypeSelected) (setq lenlst (SelectByHatchPattern olst )) ) ( (ByColorSelected) (setq lenlst (SelectByColor olst )) ) ) (if lenlst (cond ( (and (eq "0" *len:out*) (setq bPt (getpoint "\nSelect Point for Table: "))) (setq tableStyle (nth (atoi *tbl:stl*) sLst) header (strcat (nth (atoi *pop:def*) (GetFilterList)) " Name") ) ( SaveAsTable lenlst bPt tableStyle header ) ) ( (and (eq "1" *len:out*) (setq file (getfiled "Select Output File" "" "txt" 9))) (setq ofile (open file "a")) (write-line "\nArea Calculation" ofile) (write-line (strcat (Pad (strcat "\n" (nth (atoi *pop:def*) fLst) " Name") 32 31) "Area\n") ofile) (mapcar (function (lambda (x) (write-line (strcat (Pad (car x) 32 30) (rtos (cadr x) 2 *len:pre*)) ofile))) (reverse lenlst)) (setq ofile (close ofile)) ) ( (and (eq "2" *len:out*) (setq file (getfiled "Select Output File" "" "csv" 9))) (setq ofile (open file "a")) (write-line "Area Calculation" ofile) (write-line (strcat (nth (atoi *pop:def*) fLst) " Name,Area") ofile) (mapcar (function (lambda (x) (write-line (strcat (car x) (chr 44) (rtos (cadr x) 2 *len:pre*)) ofile))) (reverse lenlst)) (setq ofile (close ofile)))))) (princ "\n*Cancel*")))) (princ) ) (princ "\nř¤ş°`°ş¤ř AreaCal.lsp ~ Copyright © by Lee McDonnell ř¤ş°`°ş¤ř") (princ "\n ~¤~ ...Type \"AreaCal\" to Invoke... ~¤~ ") (princ) ;;;¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,;;; ;; ;; ;; End of Program Code ;; ;; ;; ;;;ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,ř¤ş°`°ş¤ř,¸¸,¤ş°`°ş¤;;; LenCal V1.7ZWCAD.lsp AreaCal V1.0ZWCAD.lsp

Czy może Pan przesłać do mnie mailem pliki przed zapisem i wynikowy DXF? mój adres to pomoc@dobrycad.pl