;;; ======================================================================================= ;;;
;;; CADPL-Pack-v1.lsp                                                                       ;;;
;;; [2013-04-07]                                                                            ;;;
;;; ======================================================================================= ;;;

; [ACX] ===================================================================================== ;
; cd:ACX_AddArc           - Tworzy obiekt typu ARC / Creates a ARC object                     ;
; cd:ACX_AddCircle        - Tworzy obiekt typu CIRCLE / Creates a CIRCLE object               ;
; cd:ACX_AddLayer         - Tworzy nowa warstwe / Creates a new layers                        ;
; cd:ACX_AddLine          - Tworzy obiekt typu LINE / Creates a LINE object                   ;
; cd:ACX_AddLWPolyline    - Tworzy obiekt typu LWPOLYLINE / Creates a LWPOLYLINE object       ;
; cd:ACX_AddTable         - Tworzy obiekt typu ACAD_TABLE / Creates a ACAD_TABLE object       ;
; cd:ACX_AddMText         - Tworzy obiekt typu MTEXT / Creates a MTEXT object                 ;
; cd:ACX_AddText          - Tworzy obiekt typu TEXT / Creates a TEXT object                   ;
; cd:ACX_AddTextStyle     - Tworzy nowy stylu tekstu / Creates a new text style               ;
; cd:ACX_AddXline         - Tworzy obiekt typu XLINE / Creates a XLINE object                 ;
; cd:ACX_ADoc             - Aktywny dokument / Active document                                ;
; cd:ACX_ASpace           - Aktywny obszar / Active space                                     ;
; cd:ACX_Blocks           - Kolekcja Blocks / Blocks collection                               ;
; cd:ACX_GetProp          - Pobiera cechy obiektu / Gets the object properties                ;
; cd:ACX_Layers           - Kolekcja Layers / Layers collection                               ;
; cd:ACX_Layouts          - Kolekcja Layouts / Layouts collection                             ;
; cd:ACX_LineTypes        - Kolekcja LineTypes / LineTypes collection                         ;
; cd:ACX_LoadLineType     - Laduje definicje linii z pliku LIN / Loads linetype from LIN file ;
; cd:ACX_Model            - Obszar modelu / Model space                                       ;
; cd:ACX_Paper            - Obszar papieru / Paper space                                      ;
; cd:ACX_SetProp          - Zmienia cechy obiektu VLA / Sets the property of VLA-Object       ;
; cd:ACX_TextStyles       - Kolekcja TextStyles / TextStyles collection                       ;
;                                                                                             ;
; [BLK] ===================================================================================== ;
; cd:BLK_GetAttEntity     - Zwraca liste atrybutow bloku / Returns a list of attributes block ;
; cd:BLK_GetAtts          - Pobiera wartosci atrybutow / Gets the values of all attributes    ;
; cd:BLK_GetAttsVLA       - Pobiera wartosci atrybutow / Gets the values of all attributes    ;
; cd:BLK_GetAttValueVLA   - Pobiera wartosc atrybutu / Gets the attribute value               ;
; cd:BLK_GetDynBlockNames - Lista nazw blokow (*U) zaleznych od bloku dynamicznego /          ;
;                           List of the blocks name (*U) which depends on a dynamic block     ;
; cd:BLK_GetDynamicProps  - Pobiera wlasciwosci bloku dyn. / Gets the dyn. block properties   ;
; cd:BLK_GetEntity        - Lista obiektow w definicji bloku / List of objects in block def.  ;
; cd:BLK_GetXrefs         - Lista odnosnikow zewnetrznych / List of external references       ;
; cd:BLK_InsertBlock      - Wstawia blok / Inserts a block                                    ;
; cd:BLK_IsDynamicInsert  - Sprawdza czy blok dynamiczny / Checks if the dynamic block        ;
; cd:BLK_SetAttValueVLA   - Zmienia wartosc atrybutu / Sets the attribute value               ;
; cd:BLK_SetDynamicProps  - Zmienia wlasciwosci bloku dyn. / Sets the dyn. block properties   ;
;                                                                                             ;
; [CAL] ===================================================================================== ;
; cd:CAL_BitList          - Lista bitow liczby calkowitej / List of bits integer              ;
; cd:CAL_Sequence         - Tworzy ciag arytmetyczny / Creates arithmetic sequence            ;
;                                                                                             ;
; [CON] ===================================================================================== ;
; cd:CON_All2Str          - Zmiana elem. listy na lancuchy / Convert list elem. onto strings  ;
; cd:CON_ObjConv          - Konwertuje obiekt / Convert object                                ;
; cd:CON_List2Value       - Zmiana listy na lancuch tekstowy / Convert list onto text string  ;
; cd:CON_Real2Str         - Konwertuje liczbe na tekst / Converts number to a string          ;
; cd:CON_TransMatrix      - Macierz transformacji ukl. wsp. / The coor. transformation matrix ;
; cd:CON_Value2List       - Zmiana lancucha tekstow. na liste / Convert string into list elem.;
; cd:CON_XYZ2Variant      - Lista liczb na 3DPoint / List of numbers to 3DPoint               ;
;                                                                                             ;
; [DCL] ===================================================================================== ;
; cd:DCL_ChangeColorList  - Obsluga listy kolorow / Handling of list colors                   ;
; cd:DCL_ChangeStringList - Obsluga listy tekstow / Handling of list strings                  ;
; cd:DCL_FillColorList    - Wypelnia "popup_list" kolorami / Fills "popup_list" with colors   ;
; cd:DCL_FillColorImage   - Wypelnia wycinek "image" kolorem / Fills "image" tile with color  ;
; cd:DCL_FillStringList   - Wypelnia "popup_list" tekstami / Fills "popup_list" with strings  ;
; cd:DCL_ImgBtnSortIcon   - Image_button - ikona sortowania / Image_button - sort icon        ;
; cd:DCL_MsgBox           - DCL-owe okno komunikatu / DCL message box                         ;
; cd:DCL_SetList          - Wypelnia wycinki / Fills tiles                                    ;
; cd:DCL_StdEditBoxDialog - Okno dialogowe z "edit_box" / Dialog control with "edit_box"      ;
; cd:DCL_StdListDialog    - Okno dialogowe z "list_box" / Dialog control with "list_box"      ;
;                                                                                             ;
; [DCT] ===================================================================================== ;
; cd:DCT_AddDict          - Dodaje slownik / Adds the dictionary                              ;
; cd:DCT_AddXrecord       - Dodaje Xrecord / Adds the Xrecord                                 ;
; cd:DCT_GetDict          - Pobiera slownik / Gets a dictionary                               ;
; cd:DCT_GetDictList      - Pobiera liste slownikow / Gets a list of dictionaries             ;
; cd:DCT_GetExtDict       - Pobiera/Tworzy ExtensionDict. / Gets/Creates an ExtensionDict.    ;
; cd:DCT_GetExtDictVLA    - Pobiera/Tworzy ExtensionDict. / Gets/Creates an ExtensionDict.    ;
; cd:DCT_GetXrecord       - Pobiera Xrecord / Gets Xrecord                                    ;
; cd:DCT_RemoveDict       - Usuwa slownik / Removes the dictionary                            ;
; cd:DCT_ReplaceXrecord   - Podmienia Xrecord / Replace Xrecord                               ;
; cd:DCT_SetXrecordVLA    - Zmienia Xrecord / Change Xrecord                                  ;
;                                                                                             ;
; [DWG] ===================================================================================== ;
; cd:DWG_AddCustomProp    - Dodaje wlasciwosci uzytkownika / Add custom drawing properties    ;
; cd:DWG_GetCustomProp    - Lista wlasciwosci uzytkownika / Custom drawing properties         ;
; cd:DWG_GetOpenDocs      - Lista otwartych dokumentow / Open documents list                  ;
; cd:DWG_GetSummaryInfo   - Lista wlasciwosci dokumentu / Summary drawing properties list     ;
; cd:DWG_Layout2VLA       - Zmiana nazwy arkusza na ob. VLA / Convert layout name to VLA-Ob.  ;
; cd:DWG_LayoutsList      - Lista arkuszy rysunku / Layouts drawing list                      ;
; cd:DWG_RemoveCustomProp - Usuwa wlasciwosci uzytkownika / Removes custom drawing properties ;
; cd:DWG_SetSummaryInfo   - Zmiana wlasciwosci dokumentu / Set summary drawing properties     ;
;                                                                                             ;
; [DXF] ===================================================================================== ;
; cd:DXF_Massoc           - Zwraca wartosc danego klucza z listy asocjacyjnej /               ;
;                           Returns the value of a key from assoc list                        ;
; cd:DXF_RemoveDXF        - Usuwa kody z listy DXF / Removes codes from the list of DXF       ;
;                                                                                             ;
; [ENT] ===================================================================================== ;
; cd:ENT_CheckTableObj    - Poprawnosc nazwanego obiektu / Correctness of the named object    ;
; cd:ENT_MakeArc          - Tworzy obiekt typu ARC / Creates a ARC object                     ;
; cd:ENT_MakeBlockEnd     - Tworzy koniec definicji bloku / Creates a block definition end    ;
; cd:ENT_MakeBlockHead    - Tworzy poczatek definicji bloku / Creates a block definition head ;
; cd:ENT_MakeCircle       - Tworzy obiekt typu CIRCLE / Creates a CIRCLE object               ;
; cd:ENT_MakeEllipse      - Tworzy obiekt typu ELLIPSE / Creates a ELLIPSE object             ;
; cd:ENT_MakeLayer        - Tworzy nowa warstwe / Creates a new layers                        ;
; cd:ENT_MakeLine         - Tworzy obiekt typu LINE / Make LINE object                        ;
; cd:ENT_MakeLWPolyline   - Tworzy obiekt typu LWPOLYLINE / Creates a LWPOLYLINE object       ;
; cd:ENT_MakeTable        - Tworzy obiekt typu ACAD_TABLE / Creates a ACAD_TABLE object       ;
; cd:ENT_MakeText         - Tworzy obiekt typu TEXT / Creates a TEXT object                   ;
; cd:ENT_MakeTextStyle    - Tworzy nowy stylu tekstu / Creates a new text style               ;
; cd:ENT_MakeXline        - Tworzy obiekt typu XLINE / Creates a XLINE object                 ;
; cd:ENT_SetBasicDXF      - Zmiana podstawowych cech obiektu / Set basic object properties    ;
; cd:ENT_SetDXF           - Zmiana danych DXF obiektu / Set DXF data of object                ;
;                                                                                             ;
; [LST] ===================================================================================== ;
; cd:LST_InsertItem       - Wstawia nowy element na liste / Inserts a new item in the list    ;
; cd:LST_ItemPosition     - Lista wystapien elementu / List of occurrences item in the list   ;
; cd:LST_MoveItemDown     - Przesuwa element o jedna pozyc. w dol / Moves item one pos. down  ;
; cd:LST_MoveItemToBottom - Przesuwa element na ostatnia pozyc. / Moves item to the last pos. ;
; cd:LST_MoveItemToTop    - Przesuwa element na pozycje 0 / Moves item to the 0th position    ;
; cd:LST_MoveItemUp       - Przesuwa element o jedna pozyc. w gore / Moves item one pos. up   ;
; cd:LST_RemoveItem       - Usuwa element z listy / Removes the item from the list            ;
; cd:LST_ReplaceItem      - Zastepuje element na liscie / Replaces the item on the list       ;
; cd:LST_ReverseItems     - Zamienia elementy miejscami / Reverse the elements in places      ;
;                                                                                             ;
; [SSX] ===================================================================================== ;
; cd:SSX_Convert          - Zmienia PICKSET na liste obiek. / Convert PICKSET to list of obj. ;
;                                                                                             ;
; [STR] ===================================================================================== ;
; cd:STR_CountChar        - Liczba wystapien znaku / Number of occurrences of a character     ;
; cd:STR_FillChar         - Uzupelnia lancuch tekstowy / Complements the text string          ;
; cd:STR_Parse            - Dzieli lancuch separatorem / Divide string by separator           ;
; cd:STR_ReParse          - Laczy liste lancuchow w lancuch z separatorem /                   ;
;                           Combines a list of strings in the string with the separator       ;
; cd:STR_TableNameAuto    - Tworzy automatyczna nazwe / Creates automatic name                ;
;                                                                                             ;
; [SYS] ===================================================================================== ;
; cd:SYS_AcadInfo         - AcadInfo np. ("AutoCAD" 18.0 64 "PL")                             ;
; cd:SYS_CheckError       - Sprawdza dzialanie funkcji / Checks proper operation of the func. ;
; cd:SYS_CollList         - Zwraca liste obiektow / Returns a list of objects                 ;
; cd:SYS_FilesLoader      - Wczytuje pliki lsp,fas,vlx / Loads files lsp,fas,vlx              ;
; cd:SYS_FontPaths        - Lista sciezek do czcionek / List of paths to the fonts            ;
; cd:SYS_GetDateTime      - Zwraca date/czas systemowa(y) / Return system date/time           ;
; cd:SYS_GetSymbols       - Lista symboli LISP-a / LISPs symbols list                         ;
; cd:SYS_Msgbox           - Standardowe okno komunikatu / Standard message box                ;
; cd:SYS_ReadFile         - Czyta plik tekstowy / Read a text file                            ;
; cd:SYS_RW               - Odczyt/Zapis danych w rejest. / Reads/Writes data to the registry ;
; cd:SYS_UndoBegin        - Poczatek grupy operacji / Start of group operations               ;
; cd:SYS_UndoEnd          - Koniec grupy operacji / End of group operations                   ;
; cd:SYS_WriteFile        - Zapisuje plik tekstowy / Writes the text file                     ;
;                                                                                             ;
; [USR] ===================================================================================== ;
; cd:USR_EntSelObj        - Wybiera zadane obiekty / Select a desired object                  ;
; cd:USR_GetKeyWord       - Pobranie slowa kluczowego od uzyt. / Get a keyword from the user  ;
; cd:USR_GetPoint         - Pobiera punkt od uzytkownika / Gets point from user               ;
;                                                                                             ;
; [XDT] ===================================================================================== ;
; cd:XDT_GetXData         - Czyta dane dodatkowe XDATA / Reads additional data XDATA          ;
; cd:XDT_PutXData         - Dodaje dane dodatkowe XDATA / Adds additional data XDATA          ;
; cd:XDT_RemoveXData      - Usuwa dane dodatkowe XDATA / Removes additional data XDATA        ;
;                                                                                             ;
; =========================================================================================== ;

; =========================================================================================== ;
(vl-load-com)
; =========================================================================================== ;

; =========================================================================================== ;
; Aktywny dokument / Active document                                                          ;
; =========================================================================================== ;
(defun cd:ACX_ADoc ()
  (or
    *cd-ActiveDocument*
    (setq *cd-ActiveDocument*
      (vla-get-ActiveDocument (vlax-get-acad-object))
    )
  )
  *cd-ActiveDocument*
)
; =========================================================================================== ;
; Tworzy obiekt typu ARC / Creates a ARC object                                               ;
;  Space  [VLA-Object] - kolekcja / collection | Model/Paper + Block Object                   ;
;  Pc     [LIST]  - srodek luku / center of the arc                                           ;
;  Radius [REAL]  - promien / radius                                                          ;
;  As     [REAL]  - kat poczatkowy w radianach / start angle in radians                       ;
;  Ae     [REAL]  - kat koncowy w radianach / end angle in radians                            ;
;  ActUcs [T/nil] - dopasuj do aktywnego ucs / adjust to active ucs                           ;
;                   nil = nie / no                                                            ;
;                   T   = tak / yes                                                           ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_AddArc (cd:ACX_ASpace) '(1 5 0) 5 0 pi T)                                           ;
; =========================================================================================== ;
(defun cd:ACX_AddArc (Space Pc Radius As Ae ActUcs / zdir xang obj)
  (setq zdir (trans '(0 0 1) 1 0 T)
        xang (angle '(0 0 0) (trans (getvar "UCSXDIR") 0 zdir))
  )
  (setq obj
    (vla-AddArc Space
      (vlax-3d-point (trans Pc 1 0))
      Radius
      (+ As xang)
      (+ Ae xang)
    )
  )
  (if
    (not ActUcs)
    (vla-put-normal obj (vlax-3d-point '(0 0 1)))
  )
  obj
)
; =========================================================================================== ;
; Tworzy obiekt typu CIRCLE / Creates a CIRCLE object                                         ;
;  Space  [VLA-Object]  - kolekcja / collection | Model/Paper + Block Object                  ;
;  Pc     [LIST]  - srodek okregu / center of the circle                                      ;
;  Radius [REAL]  - promien / radius                                                          ;
;  ActUcs [T/nil] - dopasuj do aktywnego ucs / adjust to active ucs                           ;
;                   nil = nie / no                                                            ;
;                   T   = tak / yes                                                           ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_AddCircle (cd:ACX_ASpace) '(1 5 0) 5 T)                                             ;
; =========================================================================================== ;
(defun cd:ACX_AddCircle (Space Pc Radius ActUcs / obj)
  (setq obj
    (vla-AddCircle
      Space
      (vlax-3d-point (trans Pc 1 0))
      Radius
    )
  )
  (if (not ActUcs)
    (vla-put-normal obj (vlax-3d-point '(0 0 1)))
  )
  obj
)
; =========================================================================================== ;
; Tworzy nowa warstwe / Creates a new layers                                                  ;
;  Name [STR] - nazwa warstwy / layer name                                                    ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_AddLayer "ABC")                                                                     ;
; =========================================================================================== ;
(defun cd:ACX_AddLayer (Name)
  (if (tblobjname "LAYER" Name)
    (vla-item (cd:ACX_Layers) Name)
    (if (snvalid Name 0)
      (vla-add (cd:ACX_Layers) Name)
    )
  )
)
; =========================================================================================== ;
; Tworzy obiekt typu LINE / Creates a LINE object                                             ;
;  Space  [VLA-Object] - kolekcja / collection | Model/Paper + Block Object                   ;
;  Ps     [LIST]  - punkt poczatkowy / start point                                            ;
;  Pe     [LIST]  - punkt koncowy / end point                                                 ;
;  ActUcs [T/nil] - dopasuj do aktywnego ucs / adjust to active ucs                           ;
;                   nil = nie / no                                                            ;
;                   T   = tak / yes                                                           ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_AddLine (cd:ACX_ASpace) '(20 10 0) '(100 50 0) T)                                   ;
; =========================================================================================== ;
(defun cd:ACX_AddLine (Space Ps Pe ActUcs / obj)
  (setq obj
    (vla-AddLine Space
      (vlax-3d-point (trans Ps 1 0))
      (vlax-3d-point (trans Pe 1 0))
    )
  )
  (if (not ActUcs)
    (vla-put-normal obj (vlax-3d-point '(0 0 1)))
  )
  obj
)
; =========================================================================================== ;
; Tworzy obiekt typu LWPOLYLINE / Creates a LWPOLYLINE object                                 ;
;  Space  [VLA-Object] - kolekcja / collection | Model/Paper + Block Object                   ;
;  Pts    [LIST]  - lista wierzcholkow polilinii / list of polyline vertex                    ;
;  Closed [T/nil] - nil = otwarta / open                                                      ;
;                   T   = zamknieta / closed                                                  ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_AddLWPolyline (cd:ACX_ASpace) (list '(5 5) '(15 5) '(15 10) '(10 10)) nil)          ;
; =========================================================================================== ;
(defun cd:ACX_AddLWPolyline (Space Pts Closed / obj)
  (setq Pts
    (apply
      (quote append)
      (mapcar
        (function
          (lambda (%)
            (list (car %) (cadr %))
          )
        )
        (mapcar
          (function
            (lambda (%)
              (trans % 1 (trans '(0 0 1) 1 0 T))
            )
          )
          Pts
        )
      )
    )
  )
  (setq obj
    (vla-AddLightweightPolyline Space
      (vlax-make-variant
        (vlax-safearray-fill
          (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length Pts))))
          Pts
        )
      )
    )
  )
  (if Closed (vla-put-closed obj Closed))
  obj
)
; =========================================================================================== ;
; Tworzy obiekt typu MTEXT / Creates a MTEXT object                                           ;
;  Space [VLA-Object] - kolekcja / collection | Model/Paper + Block Object                    ;
;  Str   [STR]  - lancuch tekstowy / string                                                   ;
;  Pb    [LIST] - punkt bazowy / base point                                                   ;
;  Width [REAL] - szerokosc tekstu / width text                                               ;
;  Rot   [REAL] - kat obrotu w radianach / rotation angle in radians                          ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_AddMText (cd:ACX_ASpace) "NEW_MTEXT" (getpoint) 1.5 (/ pi 4))                       ;
; =========================================================================================== ;
(defun cd:ACX_AddMText (Space Str Pb Width Rot / obj)
  (vla-put-rotation
    (setq obj
      (vla-AddMText Space
      (vlax-3d-point (trans Pb 1 0))
        Width
        Str      
      )
    )
    Rot
  )
  obj
)
; =========================================================================================== ;
; Tworzy obiekt typu ACAD_TABLE / Creates a ACAD_TABLE object                                 ;
;  Space [VLA-Object]  - kolekcja / collection | Model/Paper + Block Object                   ;
;  Pb    [LIST] - punkt bazowy tabeli / table base point                                      ;
;  Rows  [INT]  - liczba wierszy / number of rows                                             ;
;  Cols  [INT]  - liczba kolumn / number of columns                                           ;
;  RowH  [INT]  - wysokosc wierszy / rows height                                              ;
;  ColH  [INT]  - szerokosc kolumn / columns height                                           ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_AddTable (cd:ACX_ASpace) (getpoint) 5 5 10 30)                                      ;
; =========================================================================================== ;
(defun cd:ACX_AddTable (Space Pb Rows Cols RowH ColH)
  (vla-AddTable
     Space
     (vlax-3d-point (trans Pb 1 0))
     Rows
     Cols
     RowH
     ColH
  )
)
; =========================================================================================== ;
; Tworzy obiekt typu TEXT / Creates a TEXT object                                             ;
;  Space  [VLA-Object] - kolekcja / collection | Model/Paper + Block Object                   ;
;  Str    [STR]  - lancuch tekstowy / string                                                  ;
;  Pb     [LIST] - punkt bazowy / base point                                                  ;
;  Height [REAL] - wysokosc / height                                                          ;
;  Rot    [REAL] - kat obrotu w radianach / rotation angle in radians                         ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_AddText (cd:ACX_ASpace) "NEW_TEXT" (getpoint) 1.5 (/ pi 4))                         ;
; =========================================================================================== ;
(defun cd:ACX_AddText (Space Str Pb Height Rot / zdir xang obj)
  (setq zdir (trans '(0 0 1) 1 0 T)
        xang (angle '(0 0 0) (trans (getvar "UCSXDIR") 0 zdir))
  )
  (vla-put-rotation
    (setq obj
      (vla-AddText Space
        Str
        (vlax-3d-point (trans Pb 1 0))
        Height
      )
    )
    (+ Rot xang)
  )
  obj
)
; =========================================================================================== ;
; Tworzy nowy stylu tekstu / Creates a new text style                                         ;
;  Name [STR] - nazwa stylu tekstu / text style name                                          ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_AddTextStyle "ABC")                                                                 ;
; =========================================================================================== ;
(defun cd:ACX_AddTextStyle (Name)
  (if (tblobjname "STYLE" Name)
    (vla-item (cd:ACX_TextStyles) Name)
    (if (snvalid Name 0)
      (vla-add (cd:ACX_TextStyles) Name)
    )
  )
)
; =========================================================================================== ;
; Tworzy obiekt typu XLINE / Creates a XLINE object                                           ;
;  Space  [VLA-Object] - kolekcja / collection | Model/Paper + Block Object                   ;
;  Ps     [LIST]       - punkt poczatkowy / start point                                       ;
;  Pe     [LIST/REAL]  - punkt koncowy lub kat w radianach / end point or angle in radians    ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_AddXline (cd:ACX_ASpace) (getpoint) (/ pi 4))                                       ;
; =========================================================================================== ;
(defun cd:ACX_AddXline (Space Ps Pe)
  (vla-AddXline Space
    (vlax-3d-point (trans Ps 1 0))
    (vlax-3d-point
      (cond
        ( (numberp Pe)
           (trans (polar Ps Pe 1) 1 0)
        )
        ( (listp Pe)
           (trans (list (car Pe) (cadr Pe) (caddr Ps)) 1 0)
        )
      )
    )
  )
)
; =========================================================================================== ;
; Aktywny obszar / Active space                                                               ;
; =========================================================================================== ;
(defun cd:ACX_ASpace ()
  (if (= (getvar "CVPORT") 1)
    (vla-item (cd:ACX_Blocks) "*Paper_Space")
    (cd:ACX_Model)
  )
)
; =========================================================================================== ;
; Kolekcja Blocks / Blocks collection                                                         ;
; =========================================================================================== ;
(defun cd:ACX_Blocks ()
  (or
    *cd-Blocks*
    (setq *cd-Blocks* (vla-get-blocks (cd:ACX_ADoc)))
  )
  *cd-Blocks*
)
; =========================================================================================== ;
; Pobiera cechy obiektu VLA/ENAME / Gets the object VLA-Object/ENAME properties               ;
;  Obj [ENAME/VLA-Object] - entycja lub obiekt VLA / entity name or VLA-Object                ;
;  Lst [LIST] - lista cech / list of properties                                               ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_GetProp (entlast) '("LineType" "Color" "Layer"))                                    ;
; =========================================================================================== ;
(defun cd:ACX_GetProp (Obj Lst)
  (if (= (type Obj) (quote ENAME))
    (setq Obj (vlax-ename->vla-object Obj))
  )
  (mapcar
    (function
      (lambda (% / %1)
        (cons %
          (if (vlax-property-available-p Obj % nil)
            (if
              (not
                (setq %1
                  (cd:SYS_CheckError (list vlax-get-property Obj %))
                )
              )
              :vlax-false
              %1
            )
            :vlax-null
          )
        )
      )
    )
    Lst
  )
)
; =========================================================================================== ;
; Kolekcja Layers / Layers collection                                                         ;
; =========================================================================================== ;
(defun cd:ACX_Layers ()
  (or
    *cd-Layers*
    (setq *cd-Layers* (vla-get-Layers (cd:ACX_ADoc)))
  )
  *cd-Layers*
)
; =========================================================================================== ;
; Kolekcja Layouts / Layouts collection                                                       ;
; =========================================================================================== ;
(defun cd:ACX_Layouts ()
  (or
    *cd-Layouts*
    (setq *cd-Layouts* (vla-get-layouts (cd:ACX_ADoc)))
  )
  *cd-Layouts*
)
; =========================================================================================== ;
; Kolekcja LineTypes / LineTypes collection                                                   ;
; =========================================================================================== ;
(defun cd:ACX_LineTypes ()
  (or
    *cd-LineTypes*
    (setq *cd-LineTypes* (vla-get-LineTypes (cd:ACX_ADoc)))
  )
  *cd-LineTypes*
)
; =========================================================================================== ;
; Laduje definicje rodzaju linii z pliku LIN / Loads linetype definition from LIN file        ;
;  Name [STR] - nazwa warstwy / layer name                                                    ;
;  File [STR] - nazwa pliku LIN / LIN file name                                               ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_LoadLineType "HIDDEN" "acadiso.lin")                                                ;
; =========================================================================================== ;
(defun cd:ACX_LoadLineType (Name File / res)
  (setq res
    (if (tblobjname "LTYPE" Name)
      (vla-item (cd:ACX_LineTypes) Name)
      (if (snvalid Name 0)
        (vl-catch-all-apply
          (quote vla-load)
          (list (cd:ACX_LineTypes) Name File)
        )
      )
    )
  )
  (if (= (type res) (quote VLA-OBJECT)) res)
)
; =========================================================================================== ;
; Obszar modelu / Model space                                                                 ;
; =========================================================================================== ;
(defun cd:ACX_Model ()
  (or
    *cd-ModelSpace*
    (setq *cd-ModelSpace* (vla-get-ModelSpace (cd:ACX_ADoc)))
  )
  *cd-ModelSpace*
)
; =========================================================================================== ;
; Obszar papieru / Paper space                                                                ;
; =========================================================================================== ;
(defun cd:ACX_Paper ()
  (setq *cd-PaperSpace* (vla-get-PaperSpace (cd:ACX_ADoc)))
)
; =========================================================================================== ;
; Zmienia cechy obiektu VLA / Sets the property of VLA-Object                                 ;
;  Obj [ENAME/VLA-Object] - entycja lub obiekt VLA / entity name or VLA-Object                ;
;  Lst [LIST] - lista cech par kropkowych / list of dotted pairs properties                   ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_SetProp  (entlast) '(("LineType" . "BLA")("Color" . 1)("Layer" . "0")))             ;
; =========================================================================================== ;
(defun cd:ACX_SetProp (Obj Lst)
  (if (= (type Obj) (quote ENAME))
    (setq Obj (vlax-ename->vla-object Obj))
  )
  (if (vlax-write-enabled-p Obj)
    (mapcar
      (function
        (lambda (% / %1)
          (cons
            (car %)
            (if (vlax-property-available-p Obj (car %) T)
              (if
                (setq %1
                  (vl-catch-all-apply
                    (quote vlax-put-property)
                    (list Obj (car %)
                      (if (vl-symbolp (cdr %))
                        (eval (cdr %))
                        (cdr %)
                      )
                    )
                  )
                )
                %1
                :vlax-true
              )
              :vlax-null
            )
          )
        )
      )
      Lst
    )
  )
)
; =========================================================================================== ;
; Kolekcja TextStyles / TextStyles collection                                                 ;
; =========================================================================================== ;
(defun cd:ACX_TextStyles ()
  (or
    *cd-TextStyles*
    (setq *cd-TextStyles* (vla-get-TextStyles (cd:ACX_ADoc)))
  )
  *cd-TextStyles*
)
; =========================================================================================== ;
; Zwraca liste atrybutow wstawionego bloku / Returns a list of attributes of inserted block   ;
;  Ename [ENAME] - nazwa entycji / entity name                                                ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_GetAttEntity (car (entsel)))                                                        ;
; =========================================================================================== ;
(defun cd:BLK_GetAttEntity (Ename / dt ats res)
  (if
    (and
      Ename
      (= "INSERT" (cdr (assoc 0 (setq dt (entget Ename)))))
    )
    (if
      (and
        (setq ats (assoc 66 dt))
        (not (zerop (cdr ats)))
      )
      (reverse
        (while
          (/= "SEQEND"
            (cdr (assoc 0 (entget (setq Ename (entnext Ename)))))
          )
          (setq res (cons Ename res))
        )
      )
    )
  )
)
; =========================================================================================== ;
; Pobiera wartosci wszystkich atrybutow / Gets the values of all attributes                   ;
;  Ename [ENAME] - nazwa entycji / entity name                                                ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_GetAtts (car (entsel)))                                                             ;
; =========================================================================================== ;
(defun cd:BLK_GetAtts (Ename)
  (mapcar
    (function
      (lambda (% / dt)
        (setq dt (entget %))
        (cons
          (cdr (assoc 2 dt))
          (cdr (assoc 1 dt))
        )
      )
    )
    (cd:BLK_GetAttEntity Ename)
  )
)
; =========================================================================================== ;
; Pobiera wartosci wszystkich atrybutow / Gets the values of all attributes                   ;
;  Obj [VLA-Object] - obiekt VLA / VLA-Object                                                 ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_GetAttsVLA (vlax-ename->vla-object (car (entsel))))                                 ;
; =========================================================================================== ;
(defun cd:BLK_GetAttsVLA (Obj)
  (mapcar
    (function
      (lambda (%)
        (cons
          (vla-get-TagString %)
          (vla-get-TextString %)
        )
      )
    )
    (vlax-invoke Obj (quote GetAttributes))
  )
)
; =========================================================================================== ;
; Pobiera wartosc atrybutu / Gets the attribute value                                         ;
;  Obj [ENAME/VLA-Object] - entycja lub obiekt VLA / entity name or VLA-Object                ;
;  Tag [STR] - etykieta atrybutu / attribute tag                                              ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_GetAttValueVLA (car (entsel)) "VIEW_NUMBER")                                        ;
; =========================================================================================== ;
(defun cd:BLK_GetAttValueVLA (Obj Tag)
  (if (= (type Obj) (quote ENAME))
    (setq Obj (vlax-ename->vla-object Obj))
  )
  (vl-some
    (function
      (lambda (%)
        (if (eq (strcase tag) (strcase (vla-get-TagString %)))
          (vla-get-TextString %)
        )
      )
    )
    (vlax-invoke Obj (quote GetAttributes))
  )
)
; =========================================================================================== ;
; Lista nazw blokow (*U) zaleznych od bloku dynamicznego /                                    ;
; List of the blocks name (*U) which depends on a dynamic block                               ;
;  Name [STR] - nazwa bloku / block name                                                      ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_GetDynBlockNames "NazwaBloku")                                                      ;
; =========================================================================================== ;
(defun cd:BLK_GetDynBlockNames (Name / res n xd)
  (setq res (list Name))
  (vlax-for % (cd:ACX_Blocks)
    (if (wcmatch (setq n (vla-get-name %)) "`*U*")
      (if
        (setq xd
          (cd:XDT_GetXData
            (vlax-vla-object->ename %)
            "AcDbBlockRepBTag"
          )
        )
        (if
          (=
            (strcase Name)
            (strcase
              (cdr
                (assoc 2
                  (entget
                    (handent
                      (cdr (assoc 1005 (cdr xd)))
                    )
                  )
                )
              )
            )
          )
          (setq res (cons n res))
        )
      )
    )
  )
  (reverse res)
)
; =========================================================================================== ;
; Pobiera wlasciwosci bloku dynamicznego / Gets the dynamic block properties                  ;
;  Obj    [ENAME/VLA-Object] - entycja lub obiekt VLA / entity name or VLA-Object             ;
;  Origin [T/nil] - pokaz wlasciwosc ORIGIN / show the ORIGIN property                        ;
;                   nil = nie / no                                                            ;
;                   T = tak / yes                                                             ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_GetDynamicProps (car (entsel)) T)                                                   ;
; =========================================================================================== ;
(defun cd:BLK_GetDynamicProps (Obj Origin / _Sub pn res)
  (defun _Sub ()
    (setq res
      (cons
        (cons
          pn
          (vlax-get % (quote Value))
        )
        res
      )
    )
  )
  (if (= (type Obj) (quote ENAME))
    (setq Obj (vlax-ename->vla-object Obj))
  )
  (foreach % (vlax-invoke Obj (quote GetDynamicBlockProperties))
    (setq pn (vla-get-PropertyName %))
    (if Origin (_Sub)
      (if (/= (strcase pn) "ORIGIN") (_Sub))
    )
  )
  res
)
; =========================================================================================== ;
; Lista obiektow w definicji bloku / List of objects in block definition                      ;
;  Name   [STR] - nazwa bloku / block name                                                    ;
;  Entity [STR] - nazwa entycji / entity name                                                 ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_GetEntity "*Model_space" nil), (cd:BLK_GetEntity "NAZWA" "*LINE")                   ;
; =========================================================================================== ;
(defun cd:BLK_GetEntity (Name Entity / en dt res)
  (setq en (tblobjname "BLOCK" Name))
  (while
    (and
      en
      (setq en (entnext en))
      (setq dt (entget en))
      (/= "ENDBLK" (cdr (assoc 0 dt)))
    )
    (if
      (if Entity
        (wcmatch (cdr (assoc 0 dt)) (strcase Entity))
        (cdr (assoc 0 dt))
      )
      (setq res
        (cons
          (cdr (assoc -1 dt))
          res
        )
      )
    )
  )
  (reverse res)
)
; =========================================================================================== ;
; Lista odnosnikow zewnetrznych / List of external references                                 ;
; =========================================================================================== ;
(defun cd:BLK_GetXrefs (/ res)
  (vlax-for % (cd:ACX_Blocks)
    (if (= (vla-get-IsXref %) :vlax-true)
      (setq res (cons (vla-get-name %) res))
    )
  )
  res
)
; =========================================================================================== ;
; Wstawia blok / Inserts a block                                                              ;
;   Pb   [LIST]      - punkt wstawienia / insertion point                                     ;
;   Name [STR]       - nazwa bloku lub rysunku (bez .dwg) / block or drawing name (no .dwg)   ;
;   Xyz  [LIST/nil]  - LISTA = lista wspolczynnikow skali XYZ / list of X Y Z scale factor    ;
;                      nil   = X=Y=Z=1.0                                                      ;
;   Rot  [REAL/nil]  - REAL = kat obrotu w radianach / rotation angle in radians              ;
;                      nil  = kat=0.0 / angle=0.0                                             ;
;   Sup  [T/nil]     - szukaj w sciezkach poszukiwan / search at support path                 ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_InsertBlock '(0 0 0) "d:\\blok" '(2 2 2) 0 T)                                       ;
; =========================================================================================== ;
(defun cd:BLK_InsertBlock (Pb Name Xyz Rot Sup / ff)
  (if
    (not
      (vl-catch-all-error-p
        (setq res
          (vl-catch-all-apply
            (quote vla-InsertBlock)
            (list
              (cd:ACX_ASpace)
              (vlax-3d-point Pb)
              (if (tblsearch "BLOCK" Name)
                Name
                (if Sup
                  (findfile (strcat Name ".dwg"))
                  nil
                )
              )
              (if (not Xyz) 1.0 (car Xyz))
              (if (not Xyz) 1.0 (cadr Xyz))
              (if (not Xyz) 1.0 (caddr Xyz))
              (if (not Rot) 0.0 Rot)
            )
          )
        )
      )
    )
    res
  )
)
; =========================================================================================== ;
; Sprawdza czy blok jest blokiem dynamicznym / Checks if the block is a dynamic block         ;
;  Obj [ENAME/VLA-Object] - entycja lub obiekt VLA / entity name or VLA-Object                ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_IsDynamicInsert (car (entsel)))                                                     ;
; =========================================================================================== ;
(defun cd:BLK_IsDynamicInsert (Obj)
  (if (= (type Obj) (quote ENAME))
    (setq Obj (vlax-ename->vla-object Obj))
  )
  (= :vlax-true (vla-get-IsDynamicBlock Obj))
)
; =========================================================================================== ;
; Zmienia wartosc atrybutu / Sets the attribute value                                         ;
;  Obj   [ENAME/VLA-Object] - entycja lub obiekt VLA / entity name or VLA-Object              ;
;  Tag   [STR] - etykieta atrybutu / attribute tag                                            ;
;  Value [STR] - wartosc atrybuty / attribute value                                           ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_SetAttValueVLA (car (entsel)) "VIEW_NUMBER" "12")                                   ;
; =========================================================================================== ;
(defun cd:BLK_SetAttValueVLA (Obj Tag Value)
  (if (= (type Obj) (quote ENAME))
    (setq Obj (vlax-ename->vla-object Obj))
  )
  (vl-some
    (function
      (lambda (%)
        (if (eq (strcase tag) (strcase (vla-get-TagString %)))
          (progn
            (vla-put-TextString % Value)
            Value
          )
        )
      )
    )
    (vlax-invoke Obj (quote GetAttributes))
  )
)
; =========================================================================================== ;
; Zmienia wlasciwosci bloku dynamicznego / Sets the dynamic block properties                  ;
;  Obj  [ENAME/VLA-Object] - entycja lub obiekt VLA / entity name or VLA-Object               ;
;  Prop [STR]              - wlasciwosc / property                                            ;
;  Val  [REAL/INT/STR]     - nowa wartosc / new value                                         ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_SetDynamicProps (car (entsel)) "Height" 50)                                         ;
; =========================================================================================== ;
(defun cd:BLK_SetDynamicProps (Obj Prop Val)
  (if (= (type Obj) (quote ENAME))
    (setq Obj (vlax-ename->vla-object Obj))
  )
  (vl-some
    (function
      (lambda (%)
        (if (eq (strcase Prop) (strcase (vla-get-PropertyName %)))
          (if
            (not
              (vl-catch-all-error-p
                (vl-catch-all-apply
                  (quote vla-put-value)
                  (list
                    %
                    (vlax-make-variant Val
                      (vlax-variant-type (vla-get-value %))
                    )
                  )
                )
              )
            )
            Val
          )
        )
      )
    )
    (vlax-invoke Obj (quote GetDynamicBlockProperties))
  )
)
; =========================================================================================== ;
; Lista bitow liczby calkowitej / List of bits integer                                        ;
;  Number [INT] - liczba calkowita / integer number                                           ;
; ------------------------------------------------------------------------------------------- ;
; (cd:CAL_BitList 127)                                                                        ;
; =========================================================================================== ;
(defun cd:CAL_BitList (Number / n res)
  (setq n 1)
  (while (>= Number n)
    (and
      (= (logand Number n) n)
      (setq res (cons n res))
    )
    (setq n (lsh n 1))
  )
  (if res
    (reverse res)
    (list Number)
  )
)
; =========================================================================================== ;
; Tworzy ciag arytmetyczny / Creates arithmetic sequence                                      ;
;  St [REAL/INT] - liczba poczatkowa / initial number                                         ;
;  Le [REAL/INT] - dlugosc ciagu / sequence length                                            ;
;  Sp [REAL/INT] - roznica ciagu  / sequence difference                                       ;
; ------------------------------------------------------------------------------------------- ;
; (cd:CAL_Sequence 1.50 10 0.5)                                                               ;
; =========================================================================================== ;
(defun cd:CAL_Sequence (St Le Sp / res)
  (if (vl-every (quote numberp) (list St Le Sp))
    (progn
      (setq res (list St))
      (repeat (fix (1- Le))
        (setq res
          (cons
            (setq St (+ St Sp))
            res
          )
        )
      )
      (reverse res)
    )
  )
)
; =========================================================================================== ;
; Zmiana elementow listy na lancuchy tekstowe / Convert list elements onto strings            ;
;  Lst  [LIST]  - lista wejsciowa / input list                                                ;
;  Mode [T/nil] - nil = jak wynik z funkcji princ / as a result of the princ function         ;
;                 T   = jak wynik z funkcji prin1 / as a result of the prin1 function         ;
; ------------------------------------------------------------------------------------------- ;
; (cd:CON_All2Str '("A" "B" 1 3) nil) --> ("A" "B" "1" "3")                                   ;
; (cd:CON_All2Str '("A" "B" 1 3) T)   --> ("\"A\"" "\"B\"" "1" "3")                           ;
; =========================================================================================== ;
(defun cd:CON_All2Str (Lst Mode)
  (mapcar
    (function
      (lambda (%)
        (if Mode
          (vl-prin1-to-string %)
          (vl-princ-to-string %)
        )
      )
    )
    Lst
  )
)
; =========================================================================================== ;
; Konwertuje obiekt / Convert object                                                          ;
;  Obj [ENAME/VLA-Object/STR] - obiekt VLA, entycja lub lancuch tekstowy /                    ;
;                               VLA-Object, entity name or string                             ;
;  Format [nil/1/2/3/4] - format wyjsciowy / output format                                    ;
;                         nil = nazwa entycji / entity name                                   ;
;                         1   = obiekt VLA / VLA-Object                                       ;
;                         2   = uchwyt / handle                                               ;
;                         3   = ObjectID                                                      ;
;                         4   = ObjectIdString                                                ;
; ------------------------------------------------------------------------------------------- ;
; (cd:CON_ObjConv (entsel) 2)                                                                 ;
; =========================================================================================== ;
(defun cd:CON_ObjConv (Obj Format / ty res m %)
  (setq ty (type Obj))
  (if
    (setq res
      (cond
        ( (= ty (quote ENAME)) Obj )
        ( (= ty (quote VLA-OBJECT)) (vlax-vla-object->ename Obj) )
        ( (= ty (quote STR))
          (if (<= (strlen Obj) 8)
            (handent Obj)
            (cd:CON_ObjConv (read Obj) nil)
          )
        )
        ( (= ty (quote INT))
          (if
            (> Obj 0)
            (progn
              (setq m
                (if
                  (wcmatch
                    (strcase (getenv "PROCESSOR_ARCHITECTURE"))
                    "*64*"
                  )
                  "32" ""
                )
              )
              (vl-catch-all-apply
                (function
                  (lambda ()
                    (setq %
                      (vlax-invoke-method
                        (cd:ACX_ADoc)
                        (strcat "ObjectIDtoObject" m)
                        Obj
                      )
                    )
                  )
                )
              )
              (if % (vlax-vla-object->ename %))
            )
          )
        )
        (T nil)
      )
    )
    (cond
      ( (= 1 Format) (vlax-ename->vla-object res))
      ( (= 2 Format) (cdr (assoc 5 (entget res))))
      ( (= 3 Format) (vla-get-ObjectID (vlax-ename->vla-object res)))
      ( (= 4 Format)
        (vlax-invoke-method
          (vla-get-utility (cd:ACX_ADoc))
          "GetObjectIdString"
          (vlax-ename->vla-object res)
          :vlax-false
        )
      )
      (T res)
    )
  )
)
; =========================================================================================== ;
; Zmiana listy na lancuch tekstowy / Convert list onto text string                            ;
;  LST [LIST] - lista wejsciowa / input list                                                  ;
; ------------------------------------------------------------------------------------------- ;
; (cd:CON_List2Value (list 0 1 2 3 5)) --> "0 1 2 3 5"                                        ;
; =========================================================================================== ;
(defun cd:CON_List2Value (Lst)
  (vl-string-trim "()" (vl-princ-to-string Lst))
)
; =========================================================================================== ;
; Konwertuje liczbe na lancuch tekstowy / Converts number to a string                         ;
;  Val  [REAL/INT] - liczba do konwersji / conversion number                                  ;
;  Unit [INT/nil]  - jednostki wyjsciowe / output unit                                        ;
;                    nil = domyslne / default | (getvar "LUNITS")                             ;
;                    1   = naukowe / scientific                                               ;
;                    2   = dziesietne / decimal                                               ;
;                    3   = inzynierskie / engineering                                         ;
;                    4   = architektoniczne / architectural                                   ;
;                    5   = ulamkowe / fractional                                              ;
;  Prec [INT/nil]  - INT = liczba miejsc po przecinku / number of decimal places              ;
;                    nil = domyslna / default | (getvar "LUPREC")                             ;
; ------------------------------------------------------------------------------------------- ;
; (cd:CON_Real2Str 12 2 4)                                                                    ;
; =========================================================================================== ;
(defun cd:CON_Real2Str (Val Unit Prec / DMZ res)
  (setq DMZ (getvar "DIMZIN"))
  (setvar "DIMZIN"
    (if (not (member (getvar "LUNITS") (list 4 5)))
      (logand DMZ (~ 8)) 0
    )
  )
  (setq res
    (rtos
      Val
      (if (and Unit (member Unit (list 1 2 3 4 5))) 
        Unit
        (getvar "LUNITS")
      )
      (if Prec Prec (getvar "LUPREC"))
    )
  )
  (setvar "DIMZIN" DMZ)
  res
)
; =========================================================================================== ;
; Macierz transformacji ukladu wspolrzednych / The coordinate transformation matrix           ;
; Credit: Doug C. Broad, Jr. (UCS2WCSMatrix + WCS2UCSMatrix)                                  ;
;  Cs [INT] - docelowy uklad wspolrzednych / target coordinate system                         ;
;             0 = GUW (Globalny Uklad Wspolrzednych) / WCS (World Coordinate System)          ;
;             1 = LUW (Lokalny Uklad Wspolrzednych) / UCS (User Coordinate System)            ;
; =========================================================================================== ;
; (cd:CON_TransMatrix 0)                                                                      ;
; =========================================================================================== ;
(defun cd:CON_TransMatrix (Cs)
  (vlax-tmatrix
    (append
      (mapcar
        (function
          (lambda (vector origin)
            (append
              (trans vector (abs (1- Cs)) Cs T)
              (list origin)
            )
          )
        )
        (list '(1 0 0) '(0 1 0) '(0 0 1))
        (trans '(0 0 0) Cs (abs (1- Cs)))
      )
      (list '(0 0 0 1))
    )
  )
)
; =========================================================================================== ;
; Zmiana lancucha tekstowego na liste / Convert string into list elements                     ;
;  Val [STR] - lancuch tekstowy / string                                                      ;
; ------------------------------------------------------------------------------------------- ;
; (cd:CON_Value2List "0 1 2 3 5") --> (0 1 2 3 5)                                             ;
; =========================================================================================== ;
(defun cd:CON_Value2List (Val)
  (read (strcat "(" Val ")"))
)
; =========================================================================================== ;
; Zamienia liste liczb na 3DPoint (variant) / Converts a list of numbers to 3DPoint (variant) ;
;  Lst [LIST] - 2 lub 3 elementowa lista liczb / 2 or 3 element list of numbers               ;
; ------------------------------------------------------------------------------------------- ;
; (cd:CON_XYZ2Variant (list 10 2)), (cd:CON_XYZ2Variant (list 4 4 4))                         ;
; =========================================================================================== ;
(defun cd:CON_XYZ2Variant (Lst)
  (cond
    ( (listp Lst)
      (if
        (and
          (member (length Lst)(list 2 3))
          (apply (quote and)
            (mapcar
              (function
                (lambda (%)
                  (numberp %)
                )
              )
              Lst
            )
          )
        )
        (vlax-3d-Point Lst)
      )
    )
    ( (and
        (= (type Lst) (quote VARIANT))
        (= (vlax-variant-type Lst) 8197)
      )
      Lst
    )
    (T nil)
  )
)
; =========================================================================================== ;
; Obsluga listy kolorow / Handling of list colors                                             ;
;  KeyLst [STR]  - nazwa wycinka "popup_list" / "popup_list" tile name                        ;
;  KeyImg [STR]  - nazwa wycinka "image" / "image" tile name                                  ;
;  Lst    [LIST] - lista kolorow / list of colors                                             ;
;  Col    [STR]  - aktualny kolor / current color                                             ;
;  Old    [STR]  - poprzedni kolor / old kolor                                                ;
; =========================================================================================== ;
(defun cd:DCL_ChangeColorList (KeyLst KeyImg Lst Col Old / res cdlg tmp)
  (setq tmp Old)
  (cond
    ( (= Col "0") (setq res "256") )
    ( (= Col "1") (setq res "0") )
    ( (= Col "9")
      (if (setq cdlg (acad_colordlg (atoi tmp)))
        (setq res (itoa cdlg)
              tmp (itoa cdlg)
        )
        (setq res tmp)
      )
    )
    ( (= Col "10") (setq res tmp))
    ( T (setq res (itoa (1- (atoi Col)))) )
  )
  (cd:DCL_FillColorList KeyLst Lst res)
  (cd:DCL_FillColorImage KeyImg (atoi res))
  res
)
; =========================================================================================== ;
; Obsluga listy lancuchow tekstowych / Handling of the list of strings                        ;
;  Key   [STR]  - nazwa wycinka / tile name                                                   ;
;  Lst   [LIST] - lista / list                                                                ;
;  Pos   [INT]  - aktualna pozycja na liscie / current position in the list                   ;
;  Old   [STR]  - poprzednia pozycja na liscie / old item on the list                         ;
;  Label [STR]  - etykieta dla pozycji "Nowa..." / label for "New..." position                ;
;  Func  [SUBR] - funkcja do obslugi okienka edit_box / function to operate edit_box dialog   ;
; =========================================================================================== ;
(defun cd:DCL_ChangeStringList (Key Lst Pos Old Label Func / tmp len res)
  (setq tmp Old
        len (length Lst)
  )
  (cond
    ( (< Pos len)
      (setq res (nth Pos Lst))
    )
    ( (= Pos len)
      (cond
        ( (setq res (eval Func)) )
        ( (setq res tmp ) )
      )
    )
    ( T (setq res tmp) )
  )
  (if res (cd:DCL_FillStringList Key Lst res Label))
  res
)
; =========================================================================================== ;
; Wypelnia wycinek "image" kolorem / Fills "image" tile with color                            ;
;  Key [STR] - nazwa wycinka / tile name                                                      ;
;  Col [INT] - kolor / color                                                                  ;
; =========================================================================================== ;
(defun cd:DCL_FillColorImage (Key Col / X Y)
  (start_image Key) 
  (fill_image 0 0 (dimx_tile Key) (dimy_tile Key) Col) 
  (end_image)
)
; =========================================================================================== ;
; Wypelnia wycinek "popup_list" lista kolorow / Fills "popup_list" tiles with list of colors  ;
;  Key [STR]  - nazwa wycinka / tile name                                                     ;
;  Lst [LIST] - lista kolorow / list of colors                                                ;
;  Col [STR]  - aktualny kolor / current color                                                ;
; =========================================================================================== ;
(defun cd:DCL_FillColorList (Key Lst Col)
  (cond
    ( (= Col "256") (setq Col "0") )
    ( (= Col "0") (setq Col "1") )
    ( T (setq Col (itoa (1+ (atoi Col)))) )
  )
  (if
    (and
      (> (atoi Col) 8)
      (<= (atoi Col) 256)
    )
    (setq Lst (append Lst (list (itoa (1- (atoi Col)))))
          Col "10"
    )
  )
  (cd:DCL_SetList Key Lst Col)
)
; =========================================================================================== ;
; Wypelnia wycinek "popup_list" lista lancuchow tekstowych /                                  ;
; Fills "popup_list" tiles with list of strings                                               ;
;  Key   [STR]  - nazwa wycinka / tile name                                                   ;
;  Lst   [LIST] - lista lancuchow tekstowych / list of strings                                ;
;  Str   [STR]  - aktualny lancuch tekstowy / current string                                  ;
;  Label [STR]  - etykieta dla pozycji "Nowa..." / label for "New..." position                ;
; =========================================================================================== ;
(defun cd:DCL_FillStringList (Key Lst Str Label / pos)
  (if (setq pos (vl-position (strcase Str) (mapcar (quote strcase) Lst)))
    (setq Lst (append Lst (list Label)))
    (setq Lst (append Lst (list Label Str))
          pos (1- (length Lst))
    )
  )
  (cd:DCL_SetList Key Lst pos)
)
; =========================================================================================== ;
; Image_button - ikona sortowania / Image_button - sort icon                                  ;
;  Key   [STR] - nazwa wycinka / name of control                                              ;
;  Mode  [INT] - kierunek sortowania / sort direction                                         ;
;                0 = rosnaco / ascending                                                      ;
;                1 = malejaco / descending                                                    ;
;  Col   [INT] - kolor wypelnienia / fill color                                               ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCL_ImgBtnSortIcon "image" 0 15)                                                        ;
; =========================================================================================== ;
(defun cd:DCL_ImgBtnSortIcon (Key Mode Col / x y c n d l)
  (setq x (dimx_tile Key)
        y (dimy_tile Key)
        c (if (not Col) 252 Col)
        n (/ x 2)
        d (if (zerop Mode)(- (/ y 2) 2)(+ (/ y 2) 2))
        l '(0 1 2 3 4 5)
  )
  (start_image Key)
  (fill_image 2 2 (- x 2)(- y 2) -15)
  (mapcar
    (function
      (lambda (% / %1 %2)
        (setq %1 (nth % (reverse l))
              %2 (if (zerop Mode) (+ d %1) (- d %1))
        )
        (vector_image (- n %) %2 (+ n %) %2 c)
      )
    )
    l
  )
  (end_image)
)
; =========================================================================================== ;
; DCL-owe okno komunikatu / DCL message box                                                   ;
;  Msg   [STR]         - komunikat do wyswietlenia / message to display                       ;
;  Title [STR]         - tytul okna / window title                                            ;
;  Btn   [0/1/2/3/4/5] - przyciski / buttons                                                  ;
;  DPos  [T/nil]       - zapamietanie pozycji okna / save window position                     ;
;  Lng   [0/1/nil]     - 0   = jezyk polski / polish language                                 ;
;                        1   = jezyk angielski / english language                             ;
;                        nil = ustawienie standardowe / default settings                      ;
; ------------------------------------------------------------------------------------------- ;
; Typy przyciskow / Buttons type:                                                             ;
;  0  = OK                / OK                                                                ;
;  1  = OK i Anuluj       / OK and Cancel                                                     ;
;  2  = Anuluj            / Cancel                                                            ;
;  3  = Tak, Nie i Anuluj / Yes, No and Cancel                                                ;
;  4  = Tak i Nie         / Yes and No                                                        ;
;  5  = Zamknij           / Close                                                             ;
; ------------------------------------------------------------------------------------------- ;
; Zwraca / Return:                                                                            ;
;  1  = OK      / OK                                                                          ;
;  2  = Anuluj  / Cancel                                                                      ;
;  6  = Tak     / Yes                                                                         ;
;  7  = Nie     / No                                                                          ;
;  12 = Zamknij / Close                                                                       ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCL_Msgbox "Komunikat\nw 2 liniach" "Uwaga" 4 T 0)                                      ;
; =========================================================================================== ;
(defun cd:DCL_MsgBox (Msg Title Btns DPos Lng / data f tmp dc res l d c h)
  (if (not DPos) (setq *cd-TempDlgPosition* (list -1 -1)))
  (setq data (cd:STR_Parse Msg "\n" T)
        d (length data)
        c (if (numberp Lng)
            (cond
              ( (zerop Lng) T)
              ( (= 1 Lng) nil)
              (T nil)
            )
            (= "PL" (cadddr (cd:SYS_AcadInfo)))
          )
        h "width=12;horizontal_margin=none;vertical_margin=none;fixed_width=true;"
  )
  (cond
    ( (not
        (and
          (setq f
            (open
              (setq tmp (vl-FileName-MkTemp nil nil ".dcl")) "w"
            )
          )
          (foreach %
            (list
              "StdYesNoDialog:dialog{"
              (strcat "label=\""
                (if Title (strcat Title "\";") "\"\";")
              )
              ":text{key=\"text\";"
              (strcat
                "width="
                (itoa
                  (if (< (setq l (car (vl-sort (mapcar (quote strlen) data) (quote >)))) 36)
                    37
                    (if (> l 100) 99 l)
                  )
                )
                ";height=" (if (>= d 15) "15" (itoa d))
              )
              ";}:spacer{height=0.2;}:row{alignment=centered;spacer_0;"
              (cond
                ( (zerop Btns)
                  (strcat
                    ":retirement_button{label=\"OK\";key=\"accept\";is_default=true;" h "}"
                  )
                )
                ( (= 1 Btns)
                  (strcat
                    ":row{width=25;fixed_width=true;"
                    ":retirement_button{label=\"OK\";key=\"accept\";is_default=true;" h
                    "}:retirement_button{"
                    (if c "label=\"&Anuluj\";" "label=\"&Cancel\";")
                    "key=\"cancel\";is_cancel=true;" h "}}"
                  )
                )
                ( (= 2 Btns)
                  (strcat
                    ":retirement_button{"
                    (if c "label=\"&Anuluj\";" "label=\"&Cancel\";")
                    "key=\"cancel\";is_cancel=true;" h "}"
                  )
                )
                ( (= 3 Btns)
                  (strcat
                    ":row{width=38;fixed_width=true;:button{"
                    (if c "label=\"&Tak\";" "label=\"&Yes\";") "key=\"yes\";is_default=true;" h
                    "}:button{" (if c "label=\"&Nie\";" "label=\"&No\";") "key=\"not\";" h
                    "}:retirement_button{"
                    (if c "label=\"&Anuluj\";" "label=\"&Cancel\";")
                    "key=\"cancel\";is_cancel=true;" h "}}"
                  )
                )
                ( (= 4 Btns)
                  (strcat
                    ":row{width=25;fixed_width=true;:button{"
                    (if c "label=\"&Tak\";" "label=\"&Yes\";") "key=\"yes\";is_default=true;" h
                    "}:button{" (if c "label=\"&Nie\";" "label=\"&No\";") "key=\"not\";" h "}}"
                  )
                )
                ( (= 5 Btns)
                  (strcat
                     ":button{is_cancel=true;"
                     (if c "label=\"&Zamknij\";" "label=\"&Close\";")
                    "key=\"close\";width=12;" h "is_default=true;}"
                  )
                )
                (T
                  (strcat
                    ":retirement_button{label=\"OK\";key=\"accept\";is_default=true;" h "}"
                  )
                )
              )
              "spacer_0;}}"
            )
            (write-line % f)
          )
          (not (close f))
          (< 0 (setq dc (load_dialog tmp)))
          (new_dialog "StdYesNoDialog" dc ""
            (cond
              (*cd-TempDlgPosition*)
              ( (quote (-1 -1)) )
            )
          )
        )
      )
    )
    ( T     
      (set_tile "text"
        (apply (quote strcat)
          (mapcar
            (function
              (lambda (%)
                (strcat % "\n")
              )
            )
            data
          )
        )
      )
      (action_tile "accept" "(setq *cd-TempDlgPosition* (done_dialog 1))")
      (action_tile "yes" "(setq *cd-TempDlgPosition* (done_dialog 6))")
      (action_tile "cancel" "(done_dialog 2)")
      (action_tile "not" "(done_dialog 7)")
      (action_tile "close" "(done_dialog 12)")
      (setq res (start_dialog))
    )
  )
  (if (< 0 dc) (unload_dialog dc))
  (if (setq tmp (findfile tmp)) (vl-File-Delete tmp))
  (if (not DPos) (setq *cd-TempDlgPosition* (list -1 -1)))
  res
)
; =========================================================================================== ;
; Wypelnia wycinki "list_box" i "popup_list" / Fills "list_box" and "popup_list" tiles        ;
;  Key [STR]              - nazwa wycinka / tile name                                         ;
;  Lst [LIST]             - lista do wypelnienia / list to fill                               ;
;  Pos [INT/REAL/STR/nil] - aktualna pozycja na liscie / current position on the list         ;
; =========================================================================================== ;
(defun cd:DCL_SetList (Key Lst Pos)
  (start_list Key)
  (mapcar (quote add_list) Lst)
  (end_list)
  (set_tile Key
    (itoa
      (cond
        ( (numberp Pos) (fix Pos))
        ( (= (type Pos) (quote STR)) (atoi Pos))
        (T 0)
      )
    )
  )
)
; =========================================================================================== ;
; Okno dialogowe "edit_box" / "edit_box" dialog control                                       ;
;  Data      [LIST]     - argumetny (maks. 7) / arguments (max. 7) | (list a b c d e f g)     ;
;   * STR - dowolny lancuch / any string                                                      ;
;     a = 0                                                                                   ;
;     b - INT  = rodzaje bledow / type of errors                                              ;
;         LIST = rodzaje bledow wraz z komunikatem / type of errors with the messages         ;
;     c - wartosc domyslna / default value                                                    ;
;   * STR - zgodny z tablica/wzorcem / consistent with table/pattern                          ;
;     a = 1                                                                                   ;
;     b - INT  = rodzaje bledow / type of errors                                              ;
;         LIST = rodzaje bledow wraz z komunikatem / type of errors with the messages         ;
;     c - wartosc domyslna / default value                                                    ;
;     d - nazwa tablicy / table name                                                          ;
;     e = wzorzec / pattern                                                                   ;
;     f = lista uzytkownika / user list                                                       ;
;   * INT = 2, REAL = 3                                                                       ;
;     a = 2,3                                                                                 ;
;     b - INT  = rodzaje bledow / type of errors                                              ;
;         LIST = rodzaje bledow wraz z komunikatem / type of errors with the messages         ;
;     c - wartosc domyslna / default value                                                    ;
;     d - wartosc minimalna / minimum value                                                   ;
;     e - wartosc maksymalna / maximum value                                                  ;
;     f - jednostki wyjsciowe / output unit                                                   ;
;         nil = domyslne / default | (getvar "LUNITS")                                        ;
;         1   = naukowe / scientific                                                          ;
;         2   = dziesietne / decimal                                                          ;
;         3   = inzynierskie / engineering                                                    ;
;         4   = architektoniczne / architectural                                              ;
;         5   = ulamkowe / fractional                                                         ;
;     g - INT = liczba miejsc po przecinku / number of decimal places                         ;
;         nil = domyslna / default | (getvar "LUPREC")                                        ;
;  Title     [STR/nil]  - tytul okna / window title                                           ;
;  EditTitle [STR/nil]  - tytul "edit_box" / "edit_box" title                                 ;
;  Width     [INT]      - szerokosc / width                                                   ;
;  BtnsWidth [REAL/INT] - szerokosc przyciskow / buttons width                                ;
;  BtnsLabel [LIST]     - etykiety przyciskow / buttons label                                 ;
;  DPos      [T/nil]    - zapamietanie pozycji okna / save window position                    ;
;  Limit     [INT]      - limit znakow / signs limit                                          ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCL_StdEditBoxDialog (list 0 0 "") "Poziom" "Nowy:" 40 13 (list "&Ok" "&Anuluj") T  5)  ;
; (cd:DCL_StdEditBoxDialog                                                                    ;
;   (list 1                                                                                   ;
;     (list                                                                                   ;
;       (cons 1 "Wprowadz dane")                                                              ;
;       (cons 2 "Niepoprawna warstwa")                                                        ;
;       (cons 4 "Warstwa wystepuje w rysunku")                                                ;
;       (cons 16 "Warstwa nie pasuje do wzorca")                                              ;
;     )                                                                                       ;
;     "" "LAYER" "??-??"                                                                      ;
;   )                                                                                         ;
;   "Warstwa" "Nowa warstwa: (format ??-??)" 40 13 (list "&Ok" "&Anuluj") T 5                 ;
; )                                                                                           ;
; (cd:DCL_StdEditBoxDialog                                                                    ;
;   (list 3                                                                                   ;
;     (list                                                                                   ;
;       (cons 1 "Wprowadz liczbe rzeczywista")                                                ;
;       (cons 2 "Liczba nie moze byc zerem")                                                  ;
;       (cons 8 "Spacje niedozwolone")                                                        ;
;       (cons 16 "To nie jest liczba")                                                        ;
;       (cons 32 "Liczba jest za mala")                                                       ;
;       (cons 64 "Liczba jest za duza")                                                       ;
;     )                                                                                       ;
;     "19" -100 100 2 2                                                                       ;
;   )                                                                                         ;
;   "Poziom" "Wprowadz poziom: (-100 < X < 100)" 40 13 (list "&Ok" "&Anuluj") T nil           ;
; )                                                                                           ;
; =========================================================================================== ;
(defun cd:DCL_StdEditBoxDialog (Data Title EditTitle Width BtnsWidth BtnsLabel DPos Limit
                                / _CheckVal fd tmp dc defval res fl
                               )
  (defun _CheckVal (Code Bit Val / tmp _Logand _IsBlank _IsSpaces _Pattern _UserList
                                   _Error _StrUnit _Nth _IsNumb res err)
    (setq tmp Bit)
    (if (not fl) (setq Bit (apply (quote +) (mapcar (quote car) Bit))))
    (defun _Logand (b) (= b (logand Bit b)))
    (defun _IsBlank (s) (= s ""))
    (defun _IsSpaces (s) (not (vl-remove '32 (vl-string->list s))))
    (defun _Pattern (s) (not (wcmatch s (_Nth 4))))
    (defun _UserList (s) (member (strcase Val) (mapcar (quote strcase) (_Nth 5))))
    (defun _Error (b) (if (not fl) (setq err (cdr (assoc b tmp)))))
    (defun _StrUnit (s) (distof s 3))
    (defun _Nth (n / p)
      (if (setq p (vl-catch-all-apply (quote nth) (list n Data)))
        p
        (vl-catch-all-error-p p)
      )
    )
    (defun _IsNumb (s b / r)
      (if (setq r (_StrUnit s))
        (cond
          ( (and (= 1 (logand 1 b)) (numberp r)) ) ; liczba / number
          ( (and (= 2 (logand 2 b)) (zerop r)) )   ; zero   / zero
          ( (and (= 4 (logand 4 b)) (minusp r)) )  ; ujemna / negative
          ( T nil )
        )
      )
    )
    (cond
      ( (= Code 0) ; dowolny lancuch / any string
        (cond
          ( (and (_Logand 1) (_IsBlank Val)) (_Error 1) )  ; bez ""            / no ""
          ( (and (_Logand 8) (_IsSpaces Val)) (_Error 8) ) ; bez samych spacji / no spaces
          ( T (setq res Val) )
        )
      )
      ( (= Code 1) ; lancuch zgodny z nazwa tablicy / string consistent with table name
        (cond
          ( (and (_Logand 1) (_IsBlank Val)) (_Error 1) )           ; bez ""                  / no ""
          ( (and (_Logand 2) (not (snvalid Val))) (_Error 2) )      ; bez zlej nazwy snvalid  / no bad name
          ( (and (_Logand 4) (tblsearch (_Nth 3) Val)) (_Error 4) ) ; bez istniejacych nazw   / no existing name
          ( (and (_Logand 8) (_IsSpaces Val)) (_Error 8) )          ; bez samych spacji       / no spaces
          ( (and (_Logand 16) (_Pattern Val)) (_Error 16) )         ; pasujacy do wzorca      / match pattern
          ( (and (_Logand 32) (_UserList Val)) (_Error 32) )        ; nie wystepuje na liscie / does not appear in the list
          ( T (setq res Val) )
        )
      )
      ( (member Code (list 2 3)) ; INT = 2, REAL = 3
        (cond
          ( (and (_Logand 1) (_IsBlank Val)) (_Error 1) )                ; bez ""            / no ""
          ( (and (_Logand 2) (_IsNumb Val 2)) (_Error 2) )               ; bez zera          / no zero
          ( (and (_Logand 4) (_IsNumb Val 4)) (_Error 4) )               ; bez ujemnych      / no negative
          ( (and (_Logand 8) (_IsSpaces Val)) (_Error 8) )               ; bez samych spacji / no spaces
          ( (and (_Logand 16) (not (_IsNumb Val 1))) (_Error 16) )       ; tylko liczby      / only number
          ( (and (_Logand 32) (> (_Nth 3) (_StrUnit Val))) (_Error 32) ) ; liczba za mala    / number to small
          ( (and (_Logand 64) (< (_Nth 4) (_StrUnit Val))) (_Error 64) ) ; liczba za duza    / number to big
          ( T
            (setq res
              (if (_IsNumb Val 1)
                (if (= Code 2)
                  (itoa (fix (_StrUnit Val)))
                  (cd:CON_Real2Str (_StrUnit Val) (_Nth 5) (_Nth 6))
                )
                Val
              )
            )
          )
        )
      )
      ( T nil )
    )
    (if (and defval res)
      (set_tile "edit" res)
      (set_tile "edit" Val)
    )
    (if err
      (set_tile "error" err)
      (set_tile "error" "")
    )
    res
  )
  (if (not DPos) (setq *cd-TempDlgPosition* (list -1 -1)))
  (cond
    ( (not
        (and
          (setq fd
            (open
              (setq tmp (vl-FileName-MkTemp nil nil ".dcl")) "w"
            )
          )
          (foreach %
            (list
              (strcat
                "but : button { width = " (if BtnsWidth (itoa BtnsWidth) 13) "; fixed_width = true; }"
                "StdEditBoxDialog : dialog {"
                (if Title (strcat "label = \"" Title "\";") "")
                "  : boxed_column {"
                (if EditTitle (strcat "label = \"" EditTitle "\";") "")
                "    width = " (if Width (itoa Width) "20") ";"
                "    : edit_box { key = \"edit\";"
                (if Limit (strcat "edit_limit = " (itoa Limit) ";") "")
                "    } spacer; }"
                "  : row { alignment = centered; fixed_width = true;"
                "  : but { key = \"" (car BtnsLabel) "\";"
                "    label = \"" (car BtnsLabel) "\"; is_default = true; }"
                "  : but { key = \"" (cadr BtnsLabel) "\";"
                "    label = \"" (cadr BtnsLabel) "\"; is_cancel = true; }"
                "  } " (if (setq fl (= (type (cadr Data)) (quote INT))) "" ": errtile { width = 20; }") " }"
              )
            )
            (write-line % fd)
          )
          (not (close fd))
          (< 0 (setq dc (load_dialog tmp)))
          (new_dialog "StdEditBoxDialog" dc ""
            (cond
              ( *cd-TempDlgPosition* )
              ( (quote (-1 -1)) )
            )
          )
        )
      )
    )
    ( T
      (setq defval (substr (caddr Data) 1 Limit)
            res (if (not (= defval "")) (_CheckVal (car Data) (cadr Data) defval))
      )
      (mode_tile "edit" 2)
      (action_tile "edit" "(setq res (_CheckVal (car Data) (cadr Data) $value))")
      (action_tile (car BtnsLabel) "(if res (setq *cd-TempDlgPosition* (done_dialog 1)))")
      (action_tile (cadr BtnsLabel) "(setq res nil) (done_dialog 0)")
      (start_dialog)
    )
  )
  (if (< 0 dc) (unload_dialog dc))
  (if (setq tmp (findfile tmp)) (vl-file-delete tmp))
  (if (not DPos) (setq *cd-TempDlgPosition* (list -1 -1)))
  res
)
; =========================================================================================== ;
; Okno dialogowe z lista "list_box" / Dialog control with list "list_box"                     ;
;  Data      [LIST]     - lista do wyswietlenia / list to display                             ;
;  Pos       [INT]      - pozycja poczatkowa na liscie / select list position                 ;
;  Title     [STR/nil]  - tytul okna / window title                                           ;
;  ListTitle [STR/nil]  - tytul list_box / list_box title                                     ;
;  Width     [INT]      - szerokosc / width                                                   ;
;  Height    [INT]      - wysokosc / height                                                   ;
;  Btns      [0/1/2]    - [cancel/ok/ok_cancel] przyciski / buttons                           ;
;  BtnsWidth [REAL/INT] - szerokosc przyciskow / buttons width                                ;
;  BtnsLabel [LIST]     - etykiety przyciskow / buttons label                                 ;
;  MSelect   [T/nil]    - dopuszczenie multiple_select / allow multiple select                ;
;  DPos      [T/nil]    - zapamietanie pozycji okna / save window position                    ;
;  DblClick  [T/nil]    - podwojny klik (wykluczone Cancel) / double click (not for Cancel)   ;
;  Func      [SUBR]     - funkcja do obslugi wybranej pozycji na liscie /                     ;
;                         function to operate selected position on the list                   ;
; ------------------------------------------------------------------------------------------- ;
; Zwraca / Return:                                                                            ;
;  nil  = nic nie wybrano (anulowano) / nothing was selected (canceled)                       ;
;  INT  = wybrano jedna pozycje / one position selected  | MSelect = nil                      ;
;  LIST = wybrano kilka pozycji / few positions selected | MSelect = T                        ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCL_StdListDialog                                                                       ;
;   (setq lst (mapcar 'car (cd:DWG_LayoutsList))) (vl-position (getvar "ctab") lst)           ;
;   "List of Layouts" "Select layout:" 40 15 2 13 (list "&Ok" "&Cancel")                      ;
;   nil T T '(setvar "ctab" (nth (atoi res) lst)))                                            ;
; =========================================================================================== ;
(defun cd:DCL_StdListDialog (Data Pos Title ListTitle Width Height
                             Btns BtnsWidth BtnsLabel MSelect DPos DblClick Func
                             / _Sub _Value2List _SetControls fd ok ca tmp dc res)
  (defun _Sub (Val)
    (if (and Func Data) (eval Func))
    (_SetControls (setq res (_Value2List Val)))
  )
  (defun _Value2List (Val) (read (strcat "(" Val ")")))
  (defun _SetControls (Idx)
    (if (and Idx Data)
      (mode_tile (car BtnsLabel) 0)
      (mode_tile (car BtnsLabel) 1)
    )
  )
  (if (not DPos) (setq *cd-TempDlgPosition* (list -1 -1)))
  (cond
    ( (not
        (and
          (setq fd
            (open
              (setq tmp (vl-FileName-MkTemp nil nil ".dcl")) "w"
            )
          )
          (setq ok (strcat
                     ":but{label=\"" (car BtnsLabel) "\";"
                     "key=\"" (car BtnsLabel) "\";is_default=true;}"
                   )
                ca (strcat
                     ":but{label=\"" (cadr BtnsLabel) "\";"
                     "key=\"" (cadr BtnsLabel) "\";is_cancel=true;}"
                   )
          )
          (foreach % 
            (list
              (strcat
                "but:button{width=" (if BtnsWidth (itoa BtnsWidth) 13)
                ";fixed_width=true;}"
                "StdListDialog:dialog{"
                (if Title (strcat "label=\"" Title "\";") "")
                ":list_box{key=\"list\";"
                (if ListTitle (strcat "label=\"" ListTitle "\";") "")
                "fixed_width=true;fixed_height=true;"
                "width=" (if Width (itoa Width) "20" ) ";"
                "height=" (if Height (itoa Height) "20" ) ";"
                "multiple_select=" (if MSelect "true;" "false;")
                "}:row{alignment = centered;fixed_width = true;"
              )
              (cond
                ( (zerop Btns) ca )
                ( (= 1 Btns) ok )
                ( T (strcat ok ca) )
              )
              "}}"
            )
            (write-line % fd)
          )
          (not (close fd))
          (< 0 (setq dc (load_dialog tmp)))
          (new_dialog "StdListDialog" dc ""
            (cond
              ( *cd-TempDlgPosition* )
              ( (quote (-1 -1)) )
            )
          )
        )
      )
    )
    ( T     
      (start_list "list")
      (mapcar (quote add_list) Data)
      (end_list)
      (if
        (or
          (not Pos)
          (not (< -1 Pos (length Data)))
        )
        (setq Pos 0)
      )
      (setq res (set_tile "list" (itoa Pos)))
      (_Sub res)
      (action_tile "list"
        (vl-prin1-to-string
          (quote
            (progn
              (setq res $value)
              (_Sub res)
              (if
                (and
                  DblClick
                  (not (zerop Btns))
                )
                (if (= $reason 4)
                  (setq *cd-TempDlgPosition* (done_dialog 1))
                )
              )
            )
          )
        )
      )
      (action_tile (car BtnsLabel) "(setq *cd-TempDlgPosition* (done_dialog 1))")
      (action_tile (cadr BtnsLabel) "(setq res nil) (done_dialog 0)")
      (start_dialog)
    )
  )
  (if (< 0 dc) (unload_dialog dc))
  (if (setq tmp (findfile tmp)) (vl-file-delete tmp))
  (if (not DPos) (setq *cd-TempDlgPosition* (list -1 -1)))
  (if res (if (= 1 (length res)) (car res) res))
)
; =========================================================================================== ;
; Dodaje slownik / Adds dictionary                                                            ;
;  Root [ENAME/nil] - ENAME = slownik "rodzic" / "parent" dictionary                          ;
;                     nil   = (namedobjdict) jako "rodzic" / (namedobjdict) as "parent"       ;
;  Name [STR]       - nazwa slownika / name of the dictionary                                 ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCT_AddDict (namedobjdict) "NAZWA")                                                     ;
; =========================================================================================== ;
(defun cd:DCT_AddDict (Root Name)
  (dictadd (if (not Root) (namedobjdict) Root) Name
    (entmakex (append '((0 . "DICTIONARY")(100 . "AcDbDictionary"))))
  )
)
; =========================================================================================== ;
; Dodaje Xrecord / Adds the Xrecord                                                           ;
;  Root  [ENAME/nil] - ENAME = slownik "rodzic" / "parent" dictionary                         ;
;                      nil   = (namedobjdict) jako "rodzic" / (namedobjdict) as "parent"      ;
;  XName [STR]       - nazwa xrecord / xrecord name                                           ;
;  XData [LIST]      - dane xrecord / xrecord data                                            ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCT_AddXrecord (cd:DCT_GetDict (namedobjdict) "NAZWA") "NAZWA-SUB1" '((1 . "ABC")))     ;
; =========================================================================================== ;
(defun cd:DCT_AddXrecord (Root XName XData)
  (dictadd (if (not Root) (namedobjdict) Root) XName
    (entmakex (append '((0 . "XRECORD")(100 . "AcDbXrecord")) XData))
  )
)
; =========================================================================================== ;
; Pobiera slownik / Gets a dictionary                                                         ;
;  Root [ENAME/nil] - ENAME = slownik "rodzic" / "parent" dictionary                          ;
;                     nil   = (namedobjdict) jako "rodzic" / (namedobjdict) as "parent"       ;
;  Name [STR]       - nazwa slownika / name of the dictionary                                 ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCT_GetDict (namedobjdict) "NAZWA")                                                     ;
; =========================================================================================== ;
(defun cd:DCT_GetDict (Root Name)
  (cdr (assoc -1 (dictsearch (if (not Root) (namedobjdict) Root) Name)))
)
; =========================================================================================== ;
; Pobiera liste slownikow "rodzica" / Gets a list of "parent" dictionaries                    ;
;  Root [ENAME] - ENAME = slownik "rodzic" / "parent" dictionary                              ;
;  Code [T/nil] - T   = zwraca / returns -> ((<slownik1> . <ENAME1>) ... )                    ;
;                 nil = zwraca / returns -> (<slownik1> <slownik2> ... )                      ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCT_GetDictList (cd:DCT_GetDict (namedobjdict) "NAZWA") T)                              ;
; =========================================================================================== ;
(defun cd:DCT_GetDictList (Root Code / dt tmp res)
  (if Root
    (if Code
      (progn
        (setq dt (entget Root))
        (while
          (setq dt (member (setq tmp (assoc 3 dt)) dt))
          (setq res (cons (cons (cdr tmp) (cdadr dt)) res)
                dt (cdr dt)
          )
        )
        (setq res (reverse res))
      )
      (setq res (cd:DXF_massoc 3 (entget Root)))
    )
  )
  res
)
; =========================================================================================== ;
; Pobiera/Tworzy ExtensionDictionary obiektu / Gets/Creates an ExtensionDictionary of object  ;
;  Obj  [ENAME/VLA-Object] - entycja lub obiekt VLA / entity name or VLA-Object               ;
;  Flag [T/nil] - T   = tworzy / creates                                                      ;
;                 nil = pobiera jesli istnieje / gets if exist                                ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCT_GetExtDictVLA (car (entsel)) T)                                                     ;
; =========================================================================================== ;
(defun cd:DCT_GetExtDictVLA (Obj Flag / res)
  (if (= (type Obj) (quote ENAME))
    (setq Obj (vlax-ename->vla-object Obj))
  )
  (if
    (setq res
      (if (= :vlax-true (vla-get-HasExtensionDictionary Obj))
        (vla-GetExtensionDictionary Obj)
        (if Flag (vla-GetExtensionDictionary Obj))
      )
    )
    (vlax-vla-object->ename res)
  )
)
; =========================================================================================== ;
; Pobiera/Tworzy ExtensionDictionary obiektu / Gets/Creates an ExtensionDictionary of object  ;
;  Ename [ENAME] - nazwa entycji / entity name                                                ;
;  Flag  [T/nil] - T   = tworzy / creates                                                     ;
;                  nil = pobiera jesli istnieje / gets if exist                               ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCT_GetExtDict (car (entsel)) T)                                                        ;
; =========================================================================================== ;
(defun cd:DCT_GetExtDict (Ename Flag / res he ta)
  (if
    (and
      (= (type Ename) (quote ENAME)) 
      (setq dt (entget Ename))
    )
    (if (not (setq res (cdr (assoc 360 (member '(102 . "{ACAD_XDICTIONARY") dt)))))
      (if Flag
        (progn
          (setq res (entmakex (append '((0 . "DICTIONARY") (100 . "AcDbDictionary"))))
                he (reverse (member (assoc 5 dt) (reverse dt)))
                ta (cdr (member (assoc 5 dt) dt))
          )
          (entmod
            (append
              he
              (list 
               '(102 . "{ACAD_XDICTIONARY")
                (cons 360 res)
               '(102 . "}")
              )
              ta
            )
          )
        )
      )
    )
  )
  res
)
; =========================================================================================== ;
; Pobiera Xrecord / Gets Xrecord                                                              ;
;  Ename [ENAME] - nazwa entycji / entity name                                                ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCT_GetXrecord (cdar (cd:DCT_GetDictList (cd:DCT_GetDict (namedobjdict) "NAZWA") T)))   ;
; =========================================================================================== ;
(defun cd:DCT_GetXRecord (Ename / dt)
  (cdr (member (assoc 280 (setq dt (entget Ename))) dt))
)
; =========================================================================================== ;
; Usuwa slownik / Removes the dictionary                                                      ;
;  Root [ENAME/nil] - ENAME = slownik "rodzic" / "parent" dictionary                          ;
;                     nil   = (namedobjdict) jako "rodzic" / (namedobjdict) as "parent"       ;
;  Name [STR]       - nazwa slownika / name of the dictionary                                 ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCT_RemoveDict (namedobjdict) "NAZWA")                                                  ;
; =========================================================================================== ;
(defun cd:DCT_RemoveDict (Root Name)
  (dictremove (if (not Root) (namedobjdict) Root) Name)
)
; =========================================================================================== ;
; Podmienia Xrecord / Replace Xrecord                                                         ;
;  Ename [ENAME] - nazwa entycji xrecord / entity name xrecord                                ;
;  Data  [LIST]  - lista par kropkowych / list of dotted pairs                                ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCT_ReplaceXrecord                                                                      ;
;   (cdar (cd:DCT_GetDictList (cd:DCT_GetDict (namedobjdict) "NAZWA") T))                     ;
;   (list (cons 1 "NEW") (cons 341 (car (entsel)))))                                          ;
; =========================================================================================== ;
(defun cd:DCT_ReplaceXrecord (Ename Data / en root name)
  (setq root (cdr (assoc 330 (entget Ename)))
        name (cdr
               (assoc
                 Ename
                 (mapcar
                   (function
                     (lambda (%)
                       (cons (cdr %) (car %))
                     )
                   )
                   (cd:DCT_GetDictList root T)
                 )
               )
             )
  )
  (if (cd:DCT_RemoveDict root name)
    (progn
      (setq en (cd:DCT_AddXrecord root name Data))
      (cd:DCT_GetXRecord en)
    )
  )
)
; =========================================================================================== ;
; Zmienia Xrecord / Change Xrecord                                                            ;
;  Ename [ENAME] - nazwa entycji / entity name                                                ;
;  Data  [LIST]  - lista par kropkowych / list of dotted pairs                                ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCT_SetXrecordVLA                                                                       ;
;   (cdar (cd:DCT_GetDictList (cd:DCT_GetDict (namedobjdict) "NAZWA") T))                     ;
;   (list (cons 1 "NEW123") (cons 341 (car (entsel)))))                                       ;
; =========================================================================================== ;
(defun cd:DCT_SetXrecordVLA (Ename Data / n)
  (setq n (1- (length Data)))
  (vla-SetXRecordData
    (vlax-ename->vla-object Ename)
    (vlax-make-variant
      (vlax-safearray-fill
        (vlax-make-safearray
          vlax-vbInteger
          (cons 0 n)
        )
        (mapcar (quote car) Data)
      )
    )
    (vlax-make-variant
      (vlax-safearray-fill
        (vlax-make-safearray
          vlax-vbVariant
          (cons 0 n)
        )
        (mapcar
          (function
            (lambda (% / %1)
              (setq %1 (type %))
              (cond
                ( (= %1 (quote ENAME)) (vlax-ename->vla-object %))
                ( (= %1 (quote LIST)) (vlax-3d-point %))
                (T %)
              )
            )
          )
          (mapcar (quote cdr) Data)
        )
      )
    )
  )
  (cd:DCT_GetXRecord Ename)
)
; =========================================================================================== ;
; Dodaje wlasciwosci uzytkownika / Add custom drawing properties                              ;
;  Doc   [VLA-Object] - document / document                                                   ;
;  Name  [STR]   - nazwa / name                                                               ;
;  Value [STR]   - wartosc / value                                                            ;
;  Mode  [T/nil] - nil = nieaktualizuje istniejacej nazwy / do not updates exisitng name      ;
;                  T   = aktualizuje istniejaca nazwe / updates exisitng name                 ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DWG_AddCustomProp (cd:ACX_ADoc) "One" "1" nil)                                          ;
; =========================================================================================== ;
(defun cd:DWG_AddCustomProp (Doc Name Value Mode / si)
  (setq si (vla-get-SummaryInfo Doc))
  (if (member Name (mapcar (quote car) (cd:DWG_GetCustomProp Doc)))
    (if Mode (vla-SetCustomByKey si Name Value))
    (vla-AddCustomInfo si Name Value)
  )
)
; =========================================================================================== ;
; Lista wlasciwosci uzytkownika / Custom drawing properties                                   ;
;  Doc [VLA-Object] - document / document                                                     ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DWG_GetCustomProp (cd:ACX_ADoc))                                                        ;
; =========================================================================================== ;
(defun cd:DWG_GetCustomProp (Doc / si n k v lst)
  (setq si (vla-get-SummaryInfo Doc)
        n (vla-NumCustomInfo si)
  )
  (while (> n 0)
    (vla-GetCustomByIndex si (- n 1) 'k 'v)
    (setq lst (cons (cons k v) lst)
          n (1- n)
    )
  )
  lst
)
; =========================================================================================== ;
; Lista otwartych dokumentow / Open documents list                                            ;
; =========================================================================================== ;
(defun cd:DWG_GetOpenDocs (/ res)
  (vlax-for %
    (vla-get-documents (vlax-get-acad-object))
    (setq res
      (cons
        (cons
          (vla-get-name %)
          %
        )
        res
      )
    )
  )
)
; =========================================================================================== ;
; Lista wlasciwosci dokumentu / Summary drawing properties list                               ;
;  Doc [VLA-Object] - document / document                                                     ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DWG_GetSummaryInfo (cd:ACX_ADoc))                                                       ;
; =========================================================================================== ;
(defun cd:DWG_GetSummaryInfo (Doc)
  (mapcar
    (function
      (lambda (%)
        (cons
          %
          (vlax-get-property
            (vla-get-SummaryInfo Doc)
            %
          )
        )
      )
    )
    (list
      "Author" "Comments" "HyperLinkBase" "Keywords"
      "LastSavedBy" "RevisionNumber" "Subject" "Title"
    )
  )
)
; =========================================================================================== ;
; Zmiana nazwy arkusza na obiekt VLA / Convert layout name to VLA-Object                      ;
;  Layout [STR] - nazwa arkusza / layout tab name                                             ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DWG_Layout2VLA (getvar "CTAB"))                                                         ;
; =========================================================================================== ;
(defun cd:DWG_Layout2VLA (Layout / res)
  (and
    (member Layout (layoutlist))
    (setq res
      (vla-item
        (cd:ACX_Layouts)
        Layout
      )
    )
  )
  res
)
; =========================================================================================== ;
; Lista arkuszy rysunku / Layouts drawing list                                                ;
; =========================================================================================== ;
(defun cd:DWG_LayoutsList (/ res)
  (vlax-for %
    (cd:ACX_Layouts)
    (setq res
      (cons
        (list
          (vla-get-name %)
          (vla-get-TabOrder %)
          %
        )
        res
      )
    )
  )
)
; =========================================================================================== ;
; Usuwa wlasciwosci uzytkownika / Removes custom drawing properties                           ;
;  Doc  [VLA-Object] - document / document                                                    ;
;  Mode [LIST/T] - LIST = lista wlasciwosci do usuniecia / list of properties to remove       ;
;                  T    = usuwa wszystkie wlasciwosci / removes all properites                ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DWG_RemoveCustomProp (cd:ACX_ADoc) (list "One" "Two"))                                  ;
; =========================================================================================== ;
(defun cd:DWG_RemoveCustomProp (Doc Mode / si)
  (setq si (vla-get-SummaryInfo Doc))
  (if (listp Mode)
    (foreach % Mode
      (vl-catch-all-apply
        (quote vla-RemoveCustomByKey)
        (list si %)
      )
    )
    (foreach % (mapcar (quote car) (cd:DWG_GetCustomProp Doc))
      (vla-RemoveCustomByKey si %)
    )
  )
)
; =========================================================================================== ;
; Zmiana wlasciwosci dokumentu / Set summary drawing properties                               ;
;  Doc  [VLA-Object] - document / document                                                    ;
;  Data [LIST/nil] - LIST = lista par kropkowych / list of dotted pairs                       ;
;                    nil  = usuwa wszystkie / delete all                                      ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DWG_SetSummaryInfo (cd:ACX_ADoc) '(("Author" . "Me")("Title" . "123-ABC-55")))          ;
; =========================================================================================== ;
(defun cd:DWG_SetSummaryInfo (Doc Data / si)
  (setq si (vla-get-SummaryInfo Doc))
  (if (not Data)
    (mapcar
      (function
        (lambda (%)
          (vlax-put-property si % "")
        )
      )
      (list
        "Author" "Comments" "HyperLinkBase" "Keywords"
        "LastSavedBy" "RevisionNumber" "Subject" "Title"
      )
    )
    (mapcar
      (function
        (lambda (%)
          (if
            (vlax-property-available-p si (car %))
            (vlax-put-property si (car %) (cdr %))
          )
        )
      )
      Data
    )
  )
  nil
)
; =========================================================================================== ;
; Zwraca wartosc danego klucza z listy asocjacyjnej /                                         ;
; Returns the value of a key from assoc list                                                  ;
;  Key  [INT]  - klucz / key                                                                  ;
;  Data [LIST] - lista par kropkowych / list of dotted pairs                                  ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DXF_Massoc 10 (entget (car (entsel))))                                                  ;
; =========================================================================================== ;
(defun cd:DXF_Massoc (Key Data / res tmp)
  (while
    (setq Data (member (setq tmp (assoc Key Data)) Data))
    (setq res (cons (cdr tmp) res)
          Data (cdr Data)
    )
  )
  (reverse res)
)
; =========================================================================================== ;
; Usuwa kody z listy DXF / Removes codes from the list of DXF                                 ;
;  Data [LIST] - lista par kropkowych / list of dotted pairs                                  ;
;  Lst  [LIST] - lista kodow do usuniecia / list of codes to be removed                       ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DXF_RemoveDXF (entget (entlast)) (list -1 3 5 102 330 360 440))                         ;
; =========================================================================================== ;
(defun cd:DXF_RemoveDXF (Data Lst)
  (vl-remove-if
    (function
      (lambda (%)
        (member (car %) Lst)
      )
    )
    Data
  )
)
; =========================================================================================== ;
; Sprawdza poprawnosc nazwanego obiektu / Checks the correctness of the named object          ;
;  Table [STR] - nazwa obiektu / object name                                                  ;
;  Name  [STR] - nazwa do sprawdzenia / name to check                                         ;
; ------------------------------------------------------------------------------------------- ;
; Zwraca / Return:                                                                            ;
;   0 = obiekt nie istnieje / object does not exist                                           ;
;  -1 = zla nazwa / bad name                                                                  ;
;   1 = obiekt istnieje / object exists                                                       ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_CheckTableObj "LAYER" "0"), (cd:ENT_CheckTableObj "BLOCK" "nazwa")                  ;
; =========================================================================================== ;
(defun cd:ENT_CheckTableObj (Table Name)
  (if (not (tblobjname Table Name))
    (if (snvalid Name 0)
       0
      -1
    )
    1
  )
)
; =========================================================================================== ;
; Tworzy obiekt typu ARC / Creates a ARC object                                               ;
;  Layout [STR]   - nazwa arkusza / layout tab name                                           ;
;  Pc     [LIST]  - srodek luku / center of the arc                                           ;
;  Radius [REAL]  - promien / radius                                                          ;
;  As     [REAL]  - kat poczatkowy w radianach / start angle in radians                       ;
;  Ae     [REAL]  - kat koncowy w radianach / end angle in radians                            ;
;  ActUcs [T/nil] - dopasuj do aktywnego ucs / adjust to active ucs                           ;
;                   nil = nie / no                                                            ;
;                   T   = tak / yes                                                           ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_MakeArc "Model" '(1 5 0) 5 0 pi T)                                                  ;
; =========================================================================================== ;
(defun cd:ENT_MakeArc (Layout Pc Radius As Ae ActUcs / zdir xang)
  (setq zdir (trans (list 0 0 1) 1 0 T)
        xang (angle (list 0 0 0) (trans (getvar "UCSXDIR") 0 zdir))
  )
  (entmakex
    (list
      (cons 0 "ARC")
      (cons 10 (trans Pc 1 (if ActUcs zdir 0)))
      (cons 40 Radius)
      (cons 50 (+ As xang))
      (cons 51 (+ Ae xang))
      (if ActUcs
        (cons 210 zdir)
        (cons 210 (list 0 0 1))
      )
      (cons 410 Layout)
    )
  )
)
; =========================================================================================== ;
; Tworzy koniec definicji bloku / Creates a block definition end                              ;
; =========================================================================================== ;
(defun cd:ENT_MakeBlockEnd ()
  (entmake
    (list
      (cons 0 "ENDBLK")
      (cons 8 "0")
    )
  )
)
; =========================================================================================== ;
; Tworzy poczatek definicji bloku / Creates a block definition head                           ;
;  Name [STR]  - nazwa bloku / block name                                                     ;
;  Pb   [LIST] - punkt bazowy bloku / block base point                                        ;
;  Flag [INT]  - typ bloku (bit-kody, mozna laczyc) / block type (bit-codes, may be combined) ;
;                0 = standardowy block / standard block                                       ;
;                1 = blok anonimowy / anonymous block                                         ;
;                2 = definicje atrybutow (nie-stale) / attribute definitions (non-constant)   ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_MakeBlockHead "NOWY" (list 0 0 0) 0), (cd:ENT_MakeBlockHead "*U" (list 0 0 0) 1)    ;
; =========================================================================================== ;
(defun cd:ENT_MakeBlockHead (Name Pb Flag)
  (entmakex
    (list
      (cons 0 "BLOCK")
      (cons 2 Name)
      (cons 8 "0")
      (cons 10 Pb)
      (cons 70
        (if (member Flag (list 0 1 2 3))
          Flag
          0
        )
      )
    )
  )
)
; =========================================================================================== ;
; Tworzy obiekt typu CIRCLE / Creates a CIRCLE object                                         ;
;  Layout [STR]   - nazwa arkusza / layout tab name                                           ;
;  Pc     [LIST]  - srodek okregu / center of the circle                                      ;
;  Radius [REAL]  - promien / radius                                                          ;
;  ActUcs [T/nil] - dopasuj do aktywnego ucs / adjust to active ucs                           ;
;                   nil = nie / no                                                            ;
;                   T   = tak / yes                                                           ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_MakeCircle "Model" '(1 5 0) 5 T)                                                    ;
; =========================================================================================== ;
(defun cd:ENT_MakeCircle (Layout Pc Rad ActUcs / zdir)
  (setq zdir (trans (list 0 0 1) 1 0 T))
  (entmakex
    (list
      (cons 0 "CIRCLE")
      (cons 10 (trans Pc 1 (if ActUcs zdir 0)))
      (cons 40 Rad)
      (if ActUcs
        (cons 210 zdir)
        (cons 210 (list 0 0 1))
      )
      (cons 410 Layout)
    )
  )
)
; =========================================================================================== ;
; Tworzy obiekt typu ELLIPSE / Creates a ELLIPSE object                                       ;
;  Layout [STR]   - nazwa arkusza / layout tab name                                           ;
;  Pc     [LIST]  - srodek elipsy / center of the ellipse                                     ;
;  Width  [REAL]  - szerokosc / width                                                         ;
;  Height [REAL]  - wysokosc / height                                                         ;
;  RotAng [REAL]  - kat obrotu / rotation angle                                               ;
;  ActUcs [T/nil] - dopasuj do aktywnego ucs / adjust to active ucs                           ;
;                   nil = nie / no                                                            ;
;                   T   = tak / yes                                                           ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_MakeEllipse "Model" '(1 5 0) 10.0 5.0 (* pi 0.25) T)                                ;
; =========================================================================================== ;
(defun cd:ENT_MakeEllipse (Layout Pc Width Height RotAng ActUcs / zdir xang)
  (setq zdir (trans (list 0 0 1) 1 0 T)
        xang (angle (list 0 0 0) (trans (getvar "UCSXDIR") 0 zdir))
  )
  (entmakex
    (list
      (cons 0 "ELLIPSE")
      (cons 100 "AcDbEntity")
      (cons 100 "AcDbEllipse")
      (cons 10 (trans Pc 1 0))
      (if ActUcs
        (cons 11 (trans (polar (trans (list 0 0 0) 0 1) RotAng (/ Width 2.0)) 1 0))
        (cons 11 (polar (list 0 0 0) (+ RotAng xang) (/ Width 2.0)))
      )
      (cons 40 (/ (float Height)(float Width)))
      (if ActUcs
        (cons 210 zdir)
        (cons 210 (list 0 0 1))
      )
      (cons 410 Layout)
    )
  )
)
; =========================================================================================== ;
; Tworzy nowa warstwe / Creates a new layers                                                  ;
;  Name [STR] - nazwa warstwy / layer name                                                    ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_MakeLayer "ABC")                                                                    ;
; =========================================================================================== ;
(defun cd:ENT_MakeLayer (Name / en)
  (if (setq en (tblobjname "LAYER" Name))
    en
    (entmakex
      (list
        (cons 0 "LAYER")
        (cons 100 "AcDbSymbolTableRecord")
        (cons 100 "AcDbLayerTableRecord")
        (cons 2 Name)
        (cons 70 0)
      )
    )
  )
)
; =========================================================================================== ;
; Tworzy obiekt typu LINE / Creates a LINE object                                             ;
;  Layout [STR]   - nazwa arkusza / layout tab name                                           ;
;  Ps     [LIST]  - punkt poczatkowy / start point                                            ;
;  Pe     [LIST]  - punkt koncowy / end point                                                 ;
;  ActUcs [T/nil] - dopasuj do aktywnego ucs / adjust to active ucs                           ;
;                   nil = nie / no                                                            ;
;                   T   = tak / yes                                                           ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_MakeLine "Model" '(20 10 0) '(100 50 0) T)                                          ;
; =========================================================================================== ;
(defun cd:ENT_MakeLine (Layout Ps Pe ActUcs / zdir)
  (setq zdir (trans (list 0 0 1) 1 0 T))
  (entmakex
    (list
      (cons 0 "LINE")
      (cons 10 (trans Ps 1 0))
      (cons 11 (trans Pe 1 0))
      (if ActUcs
        (cons 210 zdir)
        (cons 210 (list 0 0 1))
      )
      (cons 410 Layout)
    )
  )
)
; =========================================================================================== ;
; Tworzy obiekt typu LWPOLYLINE / Creates a LWPOLYLINE object                                 ;
;  Layout [STR]   - nazwa arkusza / layout tab name                                           ;
;  Pts    [LIST]  - lista wierzcholkow polilinii / list of polyline vertex                    ;
;  Closed [T/nil] - nil = otwarta / open                                                      ;
;                   T   = zamknieta / closed                                                  ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_MakeLWPolyline "Model" (list '(5 5) '(15 5) '(15 10) '(10 10)) nil)                 ;
; =========================================================================================== ;
(defun cd:ENT_MakeLWPolyline (Layout Pts Closed / zdir)
  (setq zdir (trans '(0 0 1) 1 0 T))
  (entmakex
    (append
      (list
        (cons 0 "LWPOLYLINE")
        (cons 100 "AcDbEntity")
        (cons 100 "AcDbPolyline")
        (cons 38 (caddr (trans (car Pts) 1 zdir)))
        (cons 90 (length Pts))
        (cons 70 (if Closed 1 0))
        (cons 210 zdir)
        (cons 410 Layout)
      )
      (mapcar
        (function
          (lambda (%)
            (cons 10 (trans % 1 zdir))
          )
        )
        Pts
      )
    )
  )
)
; =========================================================================================== ;
; Tworzy obiekt typu ACAD_TABLE / Creates a ACAD_TABLE object                                 ;
;  Pb   [LIST] - punkt bazowy tabeli / table base point                                       ;
;  Rows [INT]  - liczba wierszy / number of rows                                              ;
;  Cols [INT]  - liczba kolumn / number of columns                                            ;
;  RowH [INT]  - wysokosc wierszy / rows height                                               ;
;  ColH [INT]  - szerokosc kolumn / columns height                                            ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_MakeTable (getpoint) 5 5 10 30)                                                     ;
; =========================================================================================== ;
(defun cd:ENT_MakeTable (Pb Rows Cols RowH ColH / r c)
  (entmakex
    (append
      (list
        (cons 0 "ACAD_TABLE")
        (cons 100 "AcDbEntity")
        (cons 100 "AcDbBlockReference")
        (cons 10 (trans Pb 1 0))
        (cons 100 "AcDbTable")
        (cons 91 Rows)
        (cons 92 Cols)
      )
      (repeat Rows (setq r (cons (cons 141 RowH) r)))
      (repeat Cols (setq c (cons (cons 142 ColH) c)))
    )
  )
)
; =========================================================================================== ;
; Tworzy obiekt typu TEXT / Creates a TEXT object                                             ;
;  Layout [STR]  - nazwa arkusza / layout tab name                                            ;
;  Str    [STR]  - lancuch tekstowy / string                                                  ;
;  Pb     [LIST] - punkt bazowy / base point                                                  ;
;  Height [REAL] - wysokosc / height                                                          ;
;  Rot    [REAL] - kat obrotu w radianach / rotation angle in radians                         ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_MakeText "Model" "NEW_TEXT" '(20 10 0) 1.5 (/ pi 4))                                ;
; =========================================================================================== ;
(defun cd:ENT_MakeText (Layout Str Pb Height Rot / zdir xang)
  (setq zdir (trans '(0 0 1) 1 0 T)
        xang (angle '(0 0 0) (trans (getvar "UCSXDIR") 0 zdir))
  )
  (entmakex
    (list
      (cons 0 "TEXT")
      (cons 1 Str)
      (cons 10 (trans Pb 1 zdir))
      (cons 40 Height)
      (cons 50 (+ Rot xang))
      (cons 210 zdir)
      (cons 410 Layout)
    )
  )
)
; =========================================================================================== ;
; Tworzy nowy stylu tekstu / Creates a new text style                                         ;
;  Name [STR] - nazwa stylu tekstu / text style name                                          ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_MakeTextStyle "ABC")                                                                ;
; =========================================================================================== ;
(defun cd:ENT_MakeTextStyle (Name / en)
  (if (setq en (tblobjname "STYLE" Name))
    en
    (entmakex
      (list
        (cons 0 "STYLE")
        (cons 100 "AcDbSymbolTableRecord")
        (cons 100 "AcDbTextStyleTableRecord")
        (cons 2 Name)
        (cons 70 0)
      )
    )
  )
)
; =========================================================================================== ;
; Tworzy obiekt typu XLINE / Creates a XLINE object                                           ;
;  Layout [STR]       - nazwa arkusza / layout tab name                                       ;
;  Ps     [LIST]      - punkt poczatkowy / start point                                        ;
;  Pe     [LIST/REAL] - punkt koncowy lub kat w radianach / end point or angle in radians     ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_MakeXline "Model" (getpoint) (/ pi 4))                                              ;
; =========================================================================================== ;
(defun cd:ENT_MakeXline (Layout Ps Pe)
  (entmakex
    (list
      (cons 0 "XLINE") 
      (cons 100 "AcDbEntity") 
      (cons 100 "AcDbXline") 
      (cons 10 (trans Ps 1 0)) 
      (cons 11
        (cond
          ( (numberp Pe)
             (trans (polar (trans '(0 0 0) 0 1) Pe 1) 1 0)
          )
          ( (listp Pe)
             (trans (polar '(0 0 0) (angle Ps Pe) 1) 1 0 T)
          )
        )
      )
      (cons 410 Layout)
    )
  )
)
; =========================================================================================== ;
; Zmiana podstawowych cech obiektu / Set basic object properties                              ;
;  Ename   [ENAME] - nazwa entycji / entity name                                              ;
;  Layer   [STR]   - nazwa warstwy / layer name                                               ;
;  Color   [INT]   - kolor warstwy / layer color                                              ;
;  LType   [STR]   - typ linii / linetype                                                     ;
;  LScale  [REAL]  - skala linii / linetype scale                                             ;
;  LWeight [INT]   - szerokosc linii / lineweight                                             ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_SetBasicDXF (entlast) "NOWA" 21 "CONTINUOUS" 1.5 13)                                ;
; =========================================================================================== ;
(defun cd:ENT_SetBasicDXF (Ename Layer Color LType LScale LWeight / dt)
  (setq dt (entget Ename))
  (mapcar
    (function
      (lambda (%1 %2)
        (setq dt
          (if %2
            (if
              (not (assoc %1 dt))
              (append dt (list (cons %1 %2)))  
              (subst
                (cons %1 %2)
                (assoc %1 dt)
                dt
              )
            )
            dt
          )
        )
      )
    )
    (list 8 62 6 48 370)
    (list Layer Color LType LScale LWeight)
  )
  (entmod dt)
)
; =========================================================================================== ;
; Zmiana danych DXF obiektu / Set the DXF data of object                                      ;
;  Ename [ENAME] - nazwa entycji / entity name                                                ;
;  Code  [INT]   - kod pary DXF / code of dotted pair                                         ;
;  Val   [LIST/INT/REAL/STR/ENAME] - wartosc / value                                          ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ENT_SetDXF (entlast) 70 129)                                                            ;
; =========================================================================================== ;
(defun cd:ENT_SetDXF (Ename Code Val / dt new)
  (setq new
    (if (not (assoc Code (setq dt (entget Ename))))
      (append dt (list (cons Code Val)))
      (subst
        (cons Code Val)
        (assoc Code dt)
        dt
      )
    )
  )
  (entmod new)
)
; =========================================================================================== ;
; Wstawia nowy element na liste / Inserts a new item in the list                              ;
;  Pos [INT]  - pozycja elementu / element position                                           ;
;  Lst [LIST] - lista wejsciowa / input list                                                  ;
;  New [LIST/INT/REAL/STR/ENAME] - nowy element / new item                                    ;
; ------------------------------------------------------------------------------------------- ;
; (cd:LST_InsertItem 3 (list 0 1 2 4 5) 3)                                                    ;
; =========================================================================================== ;
(defun cd:LST_InsertItem (Pos Lst New / res)
  (if (< -1 Pos (1+ (length Lst)))
    (progn
      (repeat Pos
        (setq res (cons (car Lst) res)
              Lst (cdr Lst)
        )
      )
      (append (reverse res) (list New) Lst)
    )
    Lst
  )
)
; =========================================================================================== ;
; Lista wystapien elementu na liscie / List of occurrences item in the list                   ;
;  Item [INT]  - element / element                                                            ;
;  Lst  [LIST] - lista wejsciowa / input list                                                 ;
; ------------------------------------------------------------------------------------------- ;
; (cd:LST_ItemPosition 1 (list 0 "a" 1 "b" 3 1))                                              ;
; =========================================================================================== ;
(defun cd:LST_ItemPosition (Item Lst / n p res)
  (setq n -1)
  (while
    (and
      (setq p (vl-position Item Lst))
      (setq n (+ (1+ n) p)
            res (cons n res)
            Lst (cdr (member Item Lst))
      )
    )
  )
  (reverse res)
)
; =========================================================================================== ;
; Przesuwa element o jedna pozycje w dol / Moves item one position down                       ;
;  Pos [INT]  - pozycja elementu / element position                                           ;
;  Lst [LIST] - lista wejsciowa / input list                                                  ;
; ------------------------------------------------------------------------------------------- ;
; (cd:LST_MoveItemDown 3 (list 0 1 2 3 4 5))                                                  ;
; =========================================================================================== ;
(defun cd:LST_MoveItemDown (Pos Lst / n)
  (setq n -1)
  (cond
    (
      (or
        (< Pos 0)
        (>= Pos (1- (length Lst)))
      )
      Lst
    )
    ( (mapcar
        (function
          (lambda (%)
            (setq n (1+ n))
            (cond
              ( (= n Pos)
                (nth (1+ Pos) Lst)
              )
              ( (= n (1+ Pos))
                (nth Pos Lst)
              )
              (%)
            )
          )
        )
        Lst
      )
    )
  )
)
; =========================================================================================== ;
; Przesuwa element na ostatnia pozycje / Moves item to the last position                      ;
;  Pos [INT]  - pozycja elementu / element position                                           ;
;  Lst [LIST] - lista wejsciowa / input list                                                  ;
; (cd:LST_MoveItemToBottom 3 (list 0 1 2 3 4 5))                                              ;
; =========================================================================================== ;
(defun cd:LST_MoveItemToBottom (Pos Lst)
  (cond
    (
      (or
        (< Pos 0)
        (>= Pos (1- (length Lst)))
      )
      Lst
    )
    ( (append
        (cd:LST_RemoveItem Pos Lst)
        (list (nth Pos Lst))
      )
    )
  )
)
; =========================================================================================== ;
; Przesuwa element na pozycje 0 / Moves item to the 0th position                              ;
;  Pos [INT]  - pozycja elementu / element position                                           ;
;  Lst [LIST] - lista wejsciowa / input list                                                  ;
; ------------------------------------------------------------------------------------------- ;
; (cd:LST_MoveItemToTop 3 (list 0 1 2 3 4 5))                                                 ;
; =========================================================================================== ;
(defun cd:LST_MoveItemToTop (Pos Lst)
  (cond
    (
      (or
        (<= Pos 0)
        (>= Pos (length Lst))
      )
      Lst
    )
    ( (append
        (list (nth Pos Lst))
        (cd:LST_RemoveItem Pos Lst)
      )
    )
  )
)
; =========================================================================================== ;
; Przesuwa element o jedna pozycje w gore / Moves item one position up                        ;
;  Pos [INT]  - pozycja elementu / element position                                           ;
;  Lst [LIST] - lista wejsciowa / input list                                                  ;
; ------------------------------------------------------------------------------------------- ;
; (cd:LST_MoveItemUp 3 (list 0 1 2 3 4 5))                                                    ;
; =========================================================================================== ;
(defun cd:LST_MoveItemUp (Pos Lst / n)
  (setq n -1)
  (cond
    (
      (or
        (zerop Pos)
        (>= Pos (length Lst))
      )
      Lst
    )
    ( (mapcar
        (function
          (lambda (%)
            (setq n (1+ n))
            (cond
              ( (= n (1- Pos))
                (nth Pos Lst)
              )
              ( (= n Pos)
                (nth (1- Pos) Lst)
              )
              (%)
            )
          )
        )
        Lst
      )
    )
  )
)
; =========================================================================================== ;
; Usuwa element z listy / Removes the item from the list                                      ;
;  Pos [INT]  - pozycja elementu / element position                                           ;
;  Lst [LIST] - lista wejsciowa / input list                                                  ;
; ------------------------------------------------------------------------------------------- ;
; (cd:LST_RemoveItem 3 (list 0 1 2 3 4 5))                                                    ;
; =========================================================================================== ;
(defun cd:LST_RemoveItem (Pos Lst)
  (vl-remove-if
    (function
      (lambda (%)
        (= -1 (setq Pos (1- Pos)))
      )
    )
    Lst
  )
)
; =========================================================================================== ;
; Zastepuje element na liscie / Replaces the item on the list                                 ;
;  Pos [INT]  - pozycja elementu / element position                                           ;
;  Lst [LIST] - lista wejsciowa / input list                                                  ;
;  New [LIST/INT/REAL/STR/ENAME] - nowy element / new item                                    ;
; ------------------------------------------------------------------------------------------- ;
; (cd:LST_ReplaceItem 3 (list 0 1 2 3 4 5) "c")                                               ;
; =========================================================================================== ;
(defun cd:LST_ReplaceItem (Pos Lst New)
  (mapcar
    (function
      (lambda (%)
        (cond
          ( (= -1 (setq Pos (1- Pos)))
            New
          )
          (%)
        )
      )
    )
    Lst
  )
)
; =========================================================================================== ;
; Zamienia elementy miejscami / Reverse the elements in places                                ;
;  Pos1 [INT]  - pozycja 1-go elementu / first element position                               ;
;  Pos2 [INT]  - pozycja 2-go elementu / second element position                              ;
;  Lst  [LIST] - lista wejsciowa / input list                                                 ;
; ------------------------------------------------------------------------------------------- ;
; (cd:LST_ReverseItems 0 5 (list 0 1 2 3 4 5))                                                ;
; =========================================================================================== ;
(defun cd:LST_ReverseItems (Pos1 Pos2 Lst / n)
  (setq n -1)
  (cond
    (
      (or
        (< Pos1 0)
        (< Pos2 0)
        (>= Pos1 (length Lst))
        (>= Pos2 (length Lst))
      )
      Lst
    )
    ( (mapcar
        (function
          (lambda (%)
            (setq n (1+ n))
            (cond
              ( (= n Pos1)
                (nth Pos2 Lst)
              )
              ( (= n Pos2)
                (nth Pos1 Lst)
              )
              (%)
            )
          )
        )
        Lst
      )
    )
  )
)
; =========================================================================================== ;
; Zmienia PICKSET na liste obiektow / Convert PICKSET to list of objects                      ;
;  Ss   [PICKSET] - zbior wskazan / selection sets                                            ;
;  Mode [INT]     - typ zwracanych obiektow / type of returned objects                        ;
;                   0 = ENAME, 1 = VLA-OBJECT, 2 = SAFEARRAY                                  ;
; =========================================================================================== ;
; (cd:SSX_Convert (ssget) 1)                                                                  ;
; =========================================================================================== ;
(defun cd:SSX_Convert (Ss Mode / n res)
  (if
    (and
      (member Mode (list 0 1 2))
      (not
        (minusp
          (setq n
            (if Ss (1- (sslength Ss)) -1)
          )
        )
      )
    )
    (progn
      (while (>= n 0)
        (setq res
          (cons
            (if (zerop Mode)
              (ssname Ss n)
              (vlax-ename->vla-object (ssname Ss n))
            )
            res
          )
              n (1- n)
        )
      )
      (if (= Mode 2)
        (vlax-safearray-fill
          (vlax-make-safearray 9
            (cons 0 (1- (length res)))
          ) res
        )
        res
      )
    )
  )
)
; =========================================================================================== ;
; Liczba wystapien znaku / Number of occurrences of a character                               ;
;  Str  [STR] - lancuch tekstowy / string                                                     ;
;  Char [STR] - znak / character                                                              ;
; ------------------------------------------------------------------------------------------- ;
; (cd:STR_CountChar  "\"123\" \"416\" \"719\" \"A1c\"" "\"")                                  ;
; =========================================================================================== ;
(defun cd:STR_CountChar (Str Char)
  (-
    (strlen Str)
    (length
      (vl-remove
        (ascii Char)
        (vl-string->list Str)
      )
    )
  )
)
; =========================================================================================== ;
; Uzupelnia lancuch tekstowy znakami / Replaces the item on the list                          ;
;  Str  [STR]   - lancuch tekstowy / string                                                   ;
;  Char [STR]   - znak / character                                                            ;
;  Pos  [INT]   - calkowita liczba znakow / total number of characters                        ;
;  Dir  [T/nil] - kierunek uzupelniania / complement direction                                ;
;                 nil = w lewo / left                                                         ;
;                 T   = w prawo / right                                                       ;
; ------------------------------------------------------------------------------------------- ;
; (cd:STR_FillChar "12" "0" 5 nil)                                                            ;
; =========================================================================================== ;
(defun cd:STR_FillChar (Str Char Pos Dir / res)
  (setq res "")
  (repeat (- Pos (strlen Str))
    (setq res (strcat res Char))
  )
  (if Dir
    (strcat str res)
    (strcat res str)
  )
)
; =========================================================================================== ;
; Dzieli lancuch separatorem / Divide string by separator                                     ;
;  Str [STR]   - lancuch tekstowy / string                                                    ;
;  Sep [STR]   - znak rozdzielajacy / string separator                                        ;
;  Rbl [T/nil] - nil = nie usuwa pustych tekstow / don't remove empty strings                 ;
;                T   = usuwa puste teksty / remove empty strings                              ;
; ------------------------------------------------------------------------------------------- ;
; (cd:STR_Parse ";;1;2;3;;;9;" ";" nil) --> ("" "" "1" "2" "3" "" "" "9" "")                  ;
; (cd:STR_Parse ";;1;2;3;;;9;" ";" T)   --> ("1" "2" "3" "9")                                 ;
; =========================================================================================== ;
(defun cd:STR_Parse (Str Sep Rbl / el res)
  (setq el "")
  (foreach % (vl-string->list Str)
    (if (= Sep (chr %))
      (setq res (cons el res) el "")
      (setq el (strcat el (chr %)))
    )
  )
  (setq res (cons el res))
  (reverse
    (if Rbl (vl-remove "" res) res)
  )
)
; =========================================================================================== ;
; Laczy liste lancuchow w lancuch z separatorem /                                             ;
; Combines a list of strings in the string with the separator                                 ;
;  Lst [LIST] - lista lancuchow / list of strings                                             ;
;  Sep [STR]  - separator / separator                                                         ;
; ------------------------------------------------------------------------------------------- ;
; (cd:STR_ReParse '("OLE2FRAME" "IMAGE" "HATCH") ",")                                         ;
; =========================================================================================== ;
(defun cd:STR_ReParse (Lst Sep / res)
  (setq res (car Lst))
  (foreach % (cdr Lst)
    (setq res (strcat res Sep %))
  )
  res
)
; =========================================================================================== ;
; Tworzy automatyczna nazwe / Creates automatic name                                          ;
;  Tbl  [STR] - tablica symboli / table symbol                                                ;
;  Pref [STR] - prefiks / prefix                                                              ;
;  Suff [STR] - sufiks / suffix                                                               ;
;  Char [STR] - znak uzupelniajacy / supplementary sign                                       ;
;  Len  [INT] - calkowita liczba znakow / total number of characters                          ;
; ------------------------------------------------------------------------------------------- ;
; (cd:STR_TableNameAuto "BLOCK" "Front_" "_Tyl" "." 3)                                        ;
; (cd:STR_TableNameAuto "LAYER" "Pre_" nil "0" 5)                                             ;
; =========================================================================================== ;
(defun cd:STR_TableNameAuto (Tbl Pref Suff Char Len / res n)
  (foreach % (list "Pref" "Suff" "Char")
    (set (read %) (if (eval (read %)) (eval (read %)) ""))
  )
  (setq res (strcat Pref (cd:STR_FillChar "1" Char Len nil) Suff)
        n 2
  )
  (while (tblsearch Tbl res)
    (setq res (strcat Pref (cd:STR_FillChar (itoa n) Char Len nil) Suff)
          n (1+ n)
    )
  )
  res
)
; =========================================================================================== ;
; AcadInfo np. ("AutoCAD" 18.0 64 "PL")                                                       ;
; =========================================================================================== ;
(defun cd:SYS_AcadInfo (/ s v)
  (list
    (getvar "PRODUCT")
    (atof (getvar "ACADVER"))
    (if (wcmatch (strcase (getenv "PROCESSOR_ARCHITECTURE")) "*64*") 64 32)
    (if (setq s (vl-string-search "(" (setq v (ver))))
      (strcase (substr v (+ 2 s) 2))
      "??"
    )
  )
)
; =========================================================================================== ;
; Sprawdza poprawnosc dzialania funkcji / Checks proper operation of the function             ;
;  Lst [LIST] - sprawdzana funkcja z argumentami / tested the function with arguments         ;
; ------------------------------------------------------------------------------------------- ;
; (cd:SYS_CheckError (list cd:CAL_BitList "199"))                                             ;
; =========================================================================================== ;
(defun cd:SYS_CheckError (Lst / res)
  (if
    (/=
      (type
        (setq res
          (vl-catch-all-apply
            (quote (car Lst))
            (cdr Lst)
          )
        )
      )
      (quote VL-CATCH-ALL-APPLY-ERROR)
    )
    res
  )
)
; =========================================================================================== ;
; Zwraca liste obiektow wybranego typu / Returns a list of objects of the selected type       ;
;  Coll [STR] - typ obiektu / object type                                                     ;
;  Bit  [INT] - liczba calkowita (suma bitow) / integer number (sum of the bits)              ;
;               0 = bezwzglednie wszystkie / absolutely all                                   ;
;               1 = bez Model/Papier dla BLOCK i "" dla STYLE /                               ;
;                   without Model/Paper for Block and "" for STYLE                            ;
;               2 = bez anonimowych / without anonymous | BLOCK, GROUP, TABLE, VPORT          ;
;               4 = bez zaleznych od odnosnikow zewnetrznych /                                ;
;                   without dependent from external references                                ;
;               8 = bez odnosnikow zewnetrznych / without external references                 ;
;              16 = wszystkie anonimowe / all anonymous | BLOCK,GROUP,TABLE,VPORT,Model/Paper ;
;              32 = tylko odnosniki zewnetrzne / only external references                     ;
; ------------------------------------------------------------------------------------------- ;
; (cd:SYS_CollList "BLOCK" (+ 1 2 4))                                                         ;
; =========================================================================================== ;
(defun cd:SYS_CollList (Coll Bit / lst con res nam)
  (setq lst
    (list
      '("APPID" . "RegisteredApplications")
      '("BLOCK" . "Blocks")
      '("DIMSTYLE" . "DimStyles")
      '("GROUP" . "Groups")
      '("LAYER" . "Layers")
      '("LAYOUT" . "Layouts")
      '("LTYPE" . "LineTypes")
      '("MATERIAL" . "Materials")
      '("PLOTCONFIGURATION" . "PlotConfigurations")
      '("STYLE" . "TextStyles")
      '("UCS" . "UserCoordinateSystems")
      '("VIEW" . "Views")
      '("VPORT" . "ViewPorts")
    )
  )
  (if
    (member
      (setq con (strcase Coll))
      (mapcar (quote car) lst)
    )
    (vlax-for %
      (vlax-get (cd:ACX_ADoc)(cdr (assoc con lst)))
      (progn
        (setq nam (vla-get-name %))
        (cond
          ( (and
              (= 1 (logand Bit 1))
              (or
                (= "" nam)
                (and
                  (= con "BLOCK")
                  (eq (vla-get-IsLayout %) :vlax-true)
                )
              )
            )
          )
          ( (and
              (= 2 (logand Bit 2))
              (wcmatch nam "[*]@#*")
            )
          )
          ( (and
              (= 4 (logand Bit 4))
              (wcmatch nam "*|*")
            )
          )
          ( (and
              (= 8 (logand Bit 8))
              (= con "BLOCK")
              (eq (vla-get-isXRef %) :vlax-true)
            )
          )
          ( (and
              (= 16 (logand Bit 16))
              (not (wcmatch nam "[*]*"))
            )
          )
          ( (and
              (= 32 (logand Bit 32))
              (= con "BLOCK")
              (eq (vla-get-isXRef %) :vlax-false)
            )
          )
          (T (setq res (cons nam res)))
        )
      )
    )
  )
  res
)
; =========================================================================================== ;
; Wczytuje pliki lsp,fas,vlx / Loads files lsp,fas,vlx                                        ;
;  Lst [LIST]  - lista plikow / files list                                                    ;
; ------------------------------------------------------------------------------------------- ;
; (cd:SYS_FilesLoader (list "CADPL-Pack-v1.lsp" "Brak.fas" "Nawias.lsp"))                     ;
; =========================================================================================== ;
(defun cd:SYS_FilesLoader (Lst / err res)
  (foreach % Lst
    (if
      (and
        (setq err (vl-catch-all-apply (quote load) (list %)))
        (= (type err) (quote vl-catch-all-apply-error))
      )
      (setq res
        (cons
          (cons % (vl-catch-all-error-message err))
          res
        )
      )
    )
  )
  (reverse res)
)
; =========================================================================================== ;
; Lista sciezek do czcionek (Win/Acad) / List of paths to the fonts (Win/Acad)                ;
; =========================================================================================== ;
(defun cd:SYS_FontPaths ()
  (cons
    (findfile (strcat (getenv "WINDIR") "\\fonts"))
    (vl-remove-if-not
      (function
        (lambda (%)
          (wcmatch (strcase %) "*\\FONTS")
        )
      )
      (cd:STR_Parse (getvar "ACADPREFIX") ";" T)
    )
  )
)
; =========================================================================================== ;
; Zwraca date/czas systemowa(y) / Return system date/time                                     ;
;  Format [STR] -                                                                             ;
;   ----- Data / Date -----    |   ---- Czas / Time ----                                      ;
;   D       ->   5             |   H       ->   4                                             ;
;   DD      ->   05            |   HH      ->   04                                            ;
;   DDD     ->   Sat           |   MM      ->   53                                            ;
;   DDDD    ->   Saturday      |   SS      ->   17                                            ;
;   M       ->   9             |   MSEC    ->   506                                           ;
;   MO      ->   09            |   AM/PM   ->   AM or PM                                      ;
;   MON     ->   Sep           |   am/pm   ->   am or pm                                      ;
;   MONTH   ->   September     |   A/P     ->   A  or P                                       ;
;   YY      ->   89            |   a/p     ->   a  or p                                       ;
;   YYYY    ->   1989          |                                                              ;
; ------------------------------------------------------------------------------------------- ;
; (cd:SYS_GetDateTime "DDD\",\" DD MON YYYY - H:MMam/pm")                                     ;
; =========================================================================================== ;
(defun cd:SYS_GetDateTime (Format)
  (menucmd (strcat "m=$(edtime,$(getvar,DATE)," Format ")"))
)
; =========================================================================================== ;
; Lista symboli LISP-a / LISPs symbols list                                                   ;
; ------------------------------------------------------------------------------------------- ;
; (cd:SYS_GetSymbols "cd:")                                                                   ;
; =========================================================================================== ;
(defun cd:SYS_GetSymbols (Str / res)
  (if
    (setq res
      (vl-remove-if
        (function
          (lambda (%)
            (if (not Str)
              (/= (strcase (substr % 1 4)) "*CD-")
              (/= (strcase (substr % 1 (strlen Str))) (strcase Str))
            )
          )
        )
        (atoms-family 1)
      )
    )
    (mapcar
      (function
        (lambda (%)
          (cons % (vl-symbol-value (read %)))
        )
      )
      (vl-sort res (quote <))
    )
    nil
  )
)
; =========================================================================================== ;
; Standardowe okno komunikatu / Standard message box                                          ;
;  Msg   [STR]           - komunikat do wyswietlenia / message to display                     ;
;  Title [STR]           - tytul okna / window title                                          ;
;  Btn   [0/1/2/3/4/5/6] - przyciski / buttons                                                ;
;  Icon  [16/32/48/64]   - wyswietlany symbolu / displayed symbol                             ;
; ------------------------------------------------------------------------------------------- ;
; Typy przyciskow / Buttons type:                                                             ;
;  0  = OK                              / OK                                                  ;
;  1  = OK i Anuluj                     / OK and Cancel                                       ;
;  2  = Przerwij, Ponow probe i Ignoruj / Abort, Retry and Ignore                             ;
;  3  = Tak, Nie i Anuluj               / Yes, No and Cancel                                  ;
;  4  = Tak i Nie                       / Yes and No                                          ;
;  5  = Ponow probe i Anuluj            / Retry and Cancel                                    ;
;  6  = Anuluj, Ponow probe Kontynuuj   / Cancel, Try Again and Continue                      ;
; ------------------------------------------------------------------------------------------- ;
; Wyswietlany symbol / Displayed symbol:                                                      ;
;  16 = "Stop"       [X] / "Stop"                                                             ;
;  32 = "Pytanie"    [?] / "Question"                                                         ;
;  48 = "Uwaga"      [!] / Show "Exclamation"                                                 ;
;  64 = "Informacja" [i] / Show "Information"                                                 ;
; ------------------------------------------------------------------------------------------- ;
; Zwraca / Return:                                                                            ;
;  1  = OK          / OK                                                                      ;
;  2  = Anuluj      / Cancel                                                                  ;
;  3  = Przerwij    / Abort                                                                   ;
;  4  = Ponow probe / Retry       | Btn = 2,5                                                 ;
;  5  = Ignoruj     / Ignore                                                                  ;
;  6  = Tak         / Yes                                                                     ;
;  7  = Nie         / No                                                                      ;
;  10 = Ponow probe / Try Again   | Btn = 6                                                   ;
;  11 = Kontynuuj   / Continue                                                                ;
; ------------------------------------------------------------------------------------------- ;
; (cd:SYS_MsgBox "Komunikat\nw 2 liniach" "Uwaga" 0 64)                                       ;
; =========================================================================================== ;
(defun cd:SYS_MsgBox (Msg Title Btn Icon / WSs res)
  (setq WSs (vlax-create-object "WScript.Shell")
        Icon (if (member Icon (list 16 32 48 64)) Icon 0)
        Btn (if (member Btn (list 0 1 2 3 4 5 6)) Btn 0)
  )
  (setq res
    (vlax-invoke-method WSs "Popup"
      (if (not Msg) "" Msg)
      0
      (if (not Title) "" Title)
      (+ Btn Icon 4096)
    )
  )
  (vlax-release-object WSs)
  res
)
; =========================================================================================== ;
; Czyta plik tekstowy / Read a text file                                                      ;
; Line [INT/nil] - INT = numer linii pliku / file line number                                 ;
;                  nil = caly plik / all lines of file                                        ;
; File [STR]     - nazwa pliku (krotka lub ze sciezka) / short or full path file name         ;
; ------------------------------------------------------------------------------------------- ;
; Zwraca / Return:                                                                            ;
;   nil = gdy Line = INT wieksze niz ilosc linii w pliku lub plik jest pusty /                ;
;         when Line = INT is greater then number of lines in file or file is empty            ;
;     0 = brak dostepu do pliku / no access to file                                           ;
;    -1 = nie znaleziono pliku / file not found                                               ;
;   STR = gdy Line = INT / when Line = INT                                                    ;
;  LIST = gdy Line = nil / when Line = nil                                                    ;
; ------------------------------------------------------------------------------------------- ;
; (cd:SYS_ReadFile nil "data.ini"), (cd:SYS_ReadFile 10 "acad.lin")                           ;
; =========================================================================================== ;
(defun cd:SYS_ReadFile (Line File / fn fd l res)
  (if (setq fn (findfile File))
    (if (setq fd (open fn "r"))
      (progn
        (if Line
          (progn
            (repeat Line (read-line fd))
            (setq res (read-line fd))
          )
          (progn
            (setq l T)
            (while l
              (setq res
                (cons
                  (setq l (read-line fd))
                  res
                )
              )
            )
            (setq res (reverse (cdr res)))
          )
        )
        (close fd)
      )
      (setq res 0)
    )
    (setq res -1)
  )
  res
)
; =========================================================================================== ;
; Odczyt/Zapis danych w rejestrze / Reads/Writes data to the registry                         ;
;  Key  [STR]     - klucz rejestru / registry key                                             ;
;  Name [STR]     - wartosc wpisu w rejestrze / value of a registry entry                     ;
;  Data [STR/nil] - nil = odczyt danych / read data                                           ;
;                   STR = dane do zapisu / data to write                                      ;
; =========================================================================================== ;
; (cd:SYS_RW "CADPL\\Tools\\MakeBlock" "Version" "1.0")                                       ;
; =========================================================================================== ;
(defun cd:SYS_RW (Key Name Data / loc)
  (setq loc (strcat "HKEY_CURRENT_USER\\Software\\" Key))
  (cond
    ( (and Name Data)
      (vl-registry-write loc Name Data)
    )
    ( Data
      (vl-registry-write loc nil Data)
    )
    ( T
      (vl-registry-read loc Name)
    )
  )
)
; =========================================================================================== ;
; Poczatek grupy operacji / Start of group operations                                         ;
; =========================================================================================== ;
(defun cd:SYS_UndoBegin ()
  (cd:SYS_UndoEnd)
  (vla-StartUndoMark (cd:ACX_ADoc))
)
; =========================================================================================== ;
; Koniec grupy operacji / End of group operations                                             ;
; =========================================================================================== ;
(defun cd:SYS_UndoEnd ()
  (if (= 8 (logand 8 (getvar "UNDOCTL")))
    (vla-EndUndoMark (cd:ACX_ADoc))
  )
)
; =========================================================================================== ;
; Zapisuje plik tekstowy / Writes the text file                                               ;
; Name [STR]   - nazwa pliku ze sciezka / file name with path                                 ;
; Lst  [LIST]  - lista do zapisu / list to save                                               ;
; Mode [T/nil] - tryb zapisu / save mode                                                      ;
;                nil - nadpisywanie pliku / overwrite the file                                ;
;                T   - dopisywanie do pliku / append to the file                              ;
; ------------------------------------------------------------------------------------------- ;
; (cd:SYS_WriteFile "d:\\Plik.txt" (list "linia 1" "linia 2" "linia 3") nil)                  ;
; =========================================================================================== ;
(defun cd:SYS_WriteFile (Name Lst Mode / fd)
  (if (setq fd (open Name (if Mode "a" "w")))
    (progn
      (foreach % Lst
        (write-line % fd)
      )
      (not (close fd))
    )
  )
)
; =========================================================================================== ;
; Wybiera zadane obiekty / Select a desired object                                            ;
;  Msg   [LIST]     - lista komunikatow / list of messages                                    ;
;  Obj   [LIST/nil] - LIST = lista zadanych obiektow / list of desired objects                ;
;                     nil  = wybiera dowolne obiekty / selects any objects                    ;
;  Init  [STR/nil]  - STR = slowa kluczowe / keywords                                         ;
;                     nil = bez slow kluczowych / no keywords                                 ;
;  Lock  [T/nil] - pomija obiekty na zamknietej warstwie / ignored objects in a locked layer  ;
;                  nil = tak / yes                                                            ;
;                  T   = nie / no                                                             ;
;  Enter [T/nil] - zakoncz prawy klik/spacja/enter / exit right click/space/enter             ;
;                  nil = nie / no                                                             ;
;                  T   = tak / yes                                                            ;
; ------------------------------------------------------------------------------------------- ;
; (cd:USR_EntSelObj                                                                           ;
;   (list                                                                                     ;
;     "\nWybierz blok [Opcje/Wyjdz]: " "Nalezy wskazac blok " "Nic nie wybrano "              ;
;     "To nie blok " "Obiekt na zamknietej warstwie "                                         ;
;   )                                                                                         ;
;   (list "INSERT") "Opcje Wyjdz" T nil                                                       ;
; )                                                                                           ;
; =========================================================================================== ;
(defun cd:USR_EntSelObj (Msg Obj Init Lock Enter / res)
  (while
    (progn
      (setvar "ERRNO" 0)
      (if Init (initget Init))
      (setq res (entsel (car Msg)))
      (cond
        ( (= (getvar "ERRNO") 7)
          (princ (cadr Msg))
        )
        ( (null res)
          (if Enter
            (not (princ (caddr Msg)))
            (princ (caddr Msg))
          )
        )
        ( (listp res)
          (if
            (if Obj
              (member (cdr (assoc 0 (entget (car res)))) Obj)
              T
            )
            (if Lock
              (if (vlax-write-enabled-p (car res))
                (not (setq res res))
                (princ (last Msg))
              )
              (not (setq res res))
            )
            (princ (cadddr Msg))
          )
        )
        ( (= (type res) (quote STR))
          nil
        )
        (T nil)
      )
    )
  )
  res
)
; =========================================================================================== ;
; Pobranie slowa kluczowego od uzytkownika / Get a keyword from the user                      ;
;  Msg  [STR]  - tekst zapytania / query text                                                 ;
;  Keys [LIST] - lista mozliwych slow kluczowych / list of possible keywords                  ;
;  Def  [STR]  - domyslne slowo kluczowe / default keyword                                    ;
; ------------------------------------------------------------------------------------------- ;
; (cd:USR_GetKeyWord "\nUtworz blok" '("Anonimowy" "Nazwa") "Nazwa")                          ;
; =========================================================================================== ;
(defun cd:USR_GetKeyWord (Msg Keys Def / res key)
  (setq key
    (mapcar
      (function
        (lambda (%)
          (cd:STR_ReParse Keys %)
        )
      )
      (list " " "/")
    )
  )
  (initget (car key))
  (setq res
    (vl-catch-all-apply
      (quote getkword)
      (list
        (strcat
          Msg " [" (cadr key) "] <"
          (setq Def
            (if (not (member Def Keys))
              (car Keys)
              Def
            )
          )
          ">: "
        )
      )
    )
  )
  (if res
    (if (= (type res) (quote STR)) res)
    Def
  )
)
; =========================================================================================== ;
; Pobiera punkt od uzytkownika / Gets point from user                                         ;
;  Msg [STR]      - komunikat do wyswietlenia / message to display                            ;
;  Bit [INT/nil]  - bit sterujacy (patrz initget) / control bit (see initget)                 ;
;  Pt  [LIST/nil] - punkt bazowy / base point                                                 ;
; ------------------------------------------------------------------------------------------- ;
; (cd:USR_GetPoint "\nWskaz punkt: " 1 nil)                                                   ;
; (cd:USR_GetPoint "\nWskaz drugi punkt: " 32 '(5 10 0))                                      ;
; =========================================================================================== ;
(defun cd:USR_GetPoint (Msg Bit Pt / res)
  (if Bit (initget Bit))
  (if
    (listp
      (setq res
        (vl-catch-all-apply
          (quote getpoint)
          (if Pt
            (list Pt Msg)
            (list Msg)
          )
        )
      )
    )
    res
  )
)
; =========================================================================================== ;
; Czyta dane dodatkowe XDATA / Reads additional data XDATA                                    ;
;  Ename [ENAME]   - nazwa entycji / entity name                                              ;
;  App   [STR/nil] - nil = dla wszystkich aplikacji / for all applications                    ;
;                    STR = dla aplikacji App / for App application                            ;
; ------------------------------------------------------------------------------------------- ;
; (cd:XDT_GetXData (car (entsel)) "CADPL")                                                    ;
; =========================================================================================== ;
(defun cd:XDT_GetXData (Ename App)
  (if App
    (cadr (assoc -3 (entget Ename (list App))))
    (cdr (assoc -3 (entget Ename (list "*"))))
  )
)
; =========================================================================================== ;
; Dodaje dane dodatkowe XDATA / Adds additional data XDATA                                    ;
;  Ename [ENAME] - nazwa entycji / entity name                                                ;
;  App   [STR]   - nazwa aplikacji / application name                                         ;
;  Data  [LIST]  - lista danych / data list                                                   ;
; ------------------------------------------------------------------------------------------- ;
; (cd:XDT_PutXData (car (entsel)) "CADPL" '((1000 . "X") (1070 . 5)))                         ;
; =========================================================================================== ;
(defun cd:XDT_PutXData (Ename App Data)
  (regapp App)
  (entmod
    (append
      (entget Ename)
      (list (list -3 (cons App Data)))
    )
  )
)
; =========================================================================================== ;
; Usuwa dane dodatkowe XDATA / Removes additional data XDATA                                  ;
;  Ename [ENAME] - nazwa entycji / entity name                                                ;
;  App   [STR]   - nil = z wszystkich aplikacji / from all applications                       ;
;                  STR = z aplikacji App / from App application                               ;
; ------------------------------------------------------------------------------------------- ;
; (cd:XDT_RemoveXData (car (entsel)) "CADPL")                                                 ;
; =========================================================================================== ;
(defun cd:XDT_RemoveXData (Ename App)
  (if
    (and
      App
     (cd:XDT_GetXData Ename App)
    )
    (entmod (list (cons -1 Ename) (list -3 (list App))))
    (foreach %
      (mapcar
        (quote car)
        (cd:XDT_GetXData Ename nil)
      )
      (entmod (list (cons -1 Ename) (list -3 (list %))))
    )
  )
)
; =========================================================================================== ;
(if
  (and
    (setq % (cd:SYS_ReadFile 2 "CADPL-Pack-v1.lsp"))
    (/= % -1)
  )
  (princ
    (strcat
      "\n-- CADPL-Pack-v1.lsp ("
      (substr % 6 10)
      ") - http://forum.cad.pl --"
    )
  )
  (princ "\n------- CADPL-Pack-v1.lsp - http://forum.cad.pl -------")
)
(setq % nil)
(princ)