_

[LISP] CADPL-Pack-v1.lsp [Dyskusja]

Forum poświęcone flagowemu produktowi oraz aplikacjom pochodnym Autodesku. To jedyne forum mające w tytule nazwę programu, a to ze względu na jego olbrzymią popularność w Polsce. Można tutaj umieszczać również posty z ogólnie pojętej tematyki "Kreślarskie 2D".

Re: [LISP] CADPL-Pack-v1.lsp [Dyskusja]

Postprzez kojacek » sty 17, 2012 16:40

kruuger napisał(a):mogloby byc. cza by dodac jeszce jeden argument Lng [0/1] [PL/EN]....

jest ostatni argument 0=PL 1=EN nil=sam se decyduje... :)
Kod: Zaznacz cały
;;; ======================================================================================= ;;;
; 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]       - Jezyk / Language | 0=PL 1=EN nil=(cadddr (cd:SYS_AcadInfo))         ;
; ------------------------------------------------------------------------------------------- ;
; Typy przyciskow / buttons type:                                                             ;
; 0   - Tylko OK                          /  OK button                                        ;
; 1   - OK i Anuluj                       /  OK and Cancel buttons                            ;
; 2   - Anuluj                            /  Cancel button                                    ;
; 3   - Tak, Nie i Anuluj                 /  Yes, No, and Cancel buttons                      ;
; 4   - Tak Nie                           /  Yes and No buttons                               ;
; 5   - Zamknij                           /  Close button                                     ;
; ------------------------------------------------------------------------------------------- ;
; Zwraca / Return:                                                                            ;
;  1   = Przyski OK     / OK button                                                           ;
;  2   = Anuluj         / Cancel button                                                       ;
;  6   = Tak            / Yes button                                                          ;
;  7   = Nie            / No button                                                           ;
;  12  = Zamknij        / Close button                                                        ;
; ------------------------------------------------------------------------------------------- ;
; (cd:DCL_Msgbox "Komunikat\nw 2 liniach" "Uwaga" 4 T 0)                                      ;
;;; ======================================================================================= ;;;
(defun cd:DCL_MsgBox (Msg Title Btns DPos Lng / data f TMP dc RET 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) '>))) 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
)


kojacek
Avatar użytkownika
kojacek
 
Posty: 5508
Dołączył(a): paź 03, 2005 20:17

Re: [LISP] CADPL-Pack-v1.lsp [Dyskusja]

Postprzez ZK » sty 17, 2012 16:55

Sprawdzone - działa.
Myślę, że to temat zamyka i można dodać do CADPL.

ZK
**************************************
********* http://madebynati.com *********
**************************************
Avatar użytkownika
ZK
 
Posty: 1082
Dołączył(a): mar 11, 2009 12:08
Lokalizacja: Poznań

Re: [LISP] CADPL-Pack-v1.lsp [Dyskusja]

Postprzez kruuger » sty 17, 2012 23:26

zbierajac wszystko do kupy.
Kod: Zaznacz cały
; cd:DCL_MsgBox           - DCL-owe okno komunikatu / DCL message box                         ;
; cd:STR_Parse            - Analiza lancucha tekstowego / Parse string                        ;
; cd:SYS_MsgBox           - Standardowe okno komunikatu / Standard message box                ;

;;; ======================================================================================= ;;;
; Analiza lancucha tekstowego / Parse string                                                  ;
;  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)
  )
)
;;; ======================================================================================= ;;;
; 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
)
;;; ======================================================================================= ;;;
; 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
)

k.
Avatar użytkownika
kruuger
 
Posty: 4867
Dołączył(a): paź 27, 2005 20:14
Lokalizacja: Kraków

Re: [LISP] CADPL-Pack-v1.lsp [Dyskusja]

Postprzez kojacek » sty 17, 2012 23:35

Zaktualniony...
Wracając nieco do czcionek. Takie coś. Lista dwóch ścieżek do fontów, windonsowych i autocadowych:
Kod: Zaznacz cały
; =========================================================================================== ;
(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)
    )
  )
)


kojacek
Avatar użytkownika
kojacek
 
Posty: 5508
Dołączył(a): paź 03, 2005 20:17

Re: [LISP] CADPL-Pack-v1.lsp [Dyskusja]

Postprzez ZK » sty 18, 2012 09:20

Sprawdzone (Win XP oraz Win 7x64)- działa również pod iCAD:
Kod: Zaznacz cały
Polecenie: (cd:SYS_FontPaths)
("C:\\WINDOWS\\fonts" "C:\\Program Files\\ZWCAD 2012 Plk\\Fonts")


pozdrawiam,
ZK
**************************************
********* http://madebynati.com *********
**************************************
Avatar użytkownika
ZK
 
Posty: 1082
Dołączył(a): mar 11, 2009 12:08
Lokalizacja: Poznań

Re: [LISP] CADPL-Pack-v1.lsp [Dyskusja]

Postprzez ZK » sty 18, 2012 09:40

Czyli mamy ścieżki, a następnie listę czcionek na bazie tematu:
http://forum.cad.pl/fonts-t78280.html

Teraz trza przerobić nieznacznie funkcję:
Kod: Zaznacz cały
(cd:DCL_StdListDialog
  (vl-sort
    (append
      (vl-directory-files (car (fnsplitl (findfile "isocp.shx"))) "*.shx")
      (vl-directory-files (strcat (getenv "WINDIR") "\\FONTS") "*.ttf")
    )(quote <)
  )
  0 "Fonty" "TTF und SHX:" 32 15 2 nil nil nil
)

by uzyskać faktyczny obraz tego co jest na dysku i z czego może skorzystać użytkownik w CAD.
Zgadza się?
**************************************
********* http://madebynati.com *********
**************************************
Avatar użytkownika
ZK
 
Posty: 1082
Dołączył(a): mar 11, 2009 12:08
Lokalizacja: Poznań

Re: [LISP] CADPL-Pack-v1.lsp [Dyskusja]

Postprzez ZK » sty 18, 2012 10:31

Taka propozycja:
Kod: Zaznacz cały
(defun cd:SYS_FontList (Path Ext)
   (cd:DCL_StdListDialog
     (vl-sort
        (vl-directory-files Path (strcat "*." Ext))
      (quote <)
     )
     0 "Fonty" (strcase Ext) 32 15 2 nil nil nil
   )
)
(cd:SYS_FontList (nth 1 (cd:SYS_FontPaths)) "shx")
(cd:SYS_FontList (nth 0 (cd:SYS_FontPaths)) "ttf")

Zastanawiam się czy jest sens wyświetlać i shx i ttf w jednej liście, dlatego rozbiłem to na dwa...
**************************************
********* http://madebynati.com *********
**************************************
Avatar użytkownika
ZK
 
Posty: 1082
Dołączył(a): mar 11, 2009 12:08
Lokalizacja: Poznań

Re: [LISP] CADPL-Pack-v1.lsp [Dyskusja]

Postprzez ZK » sty 18, 2012 10:38

I taka modyfikacja:
Kod: Zaznacz cały
(defun cd:SYS_FontList (Path Ext / Poz res)
   (setq Poz (cd:DCL_StdListDialog
     (setq res (vl-sort
        (vl-directory-files Path (strcat "*." Ext))
      (quote <)
     ))
     0 "Fonty" (strcase Ext) 32 15 2 nil nil nil
   ))
   (if res(strcat Path "\\" (nth Poz res)))
)

Dzięki czemu, mamy od razu wynik w postaci ścieżki do pliku czcionki np:
"C:\\WINDOWS\\fonts\\BOOKOS.TTF"

ZK
**************************************
********* http://madebynati.com *********
**************************************
Avatar użytkownika
ZK
 
Posty: 1082
Dołączył(a): mar 11, 2009 12:08
Lokalizacja: Poznań

Re: [LISP] CADPL-Pack-v1.lsp [Dyskusja]

Postprzez kojacek » sty 18, 2012 10:56

ZK napisał(a): Zastanawiam się czy jest sens wyświetlać i shx i ttf w jednej liście, dlatego rozbiłem to na dwa...

Ja ogólnie zastanawiam się czy jest sens w ogóle robienia takiej funkcji jako biblioteczną. Znaczy nie zastanawiam się nawet - uważam to za rzecz zbędną. Pozostawiłbym to użytkownikom CADPL-Pack.

kojacek
Avatar użytkownika
kojacek
 
Posty: 5508
Dołączył(a): paź 03, 2005 20:17

Re: [LISP] CADPL-Pack-v1.lsp [Dyskusja]

Postprzez kruuger » sty 18, 2012 11:08

kojacek napisał(a):
ZK napisał(a): Zastanawiam się czy jest sens wyświetlać i shx i ttf w jednej liście, dlatego rozbiłem to na dwa...

Ja ogólnie zastanawiam się czy jest sens w ogóle robienia takiej funkcji jako biblioteczną. Znaczy nie zastanawiam się nawet - uważam to za rzecz zbędną. Pozostawiłbym to użytkownikom CADPL-Pack.

kojacek

mi fonty od samego poczatku nie leza.
zezwolenie uzytkownikowi np. na tworzenie tekstu z wybrana czcionka to ostatnia rzecz jaka bym zrobil...ble
fontom bym juz podziekowal
k.
Avatar użytkownika
kruuger
 
Posty: 4867
Dołączył(a): paź 27, 2005 20:14
Lokalizacja: Kraków

Poprzednia stronaNastępna strona

Powrót do AutoCAD

Kto przegląda forum

Użytkownicy przeglądający ten dział: Brak zidentyfikowanych użytkowników