_

[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 ziele_o2k » mar 23, 2017 19:42

Z czystej ciekawości, dlaczego to:

Kod: Zaznacz cały
(defun cd:SYS_GetFonts (/ lt reg ttfs ls shxs)
  (setq lt
    (vl-remove-if-not
      (function
        (lambda (%)(wcmatch % "*TrueType)"))
      )
      (vl-registry-descendents
        (setq reg
          (strcat "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\"
                  "Windows NT\\CurrentVersion\\Fonts"
          )
        ) ""
      )
    )
  )
  (setq ttfs
    (mapcar
      (function
        (lambda (%)
          (cons
            (vl-string-right-trim " (TrueType)" %)
            (vl-registry-read reg %)
          )
        )
      )
      (vl-remove-if-not
        (function
          (lambda (%1 / %2)
            (and
              (not
                (wcmatch
                  (setq %2 (vl-registry-read reg %1))
                  "*\\*"
                )
              )
              (wcmatch (strcase %2) "*.TTF")
            )
          )
        ) lt
      )
    )
        lt (mapcar (quote car) ttfs)
        ls (vl-directory-files
             (vl-filename-directory
               (findfile "isocp.shx")
             )
             "*.shx"
           )
        shxs (mapcar (function (lambda (%)(cons % %))) ls)
  )
  (list
    (append lt ls)
    (append ttfs shxs)
  )
)

nie znalazło się w Packu?
Ziele
Avatar użytkownika
ziele_o2k
 
Posty: 572
Dołączył(a): mar 18, 2014 11:33
Lokalizacja: Poznań

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

Postprzez kruuger » mar 23, 2017 23:32

ziele_o2k napisał(a):Z czystej ciekawości, dlaczego to:

Kod: Zaznacz cały
(defun cd:SYS_GetFonts (/ lt reg ttfs ls shxs)
  (setq lt
    (vl-remove-if-not
      (function
        (lambda (%)(wcmatch % "*TrueType)"))
      )
      (vl-registry-descendents
        (setq reg
          (strcat "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\"
                  "Windows NT\\CurrentVersion\\Fonts"
          )
        ) ""
      )
    )
  )
  (setq ttfs
    (mapcar
      (function
        (lambda (%)
          (cons
            (vl-string-right-trim " (TrueType)" %)
            (vl-registry-read reg %)
          )
        )
      )
      (vl-remove-if-not
        (function
          (lambda (%1 / %2)
            (and
              (not
                (wcmatch
                  (setq %2 (vl-registry-read reg %1))
                  "*\\*"
                )
              )
              (wcmatch (strcase %2) "*.TTF")
            )
          )
        ) lt
      )
    )
        lt (mapcar (quote car) ttfs)
        ls (vl-directory-files
             (vl-filename-directory
               (findfile "isocp.shx")
             )
             "*.shx"
           )
        shxs (mapcar (function (lambda (%)(cons % %))) ls)
  )
  (list
    (append lt ls)
    (append ttfs shxs)
  )
)

nie znalazło się w Packu?

sie gdzies zawieruszylo? czy to byla lista wszystkich czcionek z systemu czy bez jakichs tam ?
poprzypominam sobie te wszystkie help'y co i jak i zrobie update.
Avatar użytkownika
kruuger
 
Posty: 4792
Dołączył(a): paź 27, 2005 20:14
Lokalizacja: Kraków

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

Postprzez ziele_o2k » mar 24, 2017 15:58

kruuger napisał(a):sie gdzies zawieruszylo? czy to byla lista wszystkich czcionek z systemu czy bez jakichs tam ?
poprzypominam sobie te wszystkie help'y co i jak i zrobie update.


Gdzieś w tych okolicach to odkopałem:
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")

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)))
)

Kod: Zaznacz cały
(vlax-for x (vla-get-TextStyles
         (vla-get-activedocument (vlax-get-acad-object))
       )
  (princ)
  (vla-setfont x "Georgia" :vlax-False :vlax-False 0 32)
)

;;; Zmiana czcionki dla wszystkich styli na np. SIMPLEX.SHX
(vlax-for x (vla-get-TextStyles
         (vla-get-activedocument (vlax-get-acad-object))
       )
  (princ)
  (vla-put-fontfile x "SIMPLEX") 
)

Kod: Zaznacz cały
;; sprawdza poprawnosc obiektu nazwanego
(defun jk:ENT_Name-p (Tbl Name)
  (if
    (not (tblobjname Tbl Name))
    (if
      (snvalid Name 0)
      0  ; nie ma
      -1 ; zla nazwa
    )
    1    ; juz jest
  )
)
(defun Make-or-ChangeTextStyle (Name ListProp / ch vo)
  (setq ch (jk:ENT_Name-p "STYLE" Name))
  (if
    (setq vo
      (cond
        ( (zerop ch)
          (vla-add (vla-get-textstyles (cd:ACX_ADoc)) Name)
        )
        ( (= 1 ch)
          (vla-item (vla-get-textstyles (cd:ACX_ADoc)) Name)
        )
        (T nil)
      )
    )
    (cd:ACX_SetProp vo ListProp)
  )
  vo
)
;(Make-or-ChangeTextStyle "IS_SIMPLEX" '(("fontfile" . "simplex.shx")("Height" . 5.0)))

Kod: Zaznacz cały
(defun cd:SYS_GetFonts (/ lt reg ttfs ls shxs)
  (setq lt
    (vl-remove-if-not
      (function
        (lambda (%)(wcmatch % "*TrueType)"))
      )
      (vl-registry-descendents
        (setq reg
          (strcat "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\"
                  "Windows NT\\CurrentVersion\\Fonts"
          )
        ) ""
      )
    )
  )
  (setq ttfs
    (mapcar
      (function
        (lambda (%)
          (cons
            (vl-string-right-trim " (TrueType)" %)
            (vl-registry-read reg %)
          )
        )
      )
      (vl-remove-if-not
        (function
          (lambda (%1 / %2)
            (and
              (not
                (wcmatch
                  (setq %2 (vl-registry-read reg %1))
                  "*\\*"
                )
              )
              (wcmatch (strcase %2) "*.TTF")
            )
          )
        ) lt
      )
    )
        lt (mapcar (quote car) ttfs)
        ls (vl-directory-files
             (vl-filename-directory
               (findfile "isocp.shx")
             )
             "*.shx"
           )
        shxs (mapcar (function (lambda (%)(cons % %))) ls)
  )
  (list
    (append lt ls)
    (append ttfs shxs)
  )
)
Ziele
Avatar użytkownika
ziele_o2k
 
Posty: 572
Dołączył(a): mar 18, 2014 11:33
Lokalizacja: Poznań

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

Postprzez kruuger » kwi 03, 2017 10:18

CAD_Pack zaktualizowany o ACX_AddViewport i USR_GetCorner.
mozecie jeszcze sprawdzic. help wkrotce.
Avatar użytkownika
kruuger
 
Posty: 4792
Dołączył(a): paź 27, 2005 20:14
Lokalizacja: Kraków

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

Postprzez ziele_o2k » sty 31, 2018 12:53

Tak się zastanawiam, czy nie dodać do cd:ACX_AddTable opcji dostosowywania do UCS (T/nil) wzorem innych funkcji?
Jest z tym niestety pewien problem, ponieważ
Kod: Zaznacz cały
(vlax-put table 'direction (trans '(1 0 0) 1 0 T))
nie do końca działa. Tabela nie chce się zaktualizować po wstawieniu - dopiero po rozpoczęciu edycji tabeli (wypełniania komórek, ustawiania szerokości kolumn itd.).
Ja to obszedłem w swoich lispach za pomocą:
Kod: Zaznacz cały
;;------------------=={ Rotate by Matrix }==------------------;;
;;                                                            ;;
;;  Rotates a VLA-Object or Point List using a                ;;
;;  Transformation Matrix                                     ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2010 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  target - VLA-Object or Point List to transform            ;;
;;  p1     - Base Point for Rotation Transformation           ;;
;;  ang    - Angle through which to rotate object             ;;
;;------------------------------------------------------------;;

(defun LM:RotateByMatrix ( target p1 ang )
 
  (LM:ApplyMatrixTransformation target
    (setq m
      (list
        (list (cos ang) (- (sin ang)) 0.)
        (list (sin ang)    (cos ang)  0.)
        (list    0.           0.      1.)
      )
    )
    (mapcar '- p1 (mxv m p1))
  )
)

ze strony http://www.lee-mac.com/matrixtransformationfunctions.html ale wydaje mi się, że można zgrabniej to wykonać. Niestety nie wiem jak. Na Cadtutor podpowiedzieli coś takiego, ale też mi się nie podoba:
Kod: Zaznacz cały
(setq table
  (vla-AddTable
     Space
     (vlax-3d-point 0.0 0.0 0.0)
     Rows
     Cols
     RowH
     ColH
  )
)

(vlax-put table 'direction (trans '(1 0 0) 1 0 T))
(vla-move table (vlax-3d-point 0.0 0.0 0.0) (vlax-3d-point (trans Pb 1 0)))


No i oddzielna sprawa, czy dodać tworzenie stylu tabeli?
Ziele
Avatar użytkownika
ziele_o2k
 
Posty: 572
Dołączył(a): mar 18, 2014 11:33
Lokalizacja: Poznań

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

Postprzez kojacek » sty 31, 2018 18:32

Ja myślę że pan kierownik kruuger musi się zająć jakąś aktualizacją Pack'a...
Avatar użytkownika
kojacek
 
Posty: 5347
Dołączył(a): paź 03, 2005 20:17

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

Postprzez kruuger » sty 31, 2018 23:30

kojacek napisał(a):Ja myślę że pan kierownik kruuger musi się zająć jakąś aktualizacją Pack'a...

wrzucac tutaj co tam chcecie. potestujemy i dodamy :)
no faktycznie troche kupka z ta tabelka w ucs.
k.
Avatar użytkownika
kruuger
 
Posty: 4792
Dołączył(a): paź 27, 2005 20:14
Lokalizacja: Kraków

Poprzednia strona

Powrót do AutoCAD

Kto przegląda forum

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