_

[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: 504
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: 4779
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: 504
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: 4779
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ł: TottalX