;;;Для типов линий
;;;С ttf шрифтами windows
(setq *activedoc* (vla-get-activedocument (vlax-get-acad-object)))
(mapcar (function
(lambda (mip_style font_file / text_style tmp)
(if (or (setq tmp (findfile font_file))
(setq tmp (findfile (strcat
(mip-get-special-folder "Fonts")
"\\"
font_file
) ;_ end of strcat
) ;_ end of findfile
) ;_ end of setq
) ;_ end of or
(setq font_file tmp)
(setq font_file nil)
) ;_ end of if
(if font_file
(if (not (tblsearch "STYLE" mip_style))
(progn
(setq text_style
(vla-add (vla-get-textstyles *activedoc*)
mip_style
) ;_ end of vla-add
) ;_ end of setq
(vla-put-fontfile text_style font_file)
(vla-put-width text_style 1.1)
(vla-put-height text_style 0.0)
) ;_ end of progn
(progn
(setq text_style
(vla-item (vla-get-textstyles *activedoc*)
mip_style
) ;_ end of vla-item
) ;_ end of setq
(vla-put-fontfile text_style (findfile font_file))
(vla-put-height text_style 0.0)
(vla-put-obliqueangle text_style 0)
(vla-put-width text_style 1.1)
) ;_ end of progn
) ;_ end of if
) ;_ end of if
) ;_ end of lambda
) ;_ end of function
'("TestStyle1" "standard")
'("arialbi.ttf" "isocpeur.ttf")
)
(defun mip-get-special-folder (folder / WS ret)
;;; Функция для определения одной из "специальных папок" Windows
;;; folder может быть:
;;; "AllUsersDesktop" - Windows 2000, Windows XP
;;; "AllUsersStartMenu" - Windows 2000, Windows XP
;;; "AllUsersPrograms" - Windows 2000, Windows XP
;;; "AllUsersStartup" - Windows 2000, Windows XP
;;; "Desktop" - Windows 98/ME, Windows 2000, Windows XP
;;; "Favorites" - Windows 98/ME, Windows 2000, Windows XP
;;; "Fonts" - Windows 98/ME, Windows 2000, Windows XP
;;; "MyDocuments" - Windows 98/ME, Windows 2000, Windows XP
;;; "NetHood" - Windows 98/ME, Windows 2000, Windows XP
;;; "PrintHood" - Windows 98/ME, Windows 2000, Windows XP
;;; "Programs" - Windows 98/ME, Windows 2000, Windows XP
;;; "Recent" - Windows 98/ME, Windows 2000, Windows XP
;;; "SendTo" - Windows 98/ME, Windows 2000, Windows XP
;;; "StartMenu" - Windows 98/ME, Windows 2000, Windows XP
;;; "Startup" - Windows 2000, Windows XP
;;; "Templates" - Windows 2000, Windows XP
;;; Возвращает или путь, или ""
;;; Пример:
;;; (mip-get-special-folder "Startup")
(vl-load-com)
(and
(setq WS (vlax-get-or-create-object "WScript.Shell"))
(setq folder (mip-conv-to-str folder))
(setq ret (vlax-invoke-method (vlax-get-property WS "SpecialFolders") "Item" folder))
(vlax-release-object ws)
)
(mip-conv-to-str ret)
);defun
(defun mip-conv-to-str (value)
(cond
((= (type value) 'STR)value)
((= (type value) 'INT)(itoa value))
((= (type value) 'REAL)(rtos value 2 14))
((not value) "")
(t (vl-princ-to-string value))
) ;_ end of cond
)
