新建和设置字体样式 V1.2

;;说明:新建或设置字体样式-(by-小贱贱-QQ:369034346)
;;参数:styleName:字体样式名
;;参数:textFont:字体名
;;参数:Height:字体高度
;;参数:width:字体宽度因子
;;示例：(AddTextStyle "Standard" "宋体" 3 0.7)
(defun AddTextStyle(styleName textFont Height Width)
    (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
    (if (setq bol (tblsearch "style" styleName))
        (setq acstyle (vla-Item (vla-get-TextStyles acdoc) styleName))
        (setq acstyle (vla-add (vla-get-TextStyles acdoc) styleName))
    )
    (vla-SetFont acstyle textFont :vlax-false :vlax-false 1 0)
    (vlax-put-property acstyle "Height" Height)
    (vlax-put-property acstyle "Width" Width)
    (setvar "TEXTSTYLE" styleName)
    (if bol 
        (vla-regen acdoc acAllViewports)
        (setvar "TEXTSTYLE" styleName)
    )
    (prin1)
)
;新建体样式
(defun c:tt1 ()
    (setq textstyles (vla-add (vla-get-TextStyles (vla-get-ActiveDocument (vlax-get-acad-object))) "宋 宽0.7 高3"))
    (vla-SetFont textstyles "宋体" :vlax-false :vlax-false 1 0)
    (vlax-put-property textstyles "Height" 3)
    (vlax-put-property textstyles "Width" 0.7)
    (setvar "TEXTSTYLE" "宋 宽0.7 高3")
)
;设置当前字体样式
(defun c:tt2 ()
    (setq textstyles (vla-get-ActiveTextStyle (vla-get-ActiveDocument (vlax-get-acad-object))))
    (vla-SetFont textstyles "黑体" :vlax-false :vlax-false 1 0)
    (vlax-put-property textstyles "Height" 3)
    (vlax-put-property textstyles "Width" 0.7)
    (command "REGEN")
)

;(EF:Style-CreatFontEx "字体名" "宋体" nil 1.0 0.0）
;创建字体样式
(defun EF:Style-CreatFontEx (sStyleName    ;样式名
                                                            sFont    ;西文字体 或 TrueType字体
                                                            sBigFont    ;大字体    或 TrueType是否粗体
                                                            fWidth    ;宽度比例
                                                            fObliquity    ;倾斜角度
                                                            /
                                                            TextStyles TextStyle
                                                        )
  ;;造字型
  (setq TextStyles (vla-get-TextStyles (vla-get-ActiveDocument (vlax-get-acad-object))))
  (if (tblobjname "style" sStyleName)
    (setq TextStyle (vla-item TextStyles sStyleName))
    (setq TextStyle (vla-add TextStyles sStyleName))
    )
  (if (or (findfile (strcat sFont ".SHX"))    ;shx字体
                (and (vl-filename-extension sFont)
                    (= (strcase (vl-filename-extension sFont)) ".SHX")
                )
      )
    (apply 'or
            (mapcar '(lambda (e)
                                 (vl-catch-all-error-p (vl-catch-all-apply (car e) (list TextStyle (cadr e))))
                             )
                (list (list 'vla-put-FontFile sFont)
                    (list 'vla-put-BigFontFile sBigFont)
                    (list 'vla-put-ObliqueAngle fObliquity)
                    (list 'vla-put-Width fWidth)
                )
            )
        )
    (progn
      (vla-setFont TextStyle sFont (if (equal sBigFont T) :vlax-true :vlax-false) :vlax-false 1 0)
      (vl-catch-all-apply 'vla-put-ObliqueAngle (list TextStyle fObliquity))
      (vl-catch-all-apply 'vla-put-Width (list TextStyle fWidth))
        )
    )
)