Topic: Expand on this?

[TimSpangler]

I am looking for a way to create textstyle without command.  This I what I have, can anyone expand on this:

Code: [Select]

(defun CREATE_TEXTSTYLE (TextStyle Height Width Font / ActiveDoc Space VLTextStyle)

(vl-load-com)
(setq ActiveDoc (vla-get-activedocument (vlax-get-acad-object)))
(setq Space
(if (= (getvar "cvport") 1)
(vla-get-paperspace ActiveDoc)
(vla-get-modelspace ActiveDoc)
)
)
(setq VLTextStyle (vla-Add (vla-Get-Textstyles ActiveDoc) TextStyle))
(vlax-put VLTextStyle 'Height Height)
(vlax-put VLTextStyle 'Width Width)
(vlax-put VLTextStyle 'FontFile Font)
(princ "Text Style Created....")
(princ)
)


[JohnK]

What more do you want? (Looks ok to me. ...`Cept for the releasing.)

[TimSpangler]

Just looking to make it fool-proof and more robust.

[mjguzik]

These are two functions that I have used in the past to create or modify a text style.  Hope they are helpful.  The first is to create a text style :

Code: [Select]

;;;*******************************************************************************************
;;; FUNCTION: ENTMAKE-STYLE
;;; DESCRIPTION: CREATES TEXT STYLE TO ARGS
;;; ARGS: name, font, size, oblique, width
;;; EXAMPLE: (ENTMAKE-STYLE "Test" "romans.shx" 0.109375 (dtr 15) 0.80)
;;; RETURNS: nil
;;;*******************************************************************************************
(defun ENTMAKE-STYLE (name font size obl width /)
  (if (not (tblobjname "style" name))
    (entmake (list '(0 . "STYLE")
                   '(100 . "AcDbSymbolTableRecord")
                   '(100 . "AcDbTextStyleTableRecord")
                   (cons 2 name)
                   '(70 . 0)
                   (cons 40 size)
                   (cons 41 width)
                   (cons 50 obl)
                   '(71 . 0)
                   (cons 42 0.0)
                   (cons 3 font)
                   '(4 . "")
                   )
             )
    )
  )


the second is to modify:

Code: [Select]

;;;*******************************************************************************************
;;; FUNCTION: ENTMOD-STYLE
;;; DESCRIPTION: MODIFIES TEXT STYLE TO ARGS
;;; ARGS: name, font, size, oblique, width
;;; EXAMPLE: (ENTMOD-STYLE "Test" "romans.shx" 0.109375 (dtr 22.5) 0.80)
;;; RETURNS: entlist
;;;*******************************************************************************************
(defun ENTMOD-STYLE (name font size obl width /)
  (if (tblobjname "style" name)
    (progn (setq el (entget (tblobjname "style" name)))
           (setq el (subst (cons 40 size) (assoc 40 el) el))
           (setq el (subst (cons 41 width) (assoc 41 el) el))
           (setq el (subst (cons 50 obl) (assoc 50 el) el))
           (setq el (subst (cons 3 font) (assoc 3 el) el))
           (entmod el)
           )
   
    )
  )

Have a great day.

MJG

[ronjonp]

Perhaps this?

Code: [Select]

(defun CREATE_TEXTSTYLE
       (TextStyle Height Width Font / ActiveDoc VLTextStyle)
  (vl-load-com)
  (setq ActiveDoc (vla-get-activedocument (vlax-get-acad-object)))
  (setq VLTextStyle (vla-Add (vla-Get-Textstyles ActiveDoc) TextStyle))
  (vlax-put VLTextStyle 'Height Height)
  (vlax-put VLTextStyle 'Width Width)
  (vlax-put VLTextStyle 'FontFile Font)
  (princ (strcat "\nText Style " TextStyle " Created...."))
  (princ)
)

[CAB]

I like it Ron.
You need to error trap this (vlax-put VLTextStyle 'FontFile Font)
and it would be nice to have the message reply "New Style Created" or "Style Updated" as appropriate.

[ronjonp]

I like it Ron.
You need to error trap this (vlax-put VLTextStyle 'FontFile Font)
and it would be nice to have the message reply "New Style Created" or "Style Updated" as appropriate.

How about this?

Code: [Select]

(defun CREATE_TEXTSTYLE
       (TextStyle Height Width Font / ActiveDoc VLTextStyle styles)
  (vl-load-com)
  (setq ActiveDoc   (vla-get-activedocument (vlax-get-acad-object))
VLTextStyle (vla-Add (vla-Get-Textstyles ActiveDoc) TextStyle)
  )
  (vlax-map-collection
    (vla-get-textstyles ActiveDoc)
    '(lambda (x)
       (setq styles (cons (vla-get-name x) styles))
     )
  )
  (vlax-put VLTextStyle 'Height Height)
  (vlax-put VLTextStyle 'Width Width)
  (vlax-put VLTextStyle 'FontFile Font)
  (if (member TextStyle styles)
    (princ (strcat "\nText Style " TextStyle " Updated...."))
    (princ (strcat "\nText Style " TextStyle " Created...."))
  )
  (princ)
)
What error would I need to trap? I cannot get it to break.

Ron

[CAB]

Maybe like this?

Code: [Select]

;;  Create or Update a Text Style
;;  Returns T is successful else nil
;;  no error check for proper parameters
(defun CREATE_TEXTSTYLE
       (StyleName  ; String
        Height     ; Real
        Width      ; Real
        Font       ; String
        / ActiveDoc VLTextStyle msg)
  (vl-load-com)
  (setq ActiveDoc (vla-get-activedocument (vlax-get-acad-object)))
  (princ (strcat "\nText Style " StyleName))
  (if (tblsearch "style" StyleName)
    (setq msg " Updated....")
    (setq msg " Created....")
  )
  (setq TextStyles (vla-get-textstyles ActiveDoc))
  (setq VLTextStyle (vla-add (vla-get-textstyles ActiveDoc) StyleName))
  (vlax-put VLTextStyle 'Height Height)
  (vlax-put VLTextStyle 'Width Width)
  (if (vl-catch-all-error-p
        (vl-catch-all-apply 'vlax-put (list VLTextStyle 'FontFile Font))
      )
    (not (princ " Font File Failed...."))
    (and (princ msg))
  )
)<edit: changed failure message>

[CAB]

Ops, you beat me to it.

If the font file does not exist it will crash & burn.

[CAB]

Actually mine falls short. If the font file is bad the style is still created.
Need to work on that.

[mjguzik]

I remember reading somewhere when VL came out that you should release objects created after you are finished.  Otherwise the item remains in memory and/or gets orphaned until the AutoCAD session is closed (i.e. memory leaks).  Does anyone have any more information or knowledge about this or has this been corrected in subsequent releases?  When applying VL objects I have always released them when finished using functions such as these: 

Code: [Select]

;;;*******************************************************************************************
;;; FUNCTION: ReleaseObj
;;; DESCRIPTION: Releases VLA-OBJECT and sets  to 'nil'
;;; ARGS: object
;;; EXAMPLE: (ReleaseObj (setq aobj (vlax-get-acad-object)))
;;;*******************************************************************************************
(defun ReleaseObj (symbol)
  (if (and (eval symbol) (= (type symbol) 'vla-object))
      (if (null (vlax-object-released-p (eval symbol)))
        (vlax-release-object symbol)
        )
      )
    (set 'symbol nil)
  )

and this for a list of objects:

;;;**************************************************************************
;;; FUNCTION: ReleaseObjLst
;;; DESCRIPTION: Releases list of object symbols and sets each to 'nil'
;;; ARGS: list-of-objects
;;; EXAMPLE: (ReleaseObjLst '(adoc aobj))
;;;**************************************************************************
(defun ReleaseObjLst (olist)
  (foreach symbol olist
    (if   (and (eval symbol) (= (type symbol) 'vla-object))
      (if (null (vlax-object-released-p (eval symbol)))
   (vlax-release-object symbol)
   )
      )
    (set symbol nil)
    )
  )

Regards,

MJG

[CAB]

A discussion on releasing objects.
http://www.theswamp.org/index.php?topic=2005.msg25790#msg25790

[TimSpangler]

This turned out to be a very intersting post.

Ron,
In your code the text style will always be updated, never created:

Code: [Select]

(setq ActiveDoc   (vla-get-activedocument (vlax-get-acad-object))
VLTextStyle (vla-Add (vla-Get-Textstyles ActiveDoc) TextStyle) [color=red]***Creted Here[/color]
  )
  [color=red]***Checked for exsistance here? (it will always exsist. Yes??)[/color]
  (vlax-map-collection
    (vla-get-textstyles ActiveDoc)
    '(lambda (x)
       (setq styles (cons (vla-get-name x) styles))
     )
  )


Very intersting read on the release of objects, I must have missed that one first time around.

This effort is for a program to created standard textsyle rather than using a dwt to insert from.

Now onto Dimstyles   

[ronjonp]

DOH!

This should work:

Code: [Select]

(defun CREATE_TEXTSTYLE
       (TextStyle Height Width Font / ActiveDoc VLTextStyle styles)
  (vl-load-com)
  (setq ActiveDoc (vla-get-activedocument (vlax-get-acad-object)))
  (vlax-map-collection
    (vla-get-textstyles ActiveDoc)
    '(lambda (x)
       (setq styles (cons (vla-get-name x) styles))
     )
  )
  (setq VLTextStyle (vla-Add (vla-Get-Textstyles ActiveDoc) TextStyle))
  (vlax-put VLTextStyle 'Height Height)
  (vlax-put VLTextStyle 'Width Width)
  (vlax-put VLTextStyle 'FontFile Font)
  (if (member TextStyle styles)
    (princ (strcat "\nText Style " TextStyle " Updated...."))
    (princ (strcat "\nText Style " TextStyle " Created...."))
  )
  (princ)
)

[CAB]

Here is one with some error checking.
Returns nil is Update or Create fails completely.

Code: [Select]

;;  CAB @ TheSwamp 03.06.07
;;  Create or Update a Text Style
;;  Returns T is sucessfull created/updated else nil
;;  Prompts with any failures
;;  On Failure of Height or Width the other operations are completed
(defun CREATE_TEXTSTYLE
                        (StyleName ; String - "txt" or "txt.shx" or "ArialN.TTF"
                         Height    ; Real >= 0
                         Width     ; Real > 0
                         Font      ; String
                         / ActiveDoc VLTextStyle msg)
  (vl-load-com)
  (setq ActiveDoc (vla-get-activedocument (vlax-get-acad-object)))
  (if (null (wcmatch Font "*`.*"))
    (setq Font (strcat Font ".shx"))
  )
  (if
    (or (and (setq file (findfile font)) ; found an shx font
             (setq file font)
        )
        (setq file (findfile (strcat (getenv "windir") "\\fonts\\" font)))
        (prompt (strcat "\nFont File " Font " not found."))
    )
     (progn
       (princ (strcat "\nText Style " StyleName))
       (if (tblsearch "style" StyleName)
         (princ " Updateing....")
         (princ " Createing....")
       )
       (setq TextStyles (vla-get-textstyles ActiveDoc))
       (if (vl-catch-all-error-p
              (setq VLTextStyle
                    (vl-catch-all-apply
                      'vla-add (list (vla-get-textstyles ActiveDoc) StyleName))))
         (not (princ " Failed\n**  Bad Style Name...."))
         (progn
           (and (vl-catch-all-error-p
                  (vl-catch-all-apply 'vlax-put (list VLTextStyle 'Height Height)))
                (prompt "\n**  Bad Text Height...."))
           (and (vl-catch-all-error-p
                  (vl-catch-all-apply 'vlax-put (list VLTextStyle 'Width Width)))
                (prompt "\n**  Bad Text Width...."))
           (or (not (vl-catch-all-error-p
                       (vl-catch-all-apply 'vlax-put (list VLTextStyle 'FontFile file))))
                 (prompt "\n**  Bad Font File...."))
        )
       )
     )
  )
)