Creating a new TestSyle problem

Hi
I'm using A2k2

I'm trying to create a new textstyle using Romans.shx font.
The textstyle produced by this routine creates text/dims that appear to be
drawn using romans.ttf (the text has a slight line thickness).

However the dialogue shows romans.shx as the font name.
The font style as regular (if I created the style manually this box would be
greyed out)

Any idea what I'm doing wrong?

TIA

Dave F.

Sub Create_RomansTxtStyle()
Dim txtStyleObj As AcadTextStyle

On Error Resume Next
ThisDrawing.TextStyles.Item ("Romans")
If Err.Number <> 0 Then ' if it doesn't exist
Set txtStyleObj = ThisDrawing.TextStyles.Add("Romans") ' creates a new
TextStyle
txtStyleObj.SetFont "romans", False, False, 0, 0
ThisDrawing.ActiveTextStyle = txtStyleObj ' makes it the current one
End If
End Sub

 

Dave,

I think most of the problem you are encountering stems from not using a file
extension on the file name. Below is some sample code that should work for
you.

Wayne


Sub Create_RomansTxtStyle()
Dim txtStyleObj As AcadTextStyle
Const STYLE_NAME As String = "Romans"
Const STYLE_FILE As String = "romans.shx"

'Get the text style object
On Error Resume Next
Set txtStyleObj = ThisDrawing.TextStyles.Add(STYLE_NAME)
'If an error was raised, then the style already existed
If Err Then
Err.Clear
'Try to get a reference to the existing style
Set txtStyleObj = ThisDrawing.TextStyles.Item(STYLE_NAME)
End If
'If we have an error here, then give up.
If Err Then
Err.Clear
'Dereference the object pointer
Set txtStyleObj = Nothing
Exit Sub
End If

'Set the text style values
With txtStyleObj
.fontFile = STYLE_FILE '<--Note the file extension is used in this
constant
.Height = 0#
.Width = 1#
.ObliqueAngle = 0#
End With
'Make this the active style
ThisDrawing.ActiveTextStyle = txtStyleObj
'Dereference the object pointer
Set txtStyleObj = Nothing
End Sub