GetFont

[ubh65]

Hi,

 

This is my first post.

I am trying to find the font file and the text height used in a text to be picked by user.

After finding that I want to produce a Text Style having the same properties but with a different name.

 

Can any body help.

[Tiger]

Why don't you just find the text style in question (highlight the text, bring up Properties), go into Style Manager and make a copy of the style there?

[ubh65]

Thanks.

I just accomplished the goal.

Below is the code:

 

 

Public Sub setTextProp()
   Dim XdataSel As AcadSelectionSet
   Dim AcadEnt As AcadText
   Dim txtStyle1 As AcadTextStyle
   Dim TextStyleCollection As AcadTextStyles
   Dim txtFont1 As String
   
   On Error GoTo TrapErr
   
   Call AcClass.InitCADLoad

   AcadDoc.Utility.Prompt "Select The Text Object to Copy its Properties..."
   Set XdataSel = AcClass.SelObjects
   If XdataSel.Count = 0 Then
       MsgBox "No Entity Selected", vbInformation
       ErrFlag = True
       Exit Sub
   End If
   
   Set AcadEnt = XdataSel.Item(0)
   
   Set TextStyleCollection = AcadDoc.TextStyles
   For Each txtStyle1 In TextStyleCollection
       If txtStyle1.Name = AcadEnt.StyleName Then
           AcadDoc.ActiveTextStyle = txtStyle1
           Exit For
       End If
   Next
   
   txtFont1 = txtStyle1.fontFile
   LoadtxtHt1 = txtStyle1.height
   If AcadEnt.height > LoadtxtHt1 Then
       LoadtxtHt1 = AcadEnt.height
   End If
  
   Call SetTextStyle(LoadtxtHt1, txtFont1)
TrapErr:

End Sub

Private Sub SetTextStyle(txtHt As Double, txtFont1 As String)
   Dim TextColl As AcadTextStyles
   Dim txtStyle As AcadTextStyle
   Set TextColl = AcadDoc.TextStyles
   Set txtStyle = TextColl.Add("U2Q")
   
   txtStyle.height = txtHt
   txtStyle.fontFile = txtFont1
   AcadDoc.ActiveTextStyle = txtStyle
   
   AcadDoc.SetVariable "USERR1", txtHt
End Sub