VBA Font Object Query

[Robert Mulroney]

I need to make an array of font objects, I don't even seem to be able to
make even one. Why doesn't this code work:

Public Sub x()
Dim f as Font
Set f = New Font
f.Name = "Arial"
End Sub

I'm getting an error on the 2nd line, "Invalid use of New keyword". Any
thoughts?

- Rm

[Norman Jones]

Hi Robert,

Try the following code which endeavours to adapt some code by John
Walkenbach to meet your needs:

'=================>>
Public Sub Tester()
Dim FontList As CommandBarComboBox
Dim i As Long
Dim tempbar As CommandBar
Dim arr As Variant

On Error Resume Next
Set FontList = Application.CommandBars("Formatting"). _
FindControl(ID:=1728)

If FontList Is Nothing Then
Set tempbar = Application.CommandBars.Add
Set FontList = tempbar.Controls.Add(ID:=1728)
End If

ReDim arr(1 To FontList.ListCount)
On Error GoTo 0
For i = 1 To FontList.ListCount - 1
arr(i) = FontList.List(i)
Next i

' Delete temp CommandBar if it exists
On Error Resume Next
tempbar.Delete
End Sub
'<<=================


---
Regards,
Norman



"Robert Mulroney" <''''[email protected]''''> wrote in message
news:[email protected]...
>
> I need to make an array of font objects, I don't even seem to be able to
> make even one. Why doesn't this code work:
>
> Public Sub x()
> Dim f as Font
> Set f = New Font
> f.Name = "Arial"
> End Sub
>
> I'm getting an error on the 2nd line, "Invalid use of New keyword". Any
> thoughts?
>
> - Rm

[Norman Jones]

Hi Robert,

> ReDim arr(1 To FontList.ListCount)

was intended as:

ReDim arr(1 To FontList.ListCount - 1)


---
Regards,
Norman


"Norman Jones" <[email protected]> wrote in message
news:[email protected]...
> Hi Robert,
>
> Try the following code which endeavours to adapt some code by John
> Walkenbach to meet your needs:
>
> '=================>>
> Public Sub Tester()
> Dim FontList As CommandBarComboBox
> Dim i As Long
> Dim tempbar As CommandBar
> Dim arr As Variant
>
> On Error Resume Next
> Set FontList = Application.CommandBars("Formatting"). _
> FindControl(ID:=1728)
>
> If FontList Is Nothing Then
> Set tempbar = Application.CommandBars.Add
> Set FontList = tempbar.Controls.Add(ID:=1728)
> End If
>
> ReDim arr(1 To FontList.ListCount)
> On Error GoTo 0
> For i = 1 To FontList.ListCount - 1
> arr(i) = FontList.List(i)
> Next i
>
> ' Delete temp CommandBar if it exists
> On Error Resume Next
> tempbar.Delete
> End Sub
> '<<=================
>
>
> ---
> Regards,
> Norman

[Robert Mulroney]

That's really very tricky, I'm quite impressed.

What I'm working on is a Rich text parser for Excel. In the rich text syntax
all the font's are defiend in the header of the file. I want to make and
array of the "type" Font that represents all the fonts in the rtf header.

something along the lines of :


Private fonts() As Font


sub fontTable()

dim workingFont as integer
workingFont = 0.
..
..
..

'add a new font
ReDim Preserve fonts(0 To workingFont)
fonts(workingFont) = new Font
'but I get an error here.^



Thanks for your help

- Rm







"Norman Jones" wrote:

> Hi Robert,
>
> > ReDim arr(1 To FontList.ListCount)
>
> was intended as:
>
> ReDim arr(1 To FontList.ListCount - 1)
>
>
> ---
> Regards,
> Norman
>
>
> "Norman Jones" <[email protected]> wrote in message
> news:[email protected]...
> > Hi Robert,
> >
> > Try the following code which endeavours to adapt some code by John
> > Walkenbach to meet your needs:
> >
> > '=================>>
> > Public Sub Tester()
> > Dim FontList As CommandBarComboBox
> > Dim i As Long
> > Dim tempbar As CommandBar
> > Dim arr As Variant
> >
> > On Error Resume Next
> > Set FontList = Application.CommandBars("Formatting"). _
> > FindControl(ID:=1728)
> >
> > If FontList Is Nothing Then
> > Set tempbar = Application.CommandBars.Add
> > Set FontList = tempbar.Controls.Add(ID:=1728)
> > End If
> >
> > ReDim arr(1 To FontList.ListCount)
> > On Error GoTo 0
> > For i = 1 To FontList.ListCount - 1
> > arr(i) = FontList.List(i)
> > Next i
> >
> > ' Delete temp CommandBar if it exists
> > On Error Resume Next
> > tempbar.Delete
> > End Sub
> > '<<=================
> >
> >
> > ---
> > Regards,
> > Norman
>
>
>

[Norman Jones]

Hi Robert,

The Font object is accessed by using the Font property

The following sub demonstrates loading a module level array (arr) with the
available font names:

'=================>>
Option Explicit
Public arr As Variant

'=================>>
Public Sub Tester2()
Dim FontList As CommandBarComboBox
Dim i As Long
Dim tempbar As CommandBar

On Error Resume Next
Set FontList = Application.CommandBars("Formatting"). _
FindControl(ID:=1728)

If FontList Is Nothing Then
Set tempbar = Application.CommandBars.Add
Set FontList = tempbar.Controls.Add(ID:=1728)
End If

ReDim arr(1 To FontList.ListCount - 1)
On Error GoTo 0
For i = 1 To FontList.ListCount - 1
arr(i) = FontList.List(i)
Next i

' Delete temp CommandBar if it exists
On Error Resume Next
tempbar.Delete


End Sub
'<<=================

The following demonstrates reading the available font names which are held
in the module level arr.

Note that no error checking is included and if arr should not be loaded, the
sub will error.

'=================>>
Sub ReadFontList()
Dim i As Long
For i = 1 To UBound(arr)
Debug.Print arr(i)
Next i
End Sub
'<<=================

Since you can read off the font names you can do as you wish with the
resultantly accessible fonts.

If you wish to produce an array holding a selected subset of available
fonts, of course you can do that. In this case, you would use the new array
it in much the same way as would be the case were you to use the present
array.


Regards,
Norman



"Robert Mulroney" <''''[email protected]''''> wrote in message
news:[email protected]...
> That's really very tricky, I'm quite impressed.
>
> What I'm working on is a Rich text parser for Excel. In the rich text
> syntax
> all the font's are defiend in the header of the file. I want to make and
> array of the "type" Font that represents all the fonts in the rtf header.
>
> something along the lines of :
>
>
> Private fonts() As Font
>
>
> sub fontTable()
>
> dim workingFont as integer
> workingFont = 0.
> .
> .
> .
>
> 'add a new font
> ReDim Preserve fonts(0 To workingFont)
> fonts(workingFont) = new Font
> 'but I get an error here.^
>
>
>
> Thanks for your help
>
> - Rm
>
>
>
>
>
>
>
> "Norman Jones" wrote:
>
>> Hi Robert,
>>
>> > ReDim arr(1 To FontList.ListCount)
>>
>> was intended as:
>>
>> ReDim arr(1 To FontList.ListCount - 1)
>>
>>
>> ---
>> Regards,
>> Norman
>>
>>
>> "Norman Jones" <[email protected]> wrote in message
>> news:[email protected]...
>> > Hi Robert,
>> >
>> > Try the following code which endeavours to adapt some code by John
>> > Walkenbach to meet your needs:
>> >
>> > '=================>>
>> > Public Sub Tester()
>> > Dim FontList As CommandBarComboBox
>> > Dim i As Long
>> > Dim tempbar As CommandBar
>> > Dim arr As Variant
>> >
>> > On Error Resume Next
>> > Set FontList = Application.CommandBars("Formatting"). _
>> > FindControl(ID:=1728)
>> >
>> > If FontList Is Nothing Then
>> > Set tempbar = Application.CommandBars.Add
>> > Set FontList = tempbar.Controls.Add(ID:=1728)
>> > End If
>> >
>> > ReDim arr(1 To FontList.ListCount)
>> > On Error GoTo 0
>> > For i = 1 To FontList.ListCount - 1
>> > arr(i) = FontList.List(i)
>> > Next i
>> >
>> > ' Delete temp CommandBar if it exists
>> > On Error Resume Next
>> > tempbar.Delete
>> > End Sub
>> > '<<=================
>> >
>> >
>> > ---
>> > Regards,
>> > Norman
>>
>>
>>