Solved

UnavailableFonts - VBA

Posted on 2004-08-23
12
715 Views
Last Modified: 2013-12-03
Hi

I would like to display all the substituted fonts thru a msgbox.

I tried Application.Dialogs.Item(wdDialogFontSubstitution).unavailablefont. But it gives me the name of the first substituted font, but not the others, i.e. if there are 4 unavailable fonts, the abovesaid function returns only the first unavailable font. How can I get the list of all unavailable fonts?

Thanx
Srik
0
Comment
Question by:vi_srikanth
  • 4
  • 3
  • 3
  • +1
12 Comments
 
LVL 12

Expert Comment

by:fulscher
ID: 11879445
One solution could be to make a list of all installed fonts and compare it to the list of fonts in the document.

The list of all fonts is contained in Application.FontNames

The list of fonts contained in the document is appearently not this easy to retrieve. http://www.tribbs.co.uk/showtip.php?myID=29&start=6 suggest to iterate through each character and check its font - this is certainly feasible, but obviously extremly slow.

Any other ideas?
0
 
LVL 4

Author Comment

by:vi_srikanth
ID: 11889118
Thats how I have right now. But, I want to do that thru wdDialogFontSubstitution. Is there any way?
0
 
LVL 22

Expert Comment

by:Dreamboat
ID: 11889822
Try to get something out of this...

Private Sub btnFonts_Click()
  main
End Sub
Public Sub main()
  Dim sMsg As String
  sMsg = GetFonts(ThisDocument)
  MsgBox "The fonts in this document are:" & vbNewLine & vbNewLine & sMsg
  MsgBox "The following fonts are used in this document," & vbNewLine & "but are not installed on this PC:" & vbNewLine & CompareFonts(sMsg)
End Sub

Private Function GetFonts(ByVal oDocument As Document) As String
  Dim oParagraph As Paragraph
  Dim i As Integer
  Dim oWord As Words
  Dim sFontType As String
  Dim sMsg As String
  For Each oParagraph In oDocument.Paragraphs
    For i = 1 To oParagraph.Range.Characters.Count
      sFontType = oParagraph.Range.Characters(i).Font.Name
      If InStr(1, sMsg, sFontType) = 0 Then
        sMsg = sMsg & sFontType & vbNewLine
      End If
    Next
  Next
  GetFonts = sMsg
End Function

Private Function CompareFonts(ByVal oFonts As String) As String
Dim vFont As Variant
Dim sMsg As String
Dim xFont
Dim i As Long
Dim allFonts As String
For Each vFont In FontNames
allFonts = allFonts & vbNewLine & vFont
Next vFont
xFont = Split(oFonts, vbNewLine)
For i = 0 To UBound(xFont)
If InStr(allFonts, xFont(i)) = 0 Then
sMsg = sMsg & vbNewLine & xFont(i)
End If
Next i
CompareFonts = sMsg
End Function
0
Free Tool: Postgres Monitoring System

A PHP and Perl based system to collect and display usage statistics from PostgreSQL databases.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
LVL 12

Expert Comment

by:fulscher
ID: 11889931
vi_srikanth,

it looks like the only shortcut would be to use the use SelectCurrentFont method instead of selecting each individual character as shown in the sample above from Dreamboat.

I have not yet found a way to extract the elements from the list box. An option might be to display the dialog and use some clever API programming to extract the list elements; however, this would require some external programs (i.e., not Word VBA).

Still looking into it, but I'm not very confident...

0
 
LVL 4

Author Comment

by:vi_srikanth
ID: 11899407
Hi Dreamboat,

As I've said earlier,  I want to do that thru wdDialogFontSubstitution. The Application.Dialogs.Item(wdDialogFontSubstitution).unavailablefont displays only the first font, but, how can i get the other unavailable fonts?

Hi  fulscher,

When u've got the solution pls. let me know.

Thnx
Srik
0
 
LVL 22

Expert Comment

by:Dreamboat
ID: 11899446
What do you mean, the first available font?

When I run that code, it tells me ALL the fonts that are unavailable on the PC, not just the *first*.

I created a file.
I set two fonts: Century Times and Univers

BOTH fonts showed as unavailable.
Isn't that what you want?
0
 
LVL 22

Expert Comment

by:Dreamboat
ID: 11899476
No one has discussed version here...

And, I've finally got the code loaded with a sample file:
http://www.vbaexpress.com/kb/getarticle.php?kb_id=137
0
 
LVL 12

Expert Comment

by:fulscher
ID: 11899765
Sorry, no news yet. I'm still not sure whether this can be solved using the wdDialogFontSubstitution dialog - MS obviously did not intend you to make use of the info provided there :-(

Jan
0
 
LVL 4

Author Comment

by:vi_srikanth
ID: 11901350
> When I run that code, it tells me ALL the fonts that are unavailable on the PC, not just the *first*.

I want to collect the names of the unavailable fonts thru wdDialogFontSubstitution. At present I have a code like what u've posted, but, I would like to use the Word's FontSubstitution information itself. More than that, I want to know the name of the substituted font. I use Word 2000.
0
 
LVL 22

Expert Comment

by:Dreamboat
ID: 12202938
Refund and PAQ. I don't think we ever figured out what the asker really wanted.
0
 
LVL 1

Accepted Solution

by:
Computer101 earned 0 total points
ID: 12231977
PAQed, with points refunded (250)

Computer101
E-E Admin
0

Featured Post

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

It is often necessary in this forum and others to illustrate Word fields as text with the field delimiters replaced with the curly brackets that the delimiters resemble when field codes are being displayed on the document. This means that the text c…
Using Word 2013, I was experiencing some incredible lag when typing.  Here's what worked for me....
Learn how to create and modify your own paragraph styles in Microsoft Word. This can be helpful when wanting to make consistently referenced styles throughout a document or template.
In a previous video Micro Tutorial here at Experts Exchange (http://www.experts-exchange.com/videos/1358/How-to-get-a-free-trial-of-Office-365-with-the-Office-2016-desktop-applications.html), I explained how to get a free, one-month trial of Office …

820 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question