[program-l] Re: Odd Word Request
- From: "George Bell" <george@xxxxxxxxxxxxxxxxxxx>
- To: <program-l@xxxxxxxxxxxxx>
- Date: Fri, 21 May 2010 17:25:01 +0100
Hi Mark,
What a star you are. Couple of minor problems. Suspect number length
isn't long enough as there's no space, and Times New Roman should be a
very high number.
And there one which doesn't appear to have a name - (2nd line)
All the best,
George.
Calibri used932 times
used2 times
Courier New used1 times
MS Shell Dlg 2 used18 times
MS Mincho used2 times
Cambria used35 times
Script MT Bold used1 times
SimBraille used838 times
Humanst521BT,Bold used2 times
Humanst521BT used9 times
Humanst521BT,Italic used2 times
Arial used6 times
Arial Unicode MS used5 times
Euclid Fraktur used26 times
Times New Roman used5 times
From: program-l-bounce@xxxxxxxxxxxxx
[mailto:program-l-bounce@xxxxxxxxxxxxx] On Behalf Of Mark Long
Sent: 21 May 2010 16:39
To: program-l@xxxxxxxxxxxxx
Subject: [program-l] Re: Odd Word Request
No promises, no testing and no support but try this. It will give the
number of characters in each font if I have written it right.
Public Sub ListFontsInDoc()
Dim FontList(199) As String
Dim FontFreq(199) as Integer
Dim FontFr as Integer
Dim FontCount As Integer
Dim FontName As String
Dim FontNameOfLastChar as String
Dim J As Integer, K As Integer, L As Integer
Dim X As Long, Y As Long
Dim FoundFont As Boolean
Dim rngChar As Range
Dim strFontList As String
FontCount = 0
X = ActiveDocument.Characters.Count
Y = 0
FontNameOfLastChar="###" ' no such font
' For-Next loop through every character
For Each rngChar In ActiveDocument.Characters
Y = Y + 1
FontName = rngChar.Font.Name
StatusBar = Y & ":" & X
If FontName <> FontNameOfLastChar then ' font has changed
FontNameOfLastChar = FontName ' for next time
' check if font used for this char already in list
FoundFont = False
For J = 1 To FontCount
If FontList(J) = FontName Then
FoundFont = True
FontFreq(j) = FontFreq(j) + 1 ' used again
Exit For ' no sense looking when we have already found
End if
Next J
If Not FoundFont Then
FontCount = FontCount + 1
FontFreq(FontCount) = 1 ' first instance
FontList(FontCount) = FontName
End If
End if
Next rngChar
' sort the list - A shell sort would be better but the list should be
small
StatusBar = "Sorting Font List"
For J = 1 To FontCount - 1
L = J
For K = J + 1 To FontCount
If FontList(L) > FontList(K) Then
L = K
Exit For ' Again, no sense in searching when we have already
found
End if
Next K
If J <> L Then
FontName = FontList(J)
FontList(J) = FontList(L)
FontList(L) = FontName
FontFr = FontFreq(J)
FontFreq(J) = FontFreq(L)
FontFreq(L) = FontFr
End If
Next J
StatusBar = ""
' put in new document
Documents.Add
Selection.TypeText Text:="There are " & _
FontCount & " fonts used in the document, as follows:"
Selection.TypeParagraph
Selection.TypeParagraph
For J = 1 To FontCount
Selection.TypeText Text:=FontList(J) & " used" & FontFreq(J) & "
times"
Selection.TypeParagraph
Next J
End Sub
________________________________
Subject: [program-l] Re: Odd Word Request
Date: Fri, 21 May 2010 16:15:21 +0100
From: george@xxxxxxxxxxxxxxxxxxx
To: program-l@xxxxxxxxxxxxx
I'm the first to appreciate that then end-users get involved in
design, it very often results in "Bloatware".
However, looking at it from a functionality point of view as a
proverbial end-user, I have to say that I'd like two things.
1) The resultant font list in Alphabetical order.
2) An option to include the number of non-contiguous occurrence.
In the first case, it's easier for looking up against other lists.
In the second, I need to know the seriousness of the usage in order to
determine if I have to distribute a special font - particularly as I'm
currently dealing with Mathematics.
George.
From: program-l-bounce@xxxxxxxxxxxxx
[mailto:program-l-bounce@xxxxxxxxxxxxx] On Behalf Of Mark Long
Sent: 21 May 2010 15:41
To: program-l@xxxxxxxxxxxxx
Subject: [program-l] Re: Odd Word Request
No doubt - but you would be looking at an improvement of a few
milliseconds rather than another order of magnitude. In this case, we
probably don't need them sorting anyhow.
There is not much point in optimising code that represents a small
fraction of the workload and we know that there are fewer than 200
items and more than 80,000 characters to check. I would be happy to
see how others would tighten the code still further though.
Mark
________________________________
From: dkreynolds@xxxxxxxxxxxx
To: program-l@xxxxxxxxxxxxx
Subject: [program-l] Re: Odd Word Request
Date: Fri, 21 May 2010 14:53:13 +0100
Not exactly the best sorting algorithm I've seen. It is the slowest
sorting method, and I'd hazard a guess that if you used something
other than bubble, it would run even quicker.
________________________________
From: program-l-bounce@xxxxxxxxxxxxx
[mailto:program-l-bounce@xxxxxxxxxxxxx] On Behalf Of Mark Long
Sent: 21 May 2010 13:04
To: program-l@xxxxxxxxxxxxx
Subject: [program-l] Re: Odd Word Request
So, probably not worth optimising the sort algorithm then </smile>
It is amazing how much difference you can make by removing unnecessary
work from an algorythm.
Glad that you are pleased.
Mark
________________________________
Subject: [program-l] Re: Odd Word Request
Date: Fri, 21 May 2010 12:48:53 +0100
From: george@xxxxxxxxxxxxxxxxxxx
To: program-l@xxxxxxxxxxxxx
Wow! - Did that ever improve performance. It had taken at least 10
minutes previously, but worked in 2-3 seconds with your version.
Many thanks indeed, Mark.
George.
From: program-l-bounce@xxxxxxxxxxxxx
[mailto:program-l-bounce@xxxxxxxxxxxxx] On Behalf Of Mark Long
Sent: 21 May 2010 12:17
To: program-l@xxxxxxxxxxxxx
Subject: [program-l] Re: Odd Word Request
The code is pretty ineffecient though.
Let me see if I can fix that. I haven't tested this but I bet you a
pint that it runs in 10% of the time for a non-trivial document.
Mark
Public Sub ListFontsInDoc()
Dim FontList(199) As String
Dim FontCount As Integer
Dim FontName As String
Dim FontNameOfLastChar as String
Dim J As Integer, K As Integer, L As Integer
Dim X As Long, Y As Long
Dim FoundFont As Boolean
Dim rngChar As Range
Dim strFontList As String
FontCount = 0
X = ActiveDocument.Characters.Count
Y = 0
FontNameOfLastChar="###" ' no such font
' For-Next loop through every character
For Each rngChar In ActiveDocument.Characters
Y = Y + 1
FontName = rngChar.Font.Name
StatusBar = Y & ":" & X
If FontName <> FontNameOfLastChar then ' font has changed
FontNameOfLastChar = FontName ' for next time
' check if font used for this char already in list
FoundFont = False
For J = 1 To FontCount
If FontList(J) = FontName Then
FoundFont = True
Exit For ' no sense looking when we have already found
End if
Next J
If Not FoundFont Then
FontCount = FontCount + 1
FontList(FontCount) = FontName
End If
End if
Next rngChar
' sort the list - A shell sort would be better but the list should be
small
StatusBar = "Sorting Font List"
For J = 1 To FontCount - 1
L = J
For K = J + 1 To FontCount
If FontList(L) > FontList(K) Then
L = K
Exit For ' Again, no sense in searching when we have already
found
End if
Next K
If J <> L Then
FontName = FontList(J)
FontList(J) = FontList(L)
FontList(L) = FontName
End If
Next J
StatusBar = ""
' put in new document
Documents.Add
Selection.TypeText Text:="There are " & _
FontCount & " fonts used in the document, as follows:"
Selection.TypeParagraph
Selection.TypeParagraph
For J = 1 To FontCount
Selection.TypeText Text:=FontList(J)
Selection.TypeParagraph
Next J
End Sub
> Subject: [program-l] Re: Odd Word Request
> Date: Fri, 21 May 2010 11:30:20 +0100
> From: george@xxxxxxxxxxxxxxxxxxx
> To: program-l@xxxxxxxxxxxxx
>
> By heck, Pranav! It even works! Takes a heck of a while, but
> obviously in my case has to look at around 80,000 characters.
>
> And what's more, I actually managed to do it in that awful Word
2007!
>
> Bless you, and may all your code compile flawlessly.
>
> George.
>
> -----Original Message-----
> From: program-l-bounce@xxxxxxxxxxxxx
> [mailto:program-l-bounce@xxxxxxxxxxxxx] On Behalf Of Pranav Lal
> Sent: 21 May 2010 10:21
> To: program-l@xxxxxxxxxxxxx
> Subject: [program-l] Re: Odd Word Request
>
> George,
>
> A quick search on the words get list of fonts used in word document
> leads me to the following macro from the link
>
http://word.tips.net/Pages/T001522_Creating_a_Document_Font_List.html.
> Public Sub ListFontsInDoc()
> Dim FontList(199) As String
> Dim FontCount As Integer
> Dim FontName As String
> Dim J As Integer, K As Integer, L As Integer
> Dim X As Long, Y As Long
> Dim FoundFont As Boolean
> Dim rngChar As Range
> Dim strFontList As String
>
> FontCount = 0
> X = ActiveDocument.Characters.Count
> Y = 0
> ' For-Next loop through every character
> For Each rngChar In ActiveDocument.Characters
> Y = Y + 1
> FontName = rngChar.Font.Name
> StatusBar = Y & ":" & X
> ' check if font used for this char already in list
> FoundFont = False
> For J = 1 To FontCount
> If FontList(J) = FontName Then FoundFont = True
> Next J
> If Not FoundFont Then
> FontCount = FontCount + 1
> FontList(FontCount) = FontName
> End If
> Next rngChar
>
> ' sort the list
> StatusBar = "Sorting Font List"
> For J = 1 To FontCount - 1
> L = J
> For K = J + 1 To FontCount
> If FontList(L) > FontList(K) Then L = K
> Next K
> If J <> L Then
> FontName = FontList(J)
> FontList(J) = FontList(L)
> FontList(L) = FontName
> End If
> Next J
>
> StatusBar = ""
> ' put in new document
> Documents.Add
> Selection.TypeText Text:="There are " & _
> FontCount & " fonts used in the document, as follows:"
> Selection.TypeParagraph
> Selection.TypeParagraph
> For J = 1 To FontCount
> Selection.TypeText Text:=FontList(J)
> Selection.TypeParagraph
> Next J
> End Sub
>
> On 5/21/10, George Bell <george@xxxxxxxxxxxxxxxxxxx> wrote:
> > Before I start a soul destroying Google search, does anyone know
of
> a
> > quick and easy way to obtain a list of fonts used in a Word 2003
> > Document?
> >
> >
> >
> > I have to produce a fairly complex braille mathematics notation
> > document, and need to know of any non-standard system fonts used.
> > (Aside from 9 specific ones which will be distributed with the
> > document).
> >
> >
> >
> > This would not be a problem were it not for the fact that even
> > embedding of fonts in Word is ignored by the mathematics software
> > whose equations are also embedded in the document.
> >
> >
> >
> > George.
> >
> >
> >
> >
> ** To leave the list, click on the immediately-following link:-
> ** [mailto:program-l-request@xxxxxxxxxxxxx?subject=unsubscribe]
> ** If this link doesn't work then send a message to:
> ** program-l-request@xxxxxxxxxxxxx
> ** and in the Subject line type
> ** unsubscribe
> ** For other list commands such as vacation mode, click on the
> ** immediately-following link:-
> ** [mailto:program-l-request@xxxxxxxxxxxxx?subject=faq]
> ** or send a message, to
> ** program-l-request@xxxxxxxxxxxxx with the Subject:- faq
> ** To leave the list, click on the immediately-following link:-
> ** [mailto:program-l-request@xxxxxxxxxxxxx?subject=unsubscribe]
> ** If this link doesn't work then send a message to:
> ** program-l-request@xxxxxxxxxxxxx
> ** and in the Subject line type
> ** unsubscribe
> ** For other list commands such as vacation mode, click on the
> ** immediately-following link:-
> ** [mailto:program-l-request@xxxxxxxxxxxxx?subject=faq]
> ** or send a message, to
> ** program-l-request@xxxxxxxxxxxxx with the Subject:- faq
__________ Information from ESET Smart Security, version of virus
signature database 5134 (20100521) __________
The message was checked by ESET Smart Security.
http://www.eset.com <http://www.eset.com/>
__________ Information from ESET Smart Security, version of virus
signature database 5134 (20100521) __________
The message was checked by ESET Smart Security.
http://www.eset.com <http://www.eset.com/>
__________ Information from ESET Smart Security, version of virus
signature database 5135 (20100521) __________
The message was checked by ESET Smart Security.
http://www.eset.com <http://www.eset.com/>
__________ Information from ESET Smart Security, version of virus
signature database 5135 (20100521) __________
The message was checked by ESET Smart Security.
http://www.eset.com <http://www.eset.com/>
Other related posts:
