Retrieve the Font Type and Size Using VBA

[Kumar]

Hi All,

I'm working on a web application and I'm trying to retrieve the Font type and font size of the all the text contined in the page using the VBA. Please reply with your thoughts.

[macropod]

Hi Kumar,

If you copy & paste the HTML into a Word document, the following 'ExtractFontData' macro should achieve that you're after:
Option Explicit
Dim SBar As Boolean ' Status Bar flag
Dim TrkStatus As Boolean ' Track Changes flag
Private Sub MacroEntry()
' Store current Status Bar status, then switch on
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
' Store current Track Changes status, then switch off
With ActiveDocument
TrkStatus = .TrackRevisions
.TrackRevisions = False
End With
' Turn Off Screen Updating
Application.ScreenUpdating = False
End Sub
Private Sub MacroExit()
' Clear the Status Bar
Application.StatusBar = False
' Restore original Status Bar status
Application.DisplayStatusBar = SBar
' Restore original Track Changes status
ActiveDocument.TrackRevisions = TrkStatus
' Restore Screen Updating
Application.ScreenUpdating = True
End Sub
Sub ExtractFontData()
Dim i As Long, j As Long
Dim eTime As Single
eTime = Timer
Call MacroEntry
Dim oPara As Paragraph
With ActiveDocument
For Each oPara In .Paragraphs
' Delete paragraphs that don't have "font: " as the first printable string
If InStr(Trim(Replace(oPara.Range.Text, vbTab, "")), "font: ") <> 1 Then oPara.Range.Delete
' Clean up any tabs
If InStr(Trim(oPara.Range.Text), vbTab) <> 0 Then oPara.Range.Text = Trim(Replace(oPara.Range.Text, vbTab, ""))
' Clear out any double spaces
If InStr(oPara.Range.Text, " ") <> 0 Then oPara.Range.Text = Replace(oPara.Range.Text, " ", " ")
Next
If .Paragraphs.Count > 1 Then
' Loop backwards to preserve paragraph count & indexing.
' Start at 2nd-last paragraph.
For i = .Paragraphs.Count - 1 To 1 Step -1
' Loop backwards to preserve paragraph count & indexing.
' Stop atlast preceding paragraph.
For j = .Paragraphs.Count To i + 1 Step -1
' Report progress on Status Bar.
Application.StatusBar = i & " paragraphs to check. "
' No point in checking paragraphs of unequal length.
If Len(.Paragraphs(i).Range) = Len(.Paragraphs(j).Range) Then
' Test strings of paragraphs of equal length.
If .Paragraphs(i).Range = .Paragraphs(j).Range Then
' Delete duplicate paragraph.
.Paragraphs(j).Range.Delete
End If
End If
Next
Next
End If
End With
' Report time taken. Elapsed time calculation allows for execution to extend past midnight.
MsgBox "Finished. Elapsed time: " & (Timer - eTime + 86400) Mod 86400 & " seconds."
Call MacroExit
End Sub

[Kumar]

Hi Macropad,Thanks for ur reply.Here u have used the document and had taken the Font Detasils.Can we directly get the font details.For example let it be an Google page, In that i need the size of all the links present in Google Search Page.

[macropod]

Hi Kumar,

I suppose it might be possible, but that's outside my area of expertise. In any event, copying the HTML code for a web page & pasting it into Word for processing is a trivial task.