This gives a list of all fonts used, but not the sizes (oh, it takes a while to run, BTW):

Public Sub ListFontsInDoc1()
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