Warum läuft dieser Code nicht?

Option Explicit
Sub ListMacros()
Dim oApp As Word.Application
Dim myProject As VBProject
Dim myComponent As VBComponent
Dim strNames As Variant, strDocNames As String
Dim strFile() As String
Dim iCount As Integer
Dim strProc As String
'Set oApp = GetObject(, "Word.Application")
' Alle Projekte durchlaufen
For Each myProject In VBE.VBProjects
strNames = ""
' Nur ungeschützte berücksichtigen
If myProject.Protection = vbext_pp_none Then
On Error Resume Next
If myProject.VBComponents.Count > 1 Then
strFile() = Split(myProject.Filename, "\")
strNames = strNames & myProject.Name & " (" & _
strFile(UBound(strFile())) & ")" & vbCrLf
On Error GoTo 0
' Alle Module durchlaufen
For Each myComponent In myProject.VBComponents
With myComponent
' Modul-Typ ermitteln
If .Type = vbext_ct_StdModule Then
strNames = strNames & vbTab & .Name & vbTab & " (bas)" & vbCrLf
ElseIf .Type = vbext_ct_ClassModule Then
strNames = strNames & vbTab & .Name & vbTab & " (cls)" & vbCrLf
ElseIf .Type = vbext_ct_MSForm Then
strNames = strNames & vbTab & .Name & vbTab & " (frm)" & vbCrLf
ElseIf .Type = vbext_ct_Document Then
strNames = strNames & vbTab & .Name & vbTab & " (doc)" & vbCrLf
End If
' Declaration auslesen
If .CodeModule.CountOfDeclarationLines > 0 Then
For iCount = 1 To .CodeModule.CountOfDeclarationLines
If .CodeModule.Lines(iCount, 1)  "" Then
strNames = strNames & vbTab & vbTab & "Declaration" & vbTab & " (" & _
.CodeModule.CountOfDeclarationLines & " Z.)" & vbCrLf
Exit For
End If
Next iCount
End If
' Prozeduren auslesen
strProc = ""
For iCount = 1 To .CodeModule.CountOfLines
If .CodeModule.ProcOfLine(iCount, vbext_pk_Proc)  strProc Then
strProc = .CodeModule.ProcOfLine(iCount, vbext_pk_Proc)
strNames = strNames & vbTab & vbTab & strProc & vbTab & " (" & _
.CodeModule.ProcCountLines(strProc, vbext_pk_Proc) & " Z.)" & vbCrLf
End If
Next iCount
End With
Next myComponent
'MsgBox strNames
strDocNames = strDocNames & strNames & vbCrLf
End If
End If
Next myProject
' In Dokument ausgeben
Dim oDoc As Document
Set oDoc = Documents.Add
oDoc.Range.InsertAfter strDocNames
End Sub