Looping through files in a folder VBA

I have an excel workbook that only has a single button on it the launches the following sub routine.

Sub wordopen()
     
    Dim Word As New Word.Application
    Dim WordDoc As New Word.Document
    Dim Doc As String
    Dim wb1 As Workbook
    Dim Fname2 As String
    Dim intChoice As Integer
    Dim strPath As String
    Dim strFileName As String
    Dim strFolder As String: strFolder = "N:\Public\Park\"
    Dim strFileSpec As String: strFileSpec = strFolder & "*.doc"
    Dim FileList() As String
    Dim intFoundFiles As Integer
strFileName = Dir(strFileSpec)
Do While Len(strFileName) > 0

   Doc = strFolder & strFileName
    Set WordDoc = Word.Documents.Open(Doc)
    Word.Selection.WholeStory
    Word.Selection.Copy
     
    Fname2 = "C:\Users\frogger\Documents\ExcelModuleWordExport\test.xls"
    Set wb2 = Workbooks.Open(Fname2)
 
    wb2.Sheets("Sheet1").Select
    wb2.Sheets("Sheet1").Range("B2").Select
    ActiveSheet.Paste
    WordDoc.Close
    Word.Quit
    ActiveWorkbook.SaveAs Filename:=Left(strFileName, InStrRev(strFileName, ".")) & "xls", FileFormat:=xlWorkbookNormal
    wb2.Close

    ReDim Preserve FileList(intFoundFiles)
    FileList(intFoundFiles) = strFileName
    intFoundFiles = intFoundFiles + 1
    strFileName = Dir
Loop
     
     
    End Sub

Select allOpen in new window

When launched it works the first time through but then when it loops I get a Run-Time 462 and it is on the line where is opens the document

Set WordDoc = Word.Documents.Open(Doc)

Select allOpen in new window

I have set breakpoints and it picks up a new document name just when it goes to open that document, it bombs.