Public Function GetWDFiles(ByRef astrWDFiles() As String, _
      ByVal strLookIn As String, Optional fSearchSubfolders _
      As Boolean = False) As Boolean

  Dim nFilesCnt   As Long
  Dim nFile       As Long
  Dim nCounter    As Long
  Dim strFileName As String
  Dim strFile     As String

  On Error Resume Next
  With Application.FileSearch
    .NewSearch
    .LookIn = strLookIn
    .SearchSubFolders = fSearchSubfolders
    .FileName = ".doc"
    .FileType = msoFileTypeWordDocuments

    If .Execute(SortBy:=msoSortByFileName, _
            SortOrder:=msoSortOrderAscending, _
            AlwaysAccurate:=True) > 0 Then

      nFilesCnt = .FoundFiles.Count
      ReDim astrWDFiles(0 To nFilesCnt - 1)

      nCounter = -1
      For nFile = 1 To nFilesCnt
        strFileName = .FoundFiles(nFile)
        strFile = Dir$(strFileName)
        If Len(strFile) > 0 And Left$(strFile, 1) <> "~" Then
          nCounter = nCounter + 1
          astrWDFiles(nCounter) = strFileName
        End If
      Next

      If nCounter > -1 Then
        ReDim Preserve astrWDFiles(0 To nCounter)
        GetWDFiles = True
      End If
    End If
  End With
  On Error GoTo 0
End Function

Public Sub Demo()
  Dim strPath       As String
  Dim astrWDFiles() As String
  Dim nFile         As Long

  strPath = "c:\temp"

  If Len(Dir$(strPath, vbDirectory)) > 0 Then
    If GetWDFiles(astrWDFiles(), strPath, True) Then
      For nFile = 0 To UBound(astrWDFiles)
        Debug.Print astrWDFiles(nFile)
      Next
      Erase astrWDFiles

    Else
      MsgBox "Keine Word-Dokumente im Verzeichnis " & _
            vbCrLf & strPath & vbCrLf & "gefunden!", _
            vbInformation, "VB-fun-Demo"
    End If
  Else
    MsgBox "Das Verzeichnis " & vbCrLf & strPath & vbCrLf & _
          "existiert nicht!", vbInformation, "VB-fun-Demo"
  End If
End Sub