Нужна прога на VBA, которая копировала названия word файлов в excel

Есть папка в которой находятся документы ворда . нужно чтобы их названия скопировались в один экселевский файлик(желательно чтоб название бралось из самого документа(заглавия).

0

Для работы с WORD в REFERENCES необходимо для начала подключить библиотеку 'Microsoft Word Object Library'. После этого в Object Browser станут видны объекты WORD'a которые будут доступны в программе.

На листе Excela поставь кнопку и вставь код:
Private Type BrowseInfo

hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type

Dim strPath As String
Private Declare Function SHBrowseForFolder Lib 'shell32' (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib 'shell32' (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CoTaskMemFree Lib 'ole32.dll' (ByVal hMem As Long)


Private Sub CommandButton1_Click()

Dim objDoc As Word.Document
Dim Fl, k
Dim File, CF, P1, P2, T1, T2

Columns('A').Select
Selection.ClearContents
Range('A1').Select

Const BIF_RETURNONLYFSDIRS = 1, MAX_PATH = 260
Dim intNull As Integer, lngIdList As Long
Dim udtBI As BrowseInfo

With udtBI
.hwndOwner = hwndOwner
.lpszTitle = sPrompt
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lngIdList = SHBrowseForFolder(udtBI)
If lngIdList Then
strPath = String$(MAX_PATH, 0)
SHGetPathFromIDList lngIdList, strPath
CoTaskMemFree lngIdList
intNull = InStr(strPath, vbNullChar)
If intNull Then
strPath = Left$(strPath, intNull - 1)
End If
End If
Range('A1') = strPath


k = 2
strPath = strPath & ' ' ' всё, что было до этого можно выкинуть, если нет необходимости _
выбирать папку. В этом случае: strPath = 'C:путь к файлу'
Fl = Dir(strPath)

Set MyWord = CreateObject('Word.Application')


Do While Fl <> ''
E = Right(Fl, 3)
If E = 'doc' Or E = 'DOC' Then
Cells(k, 1).Value = Fl ' в колонку А заносятся имена файлов *.doc


Set objDoc = MyWord.Documents.Open(strPath & Fl)


' MyWord.Documents.Open FileName:=strPath & Fl

objDoc.SaveAs FileName:='name.txt', FileFormat:=wdFormatText, _
LockComments:=False, Password:='', AddToRecentFiles:=True, WritePassword _
:='', ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False


objDoc.Close False



File = strPath & 'name.txt'
Open File For Binary As #1
'откpоем файл для чтения
CF = Input(FileLen(File), 1)
'загpyзить в пеpеменyю CF вcе cодеpжимое файла
Close #1
Kill File

For i = 1 To Len(CF)
T2 = Asc(Mid(CF, i, 1))
If T2 = 10 Or T2 = 44 Or T2 = 46 Or T2 = 13 Then ' здесь можно менять _
до чего выбирать текст. В данном случае до точки, запятой, перевода каретки и конца абзаца
T1 = Left(CF, i)
GoTo 3


End If
Next i


3:
Cells(k, 2).Value = T1 'в колоку В заносятся часть текста _
выбранного по условию) из документа


k = k + 1
End If

Fl = Dir
Loop

MyWord.Quit False

End Sub