Sub Файлообьединялка()
ReDim ListBox1__$(3)
ListBox1__$(0) = "По имени"
ListBox1__$(1) = "По типу"
ListBox1__$(2) = "По дате"
ListBox1__$(3) = "По размеру"
ReDim ListBox2__$(1)
ListBox2__$(0) = "По возрастанию"
ListBox2__$(1) = "По убыванию"
ReDim ComboBox1__$(3)
ComboBox1__$(0) = "txt"
ComboBox1__$(1) = "doc"
ComboBox1__$(2) = "htm"
ComboBox1__$(3) = "html"
' ComboBox1__$(2) = "rtf"
WordBasic.BeginDialog 500, 335, "Файлообьединялка"
WordBasic.Text 20, 6, 480, 13, "       Данная макрокоманда предназначена для обьединения"
WordBasic.Text 20, 26, 480, 13, "содержимого большого количества однотипных документов в один. "
WordBasic.Text 60, 48, 380, 13, " Укажите, пожалуйста, нужные опции и нажмите ОК."
WordBasic.Text 150, 70, 250, 13, "Обьединять файлы с расширением:"
WordBasic.ComboBox 400, 70, 65, 60, ComboBox1__$(), "ComboBox1"
WordBasic.Text 50, 90, 150, 13, "Сортировать файлы:"
WordBasic.ListBox 20, 110, 140, 50, ListBox1__$(), "ListBox1"
WordBasic.ListBox 160, 120, 142, 33, ListBox2__$(), "ListBox2"
WordBasic.Text 70, 170, 250, 13, "Обьединять файлы, находящиеся:"
WordBasic.OptionGroup "OptionGroup1"
WordBasic.OptionButton 20, 185, 480, 16, "В выбираемой папке (не обращайте внимание на заголовок окна)", "OptionButton1"
WordBasic.OptionButton 20, 203, 480, 16, "В папке, где находится активный документ", "OptionButton2"
WordBasic.Text 20, 275, 240, 13, "Вставлять содержимое файлов:"
WordBasic.OKButton 340, 140, 140, 40
WordBasic.CheckBox 50, 230, 420, 13, "Включать в разделитель между файлами имена файлов", "CheckBox1"
WordBasic.CheckBox 50, 253, 420, 13, "Не обновлять экран во время работы", "CheckBox2"
WordBasic.OptionGroup "OptionGroup2"
WordBasic.OptionButton 30, 291, 200, 16, "В отдельный документ", "OptionButton3"
WordBasic.OptionButton 30, 310, 200, 16, "В активный документ", "OptionButton4"
WordBasic.CancelButton 290, 285, 185, 21
WordBasic.Text 350, 320, 140, 13, "Орлов А.А., 1999 г."
WordBasic.EndDialog
Dim dlg As Object: Set dlg = WordBasic.CurValues.UserDialog
dlg.ComboBox1 = "txt"
dlg.CheckBox1 = 1
dlg.CheckBox2 = 1
ggg:
On Error GoTo -1: On Error GoTo bye
    WordBasic.Dialog.UserDialog dlg
    If dlg.CheckBox2 = 1 Then Application.ScreenUpdating = False
typef = dlg.ComboBox1
sortir = dlg.ListBox1 + 1
sortir2 = dlg.ListBox2 + 1
gde = dlg.OptionGroup1
kuda = dlg.OptionGroup2
imrazd = dlg.CheckBox1
hjo:
If gde = 0 Then
Set dlg1 = Dialogs(wdDialogCopyFile)
    hh = dlg1.Display
    If hh <> -1 Then GoTo bye
    a$ = dlg1.Directory
ttt$ = Right(a$, 2)
If ttt$ = "\" + Chr$(34) Then
    tttt = Len(a$)
    a$ = Left(a$, tttt - 2) + Chr$(34)
End If
way = a$
GoTo dal
End If
If Documents.Count = 0 Then
   fff = MsgBox("Нет открытых документов. Создать новый документ и вставить туда содержимое указанной Вами директории?", 36, "Файлообьединялка")
    If fff = 7 Then GoTo bye
    Documents.Add
    kuda = 1
    gde = 0
    GoTo hjo
End If
If Not ActiveDocument.Path = "" Then
    way = ActiveDocument.Path
    GoTo dal
End If
    fff = MsgBox("Ваш файл не сохранен ни в какой директории. Сохраните его в директории, файлы из которой Вы хотите обьединить.", 49, "Файлообьединялка")
        If fff = 2 Then GoTo bye
    hh = Dialogs(wdDialogFileSaveAs).Show
        If hh <> -1 Then GoTo bye
    way = ActiveDocument.Path
dal:
If kuda = 0 Then Documents.Add
If kuda = 1 And Documents.Count = 0 Then
   fff = MsgBox("Нет открытых документов. Создать новый документ и вставить все туда?", 36, "Файлообьединялка")
    If fff = 7 Then GoTo bye
    Documents.Add
End If
If kuda = 1 Then dsa = ActiveDocument.FullName Else dsa = ""
With Application.FileSearch
    .NewSearch
    .LookIn = way
    .FileName = "*." + typef
    .SearchSubFolders = False
    .MatchTextExactly = True
    .FileType = msoFileTypeAllFiles
If .Execute(SortBy:=sortir, SortOrder:=sortir2) = 0 Then GoTo pusto
For qqq = 1 To .FoundFiles.Count
If .FoundFiles(qqq) = dsa Then GoTo ytr
If imrazd = 1 Then Selection.TypeText Text:=Chr$(13) + "***********************************" + Chr$(13) + "Файл " + .FoundFiles(qqq) + Chr$(13) + "***********************************" + Chr$(13)
    Documents.Open FileName:=.FoundFiles(qqq), ConfirmConversions:=False, AddToRecentFiles:=False, Format:=wdOpenFormatAuto
    Selection.WholeStory
    Selection.Copy
ActiveDocument.Close
    Selection.Paste
Selection.TypeText Text:=Chr$(13) + "***********************************" + Chr$(13) + Chr$(13)
ytr:
Next qqq
End With
fff = MsgBox("Все документы c расширением ." + typef + " из выбранной Вами директории " + way + " объединены в активном документе. Для оптимизации кодировки, если такая необходимость возникнет, используйте макрос Encoding Changer Macro 98 из библиотеки Microsoft Office Extensions: www.microsoft.com/rus/offext/a1.asp#A124.", 64, "Файлообьединялка")
GoTo bye
pusto:
fff = MsgBox("В директории " + way + " нет файлов с расширением " + typef + ". Выберите другую директорию или укажите другое расширение.", 16, "Файлообьединялка")
GoTo ggg
bye:
Application.ScreenUpdating = True
End Sub