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