Готовые макросы в VBA Excel, Миронов. Готовые макросы в vba excel, Миронов Глава Макросы 9
 Скачать 1.35 Mb.
|
Создание текстового файла и ввод текста в файлSub Test() Open "c:\2.txt" For Output As #1 Print #1, "Hello File" Close #1 Open "c:\1.txt" For Input As #1 Dim s As String Input #1, s MsgBox s Close #1 End Sub Создание текстового файла и ввод текста (определение конца файла)Sub Test() Open "c:\1.txt" For Output As #1 Print #1, "Hello , File" Close #1 Open "c:\1.txt" For Input As #1 Dim s As String While Not EOF(1) Input #1, s MsgBox s Wend Close #1 End Sub Создание документов Word на основе таблицы ExcelSub ReportToWord() Dim intReportCount As Integer ' Количество сообщений Dim strForWho As String ' Получатель сообщения Dim strSum As String ' Сумма за товар Dim strProduct As String ' Название товара Dim strOutFileName As String ' Имя файла для сохранения сообщения Dim strMessage As String ' Текст дополнительного сообщения Dim rgData As Range ' Обрабатываемые ячейки Dim objWord As Object Dim i As Integer ' Создание объекта Word Set objWord = CreateObject("Word.Application") ' Информация с рабочего листа Set rgData = Range("A1") strMessage = Range("E6") ' Просмотр записей на листе Лист1 intReportCount = Application.CountA(Range("A:A")) For i = 1 To intReportCount ' Динамические сообщения в строке состояния Application.StatusBar = "Создание сообщения " & i ' Назначение данных переменным strForWho = rgData.Cells(i, 1).Value strProduct = rgData.Cells(i, 2).Value strSum = Format(rgData.Cells(i, 3).Value, "#,000") ' Имя файла для сохранения отчета strOutFileName = ThisWorkbook.path & "\" & strForWho & ".doc" ' Передача команд в Word With objWord .Documents.Add With .Selection ' Заголовок сообщения .Font.Size = 14 .Font.Bold = True .ParagraphFormat.Alignment = 1 .TypeText Text:="О Т Ч Е Т" ' Дата .TypeParagraph .TypeParagraph .Font.Size = 12 .ParagraphFormat.Alignment = 0 .Font.Bold = False .TypeText Text:="Дата:" & vbTab & _ Format(Date, "mmmm d, yyyy") ' Получатель сообщения .TypeParagraph .TypeText Text:="Кому: менеджеру " & vbTab & strForWho ' Отправитель .TypeParagraph .TypeText Text:="От:" & vbTab & Application.UserName ' Сообщение .TypeParagraph .TypeParagraph .TypeText strMessage .TypeParagraph .TypeParagraph ' Название товара .TypeText Text:="Продано товара:" & vbTab & strProduct .TypeParagraph ' Сумма за товар .TypeText Text:="На сумму:" & vbTab & _ Format(strSum, "$#,##0") End With ' Сохранение документа .ActiveDocument.SaveAs FileName:=strOutFileName End With Next i ' Удаление объекта Word objWord.Quit Set objWord = Nothing ' Обновление строки состояния Application.StatusBar = False ' Вывод на экран информационного сообщения MsgBox intReportCount & " заметки создано и сохранено в папке " _ & ThisWorkbook.path End Sub Команды создания и удаления каталоговSub Test() MkDir ("c:\test") End Sub И удаляем. Sub Test() RmDir ("c:\test") End Sub Получение текущего каталогаSub Test() MsgBox (CurDir) End Sub Смена каталогаSub Test() ChDir ("c:\windows") MsgBox (CurDir) End Sub Посмотреть все файлы в каталоге_1Sub Test() Dim s As String s = Dir("c:\windows\inf\*.*") Debug.Print s Do While s <> "" s = Dir Debug.Print s Loop End Sub Посмотреть все файлы в каталоге_2' Объявление API-функции для отображения стандартного окна _ просмотра папок Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long ' Объявление API-функции для преобразования данных, возвращаемых _ функцией SHBrowseForFolder, в строку Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _ pszPath As String) As Long ' Структура используется функцией SHBrowseForFolder Type BROWSEINFO hwndOwner As Long ' Родительское окно (для диалога) pidlRoot As Long ' Корневая папка для просмотра strDisplayName As String strTitle As String ' Заголовок окна ulFlags As Long ' Флаги для окна ' Следующие три параметра в VBA не используются lpfn As Long lParam As Long iImage As Long End Type Sub BrowseFolder() Dim strPath As String ' Папка, список файлов которой выводится Dim strFile As String Dim intRow As Long ' Текущая строка таблицы ' Выбор папки strPath = dhBrowseForFolder() If strPath = "" Then Exit Sub If Right(strPath, 1) <> "\" Then strPath = strPath & "\" ' Оформление заголовка отчета ActiveSheet.Cells.ClearContents ActiveSheet.Cells(1, 1) = "Имя файла" ActiveSheet.Cells(1, 2) = "Размер" ActiveSheet.Cells(1, 3) = "Дата/время" ActiveSheet.Range("A1:C1").Font.Bold = True ' Просмотр объектов в папке... ' Первый объект папки strFile = Dir(strPath, 7) intRow = 2 Do While strFile <> "" ' Запись в столбец "A" имени файла ActiveSheet.Cells(intRow, 1) = strFile ' Запись в столбец "B" размера файла ActiveSheet.Cells(intRow, 2) = FileLen(strPath & strFile) ' Запись в столбец "C" времени изменения файла ActiveSheet.Cells(intRow, 3) = FileDateTime(strPath & strFile) ' Следующий объект папки strFile = Dir intRow = intRow + 1 Loop End Sub Function dhBrowseForFolder() As String Dim biBrowse As BROWSEINFO Dim strPath As String Dim lngResult As Long Dim intLen As Integer ' Заполнение полей структуры BROWSEINFO ' Корневая папка - Рабочий стол biBrowse.pidlRoot = 0& ' Заголовок окна biBrowse.strTitle = "Выбор папки" ' Тип возвращаемой папки biBrowse.ulFlags = &H1 ' Вывод стандартного окна просмотра папок lngResult = SHBrowseForFolder(biBrowse) ' Обработка результата работы окна If lngResult Then ' Получение пути (по возвращенным данным) strPath = Space$(512) If SHGetPathFromIDList(ByVal lngResult, ByVal strPath) Then ' Строка пути заканчивается символом Chr(0) intLen = InStr(strPath, Chr$(0)) ' Выделение и возврат пути dhBrowseForFolder = Left(strPath, intLen - 1) Else ' Не удалось получить путь dhBrowseForFolder = "" End If Else ' Пользователь нажал кнопку "Отмена" dhBrowseForFolder = "" End If End Function |