Создание текстового файла и ввод текста в файл

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 на основе таблицы Excel

Sub 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

Посмотреть все файлы в каталоге_1

Sub 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

Посмотреть все файлы в каталоге_3

' Объявление 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 BrowseFolder1()

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) = strPath & 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

 

Глава 3. Рабочая область Microsoft Excel

Рабочая книга

Количество имен рабочей книги

Sub CountNames()

Dim intNamesCount As Integer

' Получаем и отображаем количество имен на активном _

листе рабочей книги

intNamesCount = Names.Count

If intNamesCount = 0 Then

MsgBox "Имен нет"

Else

MsgBox "Имен: " & intNamesCount & " шт."

End If

End Sub

Защита рабочей книги

Sub Worksheet_BeforeRightClick(ByVal Target As Range, _

 Cancel As Boolean)

If Target.Address = "$D$2" Then

' Установка защиты рабочей книги (с паролем "123", _

  включенной защитой структуры книги и защитой расположения _

  окон)

ThisWorkbook.Protect "123", True, True

' Указание не обрабатывать нажатие кнопки мыши _

  в этой ячейке

Cancel = True

ElseIf Target.Address = "$E$5" Then

' Снятие защиты с книги (необходимо указать ранее установленный _

  пароль)

ThisWorkbook.Unprotect "123"

Cancel = True

End If

End Sub

Запрет печати книги

Sub Workbook_BeforePrint(Cancel As Boolean)

' Установка флага в True заставляет Exсel игнорировать команду _

отправки книги на печать

Cancel = True

End Sub

Открытие книги (или текстовых файлов)

Sub Test()

 Application.Workbooks.Open ("c:\file_03.txt")

End Sub

Открытие книги и добавление в ячейку А1 текста

Dim Ex As New Excel.Application

Ex.Workbooks.Open "Путь к Файлу"

Ex.Visible = False

'В ячейку "A2" добавляем "Visual Basic"

Ex.ActiveWorkbook.Sheets.Application.Range("A2") = "Visual Basic"

Ex.ActiveWorkbook.Save

Ex.ActiveWorkbook.Close

Сколько книг открыто

Sub Test()

 MsgBox (Str(Application.Workbooks.Count))

End Sub

Закрытие всех книг

Sub Test()

 Application.Workbooks.Item(1).Close ‘(expression.Close(SaveChanges, FileName, RouteWorkbook)

End Sub

 

Закрытие рабочей книги только при выполнении условия

Sub Workbook_BeforeClose(Cancel As Boolean)

If Range("A1").Value <> "Можно закрывать" Then

' Условие закрытия не выполнено. Укажем Exсel игнорировать _

  команду

Cancel = True

End If

End Sub

Сохранение рабочей книги с именем, представляющим собой текущую дату

Sub SaveAsDate()

Dim strDate As String

' Получение текущей даты и представление ее в формате "ддммгг"

strDate = Format(Now(), "ddmmyy")

' Сохранение книги в текущую папку под новым именем

ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & strDate

End Sub

Сохранена ли рабочая книга

Function dhBookIsSaved() As Boolean

' Если путь файла рабочей книги не задан, то она _

не сохранена (ThisWorkbook.path равняется "")

dhBookIsSaved = ThisWorkbook.path <> ""

End Function

 

Создать книгу с одним листом

Sub NewOneSheetBook()

Workbooks.Add xlWBATWorksheet

End Sub

Создать книгу

Sub Test()

 Application.Workbooks.Add ("Êíèãà")

End Sub

Удаление ненужных имен

Sub EraseNames()

Dim nmName As Name

Dim strMessage As String

' Проверка наличия в книге определенных имен

If ThisWorkbook.Names.Count = 0 Then

' В книге нет определенных имен

MsgBox "Имена не определены"

   Exit Sub

End If

 

' Просмотр всей коллекции определенных имен и удаление тех, _

которые пользователю не нужны

For Each nmName In ThisWorkbook.Names

With nmName

    ' Спрашиваем пользователя о необходимости удалить _

     найденное имя

    strMessage = "Удалить имя " &.Name & "? " & vbCr & _

     "относящееся к " &.RefersTo

    If MsgBox(strMessage, vbYesNo + vbQuestion) = vbYes Then

       ' Имя можно удалить

      .Delete

    End If

End With

Next

End Sub

Быстрое размножение рабочей книги

Sub DuplicateBook()

Dim avarFileNames As Variant

' Формирование массива из путей для копий книги

avarFileNames = Array("C:\" & _

ActiveWorkbook.Name, "D:\" & ActiveWorkbook.Name)

' Сохранение книги

ActiveWorkbook.SaveAs avarFileNames

End Sub

 

Сортировка листов

Sub SortSheets()

Dim astrSheetNames() As String ' Массив для хранения имен листов

Dim intSheetCount As Integer

Dim i As Integer

Dim objActiveSheet As Object

 

 ' Если нет активной рабочей книги - закрыть процедуру

If ActiveWorkbook Is Nothing Then Exit Sub

 

' Проверка защищенности структуры рабочей книги

If ActiveWorkbook.ProtectStructure Then

   ' Сортировка листов защищенной рабочей книги невозможна

   MsgBox "Структура книги " & ActiveWorkbook.Name & _

    " защищена. Сортировка листов невозможна.", _

    vbCritical

   Exit Sub

End If

 

' Сохраняем ссылку на активный лист книги

Set objActiveSheet = ActiveSheet

 

' Отключение сочетания клавиш Ctrl+Pause Break

Application.EnableCancelKey = xlDisabled

' Отключение обновления экрана

Application.ScreenUpdating = False

 

intSheetCount = ActiveWorkbook.Sheets.Count

' Заполнение массива astrSheetNames именами листов книги

ReDim astrSheetNames(1 To intSheetCount)

For i = 1 To intSheetCount

   astrSheetNames(i) = ActiveWorkbook.Sheets(i).Name

Next i

 

' Сортировка массива имен в порядке возрастания

Call Sort(astrSheetNames)

' Перемещение листов книги

For i = 1 To intSheetCount

   ActiveWorkbook.Sheets(astrSheetNames(i)).Move _

    ActiveWorkbook.Sheets(i)

Next i

 

' Переход на исходный рабочий лист

objActiveSheet.Activate

' Включение обновления экрана

Application.ScreenUpdating = True

' Включение сочетания клавиш Ctrl+Pause Break

Application.EnableCancelKey = xlInterrupt

End Sub

 

Sub Sort(astrNames() As String)

' Сортировка массива строк по алфавиту (в порядке возрастания)

Dim i As Integer, j As Integer

Dim strBuffer As String

Dim fBuffer As Boolean

 

For i = LBound(astrNames) To UBound(astrNames) - 1

   For j = i + 1 To UBound(astrNames)

       If astrNames(i) > astrNames(j) Then

           ' Меняем i-й и j-й элементы массива местами

           strBuffer = astrNames(i)

           astrNames(i) = astrNames(j)

           astrNames(j) = strBuffer

       End If

   Next j

Next i

End Sub

Поиск максимального значения на всех листах книги

Function dhMaxInBook(cell As Range) As Double

Dim sheet As Worksheet

Dim dblMax As Double

Dim dblResult As Double

Dim fFirst As Boolean

fFirst = True

 

' Расчет максимальных значений на всех листах рабочей книги _

и выбор наибольшего из них

For Each sheet In cell.Parent.Parent.Worksheets

' Расчет максимального значения на листе

dblResult = Application.WorksheetFunction.Max(sheet.UsedRange)

 

If fFirst Then

    ' Найдено первое значение - его не с чем сравнивать

    dblMax = dblResult

    fFirst = False

End If

' Выбираем большее из dblMax и dbmResult

If dblResult > dblMax Then

    dblMax = dblResult

End If

Next sheet

' Возврат результата

dhMaxInBook = dblMax

End Function

 

 

Рабочий лист