Готовые макросы в VBA Excel, Миронов. Готовые макросы в vba excel, Миронов Глава Макросы 9

• Название: Готовые макросы в vba excel, Миронов Глава Макросы 9
• Дата: 23.01.2019
• Размер: 1.35 Mb.
• Имя файла: Готовые макросы в VBA Excel, Миронов.doc
• Тип: Документы; #64865
• страница: 34 из 47

Вызов предварительного просмотра

Sub Test()

With Application.Workbooks.Item("Test.xls")

Sheets("Test").PrintPreview

End With

End Sub

Настройка ввода данных в диалоговом окне

Sub DialogInputData()

Dim intMin As Integer, intMax As Integer ' Диапазон значений

Dim strInput As String ' Введенная пользователем строка

Dim strMessage As String

Dim intValue As Integer

intMin = 1 ' Минимальное значение

intMax = 50 ' Максимальное значение

strMessage = "Введите значение от " & intMin & " до " & intMax

' Ввод значения (цикл завершается, когда пользователь вводит _

значение из заданного диапазона или отменяет ввод)

Do

strInput = InputBox(strMessage)

If strInput = "" Then Exit Sub ' Отмена ввода

' Проверка, содержит ли введенная пользователем строка число

If IsNumeric(strInput) Then

intValue = CInt(strInput)

' Проверка, удовлетворяет ли значение диапазону

If intValue >= intMin And intValue <= intMax Then

' Все условия выполнены

Exit Do

End If

End If

' Формирование сообщения с текстом ошибки

strMessage = "Вы ввели некорректное значение." & vbNewLine & _

"Введите число от " & intMin & " до " & intMax

Loop

' Внесение данных в ячейку

ActiveSheet.Range("A1").Value = strInput

End Sub

Открытие диалогового окна (“Открыть файл”)_1

Sub Test()

Application.Dialogs(xlDialogOpen).Show "*.dbf"

End Sub

Открытие диалогового окна (“Открыть файл”)_2

fileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")

If fileToOpen <> False Then

MsgBox "Open " & fileToOpen

End If

Открытие диалогового окна (“Печать”)

Application.Dialogs(xlDialogPrint).Show

Другие диалоговые окна

xlDialogClear - очистка ячейки или диапазона

xlDialogDisplay - параметры отображения ячеек

xlDialogFileDelete - удаление файла

xlDialogSaveWorkbook - сохранить книгу

xlDialogSearch - поиск в документе

xlDialogWorkbookName - переименование листа

Вызов броузера из Экселя

Надо создать кнопку которой добавить код:

Sub Button1_Click()

Call ShellExecute(GetDesktopWindow, "Open", "www.armentel.com/avb", "", "c:\", SW_SHOWNORMAL)

End Sub

И функция:

Private Declare Function ShellExecute& Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal _

lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _

ByVal nShowCmd As Long)

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Const SW_SHOWNORMAL = 1

Диалоговое окно ввода данных

Sub InputDialog()

Dim strInput As String

' Вызов стандартного диалогового окна ввода данных

strInput = InputBox("Введите данные", "Ввод данных")

End Sub

Диалоговое окно настройки шрифта

Sub ShowFontDialog()

' Вызов стандартного окна настройки шрифта текущей ячейки

Application.Dialogs(xlDialogActiveCellFont).Show

End Sub

Значения по умолчанию

Sub NewInputDialog()

Dim strInput As String

' Вызов стандартного диалогового окна ввода со значением _

по умолчанию

strInput = InputBox("Введите данные", "Ввод данных", _

"Значение по умолчанию", 200, 200)

End Sub

Глава .Форматирование текста. Таблицы. ГРАНИЦЫ И ЗАЛИВКА.

Вывод списка доступных шрифтов

Листинг_3.104.'>Листинг 3.104. Список шрифтов

Sub ListOfFonts()

Dim cbrcFonts As CommandBarControl

Dim cbrBar As CommandBar

Dim i As Integer

' Получение доступа к списку шрифтов (элемент управления в виде _

раскрывающегося списка на панели инструментов "Форматирование")

Set cbrcFonts = Application.CommandBars("Formatting"). _

FindControl(ID:=1728)

If cbrcFonts Is Nothing Then

' Панель "Форматирование" не открыта - откроем ее

Set cbrBar = Application.CommandBars.Add

Set cbrcFonts = cbrBar.Controls.Add(ID:=1728)

End If

' Подготовка к выводу шрифтов (очистка ячеек)

Range("A:A").ClearContents

' Вывод списка шрифтов в столбец "A" текущего листа

For i = 0 To cbrcFonts.ListCount - 1

Cells(i + 1, 1) = cbrcFonts.List(i + 1)

Next i

' Закрытие панели инструментов "Форматирование", если мы были _

вынуждены ее открывать

On Error Resume Next

cbrBar.Delete

End Sub

Выбор из текста всех чисел

Листинг 2.48. Функция ExtractNumeric

Function ExtractNumeric(iCell)

' Анализируется каждый символ входной строки iCell

For iCount = 1 To Len(iCell)

' Проверка, является ли анализируемый символ числом

If IsNumeric(Mid(iCell, iCount, 1)) = True Then

' Число добавляется в выходную строку

ExtractNumeric = ExtractNumeric & Mid(iCell, iCount, 1)

End If

Next

End Function

Прописная буква только в начале текста

Листинг 2.49. Функция ПрописнНач

Function ПрописнНач(Текст)

' Пустой текст функция не обрабатывает

If Текст = "" Then ПрописнНач = "<>": Exit Function

' Выделение первого символа и перевод его в верхний регистр

ПервыйСимвол = UCase(Left(Текст, 1))

' Выделение остальной части строки и перевод _

ее в нижний регистр

Обрубок = LCase(Mid(Текст, 2))

' Соединение частей строки и возврат значения

ПрописнНач = ПервыйСимвол & Обрубок

End Function

Подсчет количества повторов искомого текста

Листинг 2.51. Функция CoincideCount

Function CoincideCount(Text, Search)

' Проверка правильности входных данных _

(аргумента Search)

If IsArray(Search) = True Then Exit Function

If IsError(Search) = True Then Exit Function

If IsEmpty(Search) = True Then Exit Function

' Просмотр заданного в параметре Text диапазона

For Each iCell In Text

' Анализируются только ячейки, содержащие _

корректные значения

If Not IsError(iCell) Then

' iText - строка для просмотра (в нижнем регистре)

iText = LCase(iCell)

' iSearch - искомое значение (в нижнем регистре)

iSearch = LCase(Search)

' Длина искомой строки

iLen = Len(Search)

' Первый поиск строки iSearch в строке iText _

(этот и последующий поиски производятся без _

учета регистра символов)

iNumber = InStr(iText, iSearch)

While iNumber > 0

' Поиск следующего вхождения строки

iNumber = InStr(iNumber + iLen, iText, iSearch)

' Подсчет количества вхождений

CoincideCount = CoincideCount + vbNull

Wend

End If

Next

End Function

Выделение из текста произвольного элемента

Листинг 2.76. Выделение элемента текста

Function dhGetTextItem(ByVal strTextIn As String, intItem As _

Integer, strSeparator As String) As String

Dim intStart As Integer ' Позиция начала текущего элемента

Dim intEnd As Integer ' Позиция конца текущего элемента

Dim i As Integer ' Номер текущего элемента

' Проверка корректности номера элемента

If intItem < 1 Then Exit Function

' Убираются лишние пробелы, если разделитель - пробел

If strSeparator = " " Then strTextIn = Application.Trim(strTextIn)

' Разделитель добавляется в конец строки

If Right(strTextIn, Len(strTextIn)) <> strSeparator Then _

strTextIn = strTextIn & strSeparator

' Поиск всех элементов в строке до нужного

For i = 1 To intItem

' Начало элемента (перемещение вперед по строке)

intStart = intEnd + 1

' Конец элемента

intEnd = InStr(intStart, strTextIn, strSeparator)

If (intEnd = 0) Then

' Дошли до конца строки, но элемент не нашли

Exit Function

End If

Next i

' Выделение текста из входной строки

dhGetTextItem = Mid(strTextIn, intStart, intEnd - intStart)

End Function

Отображение текста «задом наперед»

Листинг 2.71. Преобразование текста в обратном порядке

Function dhReverseText(strText As String) As String

Dim i As Integer

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

в обратном порядке

For i = Len(strText) To 1 Step -1

dhReverseText = dhReverseText & Mid(strText, i, 1)

Next i

End Function

Sub ReverseText()

Dim strText As String

' Ввод строки посредством стандартного окна ввода

strText = InputBox("Введите текст:")

' Реверсия строки и вывод результата

MsgBox dhReverseText(strText), , strText

End Sub

Англоязычный текст — заглавными буквами

Листинг 2.70. Английский текст — в верхнем регистре

Function dhFormatEnglish(strText As String) As String

Dim i As Integer

Dim strCurChar As String * 1

' Анализируется каждый символ строки strText. Каждый символ _

латинского алфавита преобразуется в верхний регистр

For i = 1 To Len(strText)

strCurChar = Mid(strText, i, 1)

' Код латинских строчных символов лежит в пределах _

от 97 до 122

If Asc(strCurChar) >= 97 And Asc(strCurChar) <= 122 Then

' Переводим символ в верхний регистр

dhFormatEnglish = dhFormatEnglish & UCase(strCurChar)

Else

' Просто добавляем символ в выходную строку

dhFormatEnglish = dhFormatEnglish & strCurChar

End If

Next i

End Function