Главная страница
Навигация по странице:

  • Листинг 3.104.

  • Листинг 2.48.

  • Листинг 2.49.

  • Листинг 2.51.

  • Листинг 2.76.

  • Листинг 2.71.

  • Листинг 2.70.

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


    Скачать 1.35 Mb.
    НазваниеГотовые макросы в vba excel, Миронов Глава Макросы 9
    Дата23.01.2019
    Размер1.35 Mb.
    Формат файлаdoc
    Имя файлаГотовые макросы в VBA Excel, Миронов.doc
    ТипДокументы
    #64865
    страница34 из 47
    1   ...   30   31   32   33   34   35   36   37   ...   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
    1   ...   30   31   32   33   34   35   36   37   ...   47


    написать администратору сайта