Главная страница

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


Скачать 1.35 Mb.
НазваниеГотовые макросы в vba excel, Миронов Глава Макросы 9
Дата06.02.2018
Размер1.35 Mb.
Формат файлаdoc
Имя файла33980_7d1642e70814394f108d07a8a2edd23e.doc
ТипДокументы
#35930
страница3 из 47
1   2   3   4   5   6   7   8   9   ...   47

Проверка наличия файла по указанному пути_2


Sub VerifyFileLocation1()

Dim strFileName As String

' Имя искомого файла

strFileName = "C:\Документы\primer.xls"

' Проверка наличия файла (функция Dir возвращает пустую _

строку, если по указанному пути файл обнаружить не удалось)

If Dir(strFileName) <> "" Then

MsgBox "Файл " & strFileName & " найден"

Else

MsgBox "Файл " & strFileName & " не найден"

End If

End Sub

Проверка наличия файла по указанному пути_3


Sub Check_Disk()

On Error Resume Next

If Dir("\\192.168.1.200\c\", vbSystem) <> "" Then

If Err = 52 Then

Err.Clear

MsgBox "Диска нет!", 48, "Ошибка"

Exit Sub

End If

If Err <> 0 Then

MsgBox "Произошло ошибка!", 48, "Ошибка"

Exit Sub

Else

On Error GoTo 0

MsgBox "Диск есть!", 64, ""

End If

End If

End Sub

Поиск нужного файла_1


Sub FileSearch()

Dim strFileName As String

Dim strFolder As String

Dim strFullPath As String

' Задание имени папки для поиска

strFolder = InputBox("Определите папку:")

If strFolder = "" Then Exit Sub

' Задание имени файла для поиска

strFileName = Application.InputBox("Введите имя файла:")

If strFileName = "" Then Exit Sub

' При необходимости дополняем имя папки "\"

If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"

' Полный путь файла

strFullPath = strFolder & strFileName

' Вывод окна с отчетом о поиске средствами VBA

MsgBox "Использование команды VBA..." & vbCrLf & vbCrLf & _

dhSearchVBA(strFullPath), vbInformation, strFullPath

' Вывод окна с отчетом о поиске средствами объекта FileSearch

MsgBox "Использование объекта FileSearch..." & vbCrLf & _

vbCrLf & dhSearchFileSearch(strFolder, strFileName), vbInformation, _

strFullPath

' Вывод окна с отчетом о поиске средствами объекта _

FileSystemObject

MsgBox "Использование объекта FileSystemObject..." & vbCrLf & _

vbCrLf & dhSearchFileSystemObject(strFullPath), vbInformation, _

strFullPath

End Sub

Поиск нужного файла_2


Function dhSearchVBA(varFullPath As Variant) As Boolean

' Использование команды VBA

dhSearchVBA = Dir(varFullPath) <> ""

End Function

Поиск нужного файла_3


Function dhSearchFileSearch(varFolder As Variant, varFileName _

As Variant) As Boolean

' Использование объекта FileSearch

With Application.FileSearch

' Создание нового поиска

.NewSearch

' Имя для поиска

.FileName = varFileName

' Папка поиска

.LookIn = varFolder

' Собственно поиск

.Execute

dhSearchFileSearch = .FoundFiles.Count <> 0

End With

End Function

Поиск нужного файла_4


Function dhSearchFileSystemObject(varFullPath As Variant) As Boolean

Dim objFSObject As Object

' Использование объекта FileSystemObject

Set objFSObject = CreateObject("Scripting.FileSystemObject")

dhSearchFileSystemObject = objFSObject.FileExists(varFullPath)

End Function

Автоматизация удаления файлов


Листинг 3.51. Удаление файла

Sub DeleteFile()

Kill "C:\Документы\primer.xls"

End Sub

Листинг 3.52. Удаление группы файлов

Sub DeleteFiles()

' Удаление всех файлов с расширением XLS из заданной папки

Kill "C:\Документы" & "*.xls"

End Sub

Произвольный текст в строке состояния


Sub ChangeStatusBarText()

Application.StatusBar = "Как надоело работать!!!"

End Sub

Восстановление строки состояния


Sub ReturnStatusBarText()

Application.StatusBar = False

End Sub

Бегущая строка в строке состояния


Sub MovingTextInStatusBar()

Dim intSpaces As Integer

' Изменение количества пробелов в начале строки (от 20 до 0) - _

строка бежит (скорее, ползет) влево

For intSpaces = 20 To 0 Step -1

' Запись текста в строку состояния

Application.StatusBar = Space(intSpaces) & "Как надоело работать!!!"

' Выдерживаем паузу

Application.Wait Now + TimeValue("00:00:01")

' Дадим Excel обработать пользовательский ввод

DoEvents

Next

Application.StatusBar = False

End Sub
1   2   3   4   5   6   7   8   9   ...   47


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