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

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

Вывод разрешения монитора

Листинг 3.73. Разрешение монитора

'Объявление API-функции

Declare Function GetSystemMetrics Lib "user32" _

(ByVal nIndex As Long) As Long

' Константы, которые передаются в функцию для определения _

горизонтального и вертикального размеров изображения

Const SM_CXSCREEN = 0

Const SM_CYSCREEN = 1

Sub GetMonitorResolution()

Dim lngHorzRes As Long

Dim lngVertRes As Long

' Получение ширины и высоты изображения на мониторе

lngHorzRes = GetSystemMetrics(SM_CXSCREEN)

lngVertRes = GetSystemMetrics(SM_CYSCREEN)

' Отображение сообщения

MsgBox "Текущее разрешение: " & lngHorzRes & "x" & lngVertRes

End Sub

Получение информации об используемом принтере

Информация о принтере

' Объявление API-функции

Declare Function GetProfileStringA Lib "kernel32" _

(ByVal lpAppName As String, ByVal lpKeyName As String, _

ByVal lpDefault As String, ByVal lpReturnedString As _

String, ByVal nSize As Long) As Long

Sub Принтер()

Dim strFullInfo As String * 255 ' Буфер для API-функции

Dim strInfo As String ' Строка с полной информацией

Dim strPrinter As String ' Название принтера

Dim strDriver As String ' Драйвер принтера

Dim strPort As String ' Порт принтера

Dim strMessage As String

Dim intPrinterEndPos As Integer

Dim intDriverEndPos As Integer

' Заполнение буфера пробелами

strFullInfo = Space(255)

' Получение полной информации о принтере

Call GetProfileStringA("Windows", "Device", "", strFullInfo, 254)

' Удаление лишних символов из конца возвращенной строки

' Строка strInfo имеет формат <имя_принтера>,<драйвер>,<порт>:

strInfo = Trim(strFullInfo)

' Поиск запятых в строке (окончаний названий принтера и драйвера)

intPrinterEndPos = Application.Find(",", strInfo, 1)

intDriverEndPos = Application.Find(",", strInfo, intPrinterEndPos + 1)

' Определение названия принтера

strPrinter = Left(strInfo, intPrinterEndPos - 1)

' Определение драйвера

strDriver = Mid(strInfo, intPrinterEndPos + 1, intDriverEndPos _

- intPrinterEndPos - 1)

' Определение порта (его название заканчивается символом ":")

strPort = Mid(strInfo, intDriverEndPos + 1, InStr(1, strInfo, ":") _

- intDriverEndPos - 1)

' Формирование информационного сообщения

strMessage = "Принтер:" & Chr(9) & strPrinter & Chr(13)

strMessage = strMessage & "Драйвер:" & strDriver & Chr(13)

strMessage = strMessage & "strPort:" & Chr(9) & strPort

' Вывод информационного сообщения

MsgBox strMessage, vbInformation, "Сведения о принтере по умолчанию"

End Sub

Просмотр информации о дисках компьютера

Sub DrivesInfo()

Dim objFileSysObject As Object ' Объект для работы _

с файловой системой

Dim objDrive As Object ' Анализируемый диск

Dim intRow As Integer ' Заполняемая строка листа

' Создание объекта для работы с файловой системой

Set objFileSysObject = CreateObject("Scripting.FileSystemObject")

' Очистка листа

Cells.Clear

' Запись с первой строки

intRow = 1

' Запись на лист информации о дисках компьютера

On Error Resume Next

For Each objDrive In objFileSysObject.Drives

' Буква диска

Cells(intRow, 1) = objDrive.DriveLetter

' Готовность

Cells(intRow, 2) = objDrive.IsReady

' Тип диска

Select Case objDrive.DriveType

Case 0

Cells(intRow, 3) = "Неизвестно"

Case 1

Cells(intRow, 3) = "Съемный"

Case 2

Cells(intRow, 3) = "Жесткий"

Case 3

Cells(intRow, 3) = "Сетевой"

Case 4

Cells(intRow, 3) = "CD-ROM"

Case 5

Cells(intRow, 3) = "RAM"

End Select

' Метка диска

Cells(intRow, 4) = objDrive.VolumeName

' Общий размер

Cells(intRow, 5) = objDrive.TotalSize

' Свободное место

Cells(intRow, 6) = objDrive.AvailableSpace

intRow = intRow + 1

Next

End Sub