Типы Public Type RECT Left
|
Option Explicit 'Константы Public Const SW_HIDE = 0 Public Const SW_SHOWNORMAL = 1 Public Const SW_SHOWMINIMIZED = 2 Public Const SW_SHOWMAXIMIZED = 3 ' Типы Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type 'Функции Public Declare Function GetActiveWindow Lib "user32" () As Long Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _ lpRect As RECT) As Long Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _ (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _ ByVal nCmdShow As Long) As Long Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" _ (ByVal hwnd As Long, ByVal lpString As String) As Long |
| Пример 6.1. |
| Закрыть окно |
|
Public Sub WorkWithWindows() Dim Res As Long ' Результат выполнения функции Dim HandleAW As Long 'Описатель активного окна Dim RectAW As RECT 'Структура, задающая прямоугольник окна Dim TextAW As String 'Заголовок активного окна Dim LenTextAW As Long 'Длина строки Dim HandleW As Long 'Описатель окна Dim TextW As String 'Заголовок окна 'Получить описатель активного окна HandleAW = GetActiveWindow Debug.Print HandleAW 'Получить прямоугольник, задающий положение активного окна Res = GetWindowRect(HandleAW, RectAW) Debug.Print Res If Res > 0 Then 'OK Debug.Print "Размеры окна: Left = ", RectAW.Left, " Top = ", _ RectAW.Top, " Right = ", RectAW.Right, " Bottom = ", RectAW.Bottom Else: MsgBox ("Не удалось получить размеры активного окна") End If 'Получить заголовок окна 'Предварительная набивка результирующей строки нулевыми символами TextAW = VBA.String$(255, vbNullChar) LenTextAW = VBA.Len(TextAW) Res = GetWindowText(HandleAW, TextAW, LenTextAW) Debug.Print Res If Res > 0 Then 'OK TextAW = VBA.Left(TextAW, VBA.InStr(1, TextAW, vbNullChar) - 1) Debug.Print TextAW Else: MsgBox ("Не удалось получить заголовок активного окна") End If 'Поиск окна документа по его заголовку 'Возвращается описатель окна TextW = "DocOne6 - Microsoft Word" HandleW = FindWindow(vbNullString, TextW) If HandleW > 0 Then 'OK Debug.Print HandleW Else: MsgBox ("Не удалось найти окно с указанным заголовком" _ & vbCrLf & TextW) End If 'Минимизация и нормализация окна документа Res = ShowWindow(HandleW, SW_SHOWMINIMIZED) If Res > 0 Then Debug.Print "Окно минимизировано" Res = ShowWindow(HandleW, SW_SHOWNORMAL) If Res > 0 Then Debug.Print "Окно в нормальном состоянии" 'Изменение заголовка окна TextW = "Document1 - Microsoft Word" HandleW = FindWindow(vbNullString, TextW) If HandleW > 0 Then 'OK Debug.Print HandleW Else: MsgBox ("Не удалось найти окно с указанным заголовком" _ & vbCrLf & TextW) End If Res = SetWindowText(HandleW, "DocTwo6 - Microsoft Word") End Sub |
| Пример 6.2. |
| Закрыть окно |
| Option Explicit 'Константы Public Const PROCESSOR_INTEL_386 = 386 Public Const PROCESSOR_INTEL_486 = 486 Public Const PROCESSOR_INTEL_PENTIUM = 586 Public Const PROCESSOR_MIPS_R4000 = 4000 Public Const PROCESSOR_ALPHA_21064 = 21064 ' Типы Type SYSTEM_INFO dwOemID As Long dwPageSize As Long lpMinimumApplicationAddress As Long lpMaximumApplicationAddress As Long dwActiveProcessorMask As Long dwNumberOrfProcessors As Long dwProcessorType As Long dwAllocationGranularity As Long dwReserved As Long End Type Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 End Type Type MEMORYSTATUS dwLength As Long dwMemoryLoad As Long dwTotalPhys As Long dwAvailPhys As Long dwTotalPageFile As Long dwAvailPageFile As Long dwTotalVirtual As Long dwAvailVirtual As Long End Type 'Операторы Declare Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _ (LpVersionInformation As OSVERSIONINFO) As Long Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As _ MEMORYSTATUS) Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As _ SYSTEM_INFO) |
| Пример 6.3. |
| Закрыть окно |
|
Public Sub WorkWithStatus() Dim res As Long ' Результат выполнения функции Dim msg As String ' Формируемое сообщение Dim verinfo As OSVERSIONINFO 'Информация об ОС и ее версиях Dim sysinfo As SYSTEM_INFO 'Системная информация Dim memstatus As MEMORYSTATUS 'Информация о статусе памяти verinfo.dwOSVersionInfoSize = Len(verinfo) res = GetVersionEx(verinfo) If res > 0 Then Select Case verinfo.dwPlatformId Case 0 msg = "Windows 32s " Case 1 msg = "Windows 95/98 " Case 2 msg = "Windows NT " End Select msg = msg & verinfo.dwMajorVersion & "." & verinfo.dwMinorVersion msg = msg & " (Build " & verinfo.dwBuildNumber & ")" & vbCrLf Debug.Print msg Else MsgBox ("Не могу получить версию операционной системы") End If ' определение типа процессора GetSystemInfo sysinfo msg = "Процессор: " Select Case sysinfo.dwProcessorType Case PROCESSOR_INTEL_386 msg = msg & "Intel 386" & vbCrLf Case PROCESSOR_INTEL_486 msg = msg & "Intel 486" & vbCrLf Case PROCESSOR_INTEL_PENTIUM msg = msg & "Intel Pentium" & vbCrLf Case PROCESSOR_MIPS_R4000 msg = msg & "MIPS R4000" & vbCrLf Case PROCESSOR_ALPHA_21064 msg = msg & "DEC Alpha 21064" & vbCrLf Case Else msg = msg & "(unknown)" & vbCrLf End Select Debug.Print msg msg = "Число процессоров: " & sysinfo.dwNumberOrfProcessors & vbCrLf Debug.Print msg msg = "Размер страницы: " & sysinfo.dwPageSize & vbCrLf Debug.Print msg msg = "Минимальный адрес приложения: " & sysinfo.lpMinimumApplicationAddress & vbCrLf Debug.Print msg msg = "Максимальный адрес приложения: " & sysinfo.lpMaximumApplicationAddress & vbCrLf Debug.Print msg ' Получение характеристик памяти GlobalMemoryStatus memstatus msg = "Физическая память. Всего: " & _ VBA.Format$(memstatus.dwTotalPhys \ 1024, "###,###,###") & "K" & vbCrLf Debug.Print msg msg = "Физическая память. Доступно: " & _ VBA.Format$(memstatus.dwAvailPhys \ 1024, "###,###,###") & "K" & vbCrLf Debug.Print msg msg = "Виртуальная память. Всего: " & _ VBA.Format$(memstatus.dwTotalVirtual \ 1024, "###,###,###") & "K" & vbCrLf Debug.Print msg msg = "Виртуальная память. Доступно: " & _ VBA.Format$(memstatus.dwAvailVirtual \ 1024, "###,###,###") & "K" & vbCrLf Debug.Print msg msg = "Длина слова: " & memstatus.dwLength & vbCrLf Debug.Print msg msg = "Загрузка памяти: " & memstatus.dwMemoryLoad & vbCrLf Debug.Print msg End Sub |
| Пример 6.4. |
| Закрыть окно |
|
Public Sub WorkWithUniFunc() Dim res As Long Dim Capt As String 'Заголовок 'Динамический массив байтов для передачи строки заголовка Dim HandleW As Long 'Описатель окна 'Поиск окна по заголовку Capt = "Document1 - Microsoft Word" HandleW = FindWindowA(vbNullString, Capt) If HandleW > 0 Then 'OK Debug.Print HandleW Else: MsgBox ("FindWindowA не может найти окно с заголовком" & vbCrLf & Capt) End If 'Попытки использовать для поиска Unicode функцию 'FindWindowW не увенчались успехом ' ReDim ArCapt(0 To 2 * VBA.Len(Capt)) As Byte ' ArCapt = Capt & vbNullChar ' Debug.Print ArCapt ' HandleW = FindWindowW(0&, ArCapt(0)) ' If HandleW > 0 Then 'OK ' Debug.Print HandleW ' Else: MsgBox ("Не могу вызвать UniCode FindWindowW") ' End If 'Получить заголовок окна ArCapt = VBA.String$(128, vbNullChar) res = GetWindowText(HandleW, ArCapt(0), 128) If res > 0 Then 'OK Debug.Print ArCapt Else: MsgBox ("не получен заголовок окна") End If 'Изменить заголовок окна Capt = "NewDoc" ArCapt = Capt & vbNullChar res = SetWindowText(HandleW, ArCapt(0)) 'Повторно получить заголовок окна ArCapt = VBA.String$(128, vbNullChar) res = GetWindowText(HandleW, ArCapt(0), 128) If res > 0 Then 'OK Debug.Print ArCapt Else: MsgBox ("не получен заголовок окна") End If End Sub |
| Пример 6.5. |
| Закрыть окно |
|
Public Sub WorkWithApiErr() Dim Res As Long Dim capt As String 'Заголовок Dim HandleW As Long 'Описатель окна 'Поиск окна по заголовку capt = "DocOne6 - Microsoft Word" ArCapt = capt & vbNullChar Debug.Print ArCapt HandleW = FindWindowW(0&, ArCapt(0)) If HandleW > 0 Then 'OK Debug.Print HandleW Else: MsgBox ("Не могу корректно вызвать UniCode FindWindowW") If Err.LastDllError = ERROR_INVALID_NAME Then Debug.Print "Не корректно задано имя при вызове Unicode FindWindowW функции!" End If End If 'Еще один эксперимент: вначале получим заголовок активного окна, 'затем найдем окно по заголовку, работая в Unicode кодировке. HandleW = GetActiveWindow() 'Получить заголовок окна ArCapt = VBA.String$(128, vbNullChar) Res = GetWindowText(HandleW, ArCapt(0), 128) If Res > 0 Then 'OK Debug.Print ArCapt Else: MsgBox ("не получен заголовок окна") End If ArCapt = VBA.Left(ArCapt, Res) HandleW = FindWindowW(0&, ArCapt(0)) If HandleW > 0 Then 'OK Debug.Print HandleW Else: MsgBox ("Не могу корректно вызвать UniCode FindWindowW") If Err.LastDllError = ERROR_INVALID_NAME Then Debug.Print "Не корректно задано имя при вызове Unicode FindWindowW функции!" End If End If End Sub |
| Пример 6.6. |
| Закрыть окно |
|
Public Function EnumWindowsProc(ByVal HandleW As Long, _ ByVal lParam As Long) As Long Dim TextW As String Dim LenTextW As Long Dim Res As Long 'Добавить описатель в коллекцию HandleCol.Add HandleW 'Получить заголовок окна. TextW = VBA.String$(255, vbNullChar) LenTextW = VBA.Len(TextW) Res = GetWindowText(HandleW, TextW, LenTextW) If Res > 0 Then 'Добавить заголовок в коллекцию TextW = VBA.Left(TextW, Res) CaptCol.Add TextW End If 'Получить класс окна. TextW = VBA.String$(255, vbNullChar) LenTextW = VBA.Len(TextW) Res = GetClassName(HandleW, TextW, LenTextW) If Res > 0 Then 'Добавить имя класса в коллекцию TextW = VBA.Left(TextW, Res) ClassNameCol.Add TextW End If EnumWindowsProc = 1 End Function |
| Пример 6.7. |
| Закрыть окно |
|
Public Sub GetCaptions() ' Вызов Win32 API функции EnumWindows, 'вызывающей в свою очередь Callback функцию EnumWindowsProc Dim item As Variant Dim Res As Long Res = EnumWindows(AddressOf EnumWindowsProc, 0&) 'Обработка глобальных переменных, определенных в 'результате совместной работы EnumWindows и EnumWindowsProc Debug.Print "Число окон = ", HandleCol.Count Debug.Print "Описатели окон" Res = 0 For Each item In HandleCol Debug.Print item Res = Res + 1 If Res > 10 Then Exit For Next item Debug.Print "Число окон с заголовками= ", CaptCol.Count Debug.Print "Заголовки окон" Res = 0 For Each item In CaptCol Debug.Print item Res = Res + 1 If Res > 10 Then Exit For Next item Debug.Print "Число окон, возвращающих класс = ", ClassNameCol.Count Debug.Print "Имена классов окон" Res = 0 For Each item In ClassNameCol Debug.Print item Res = Res + 1 If Res > 10 Then Exit For Next item End Sub |
| Пример 6.8. |
| Закрыть окно |
| Число окон = 254 Описатели окон 3735790 131912 131888 131916 65684 40370412 917748 262866 852650 852668 131844 Число окон с заголовками =76 Заголовки окон Continue Microsoft Agent Microsoft Office Shortcut Bar Menu Parent Window NetDDE Agent Edit Microsoft Visual Basic - DocOne6 [running] - [ОбратныйВызов (Code)] Ch6 - Microsoft Word Edit Properties Microsoft Office Shortcut Bar Число окон, возвращающих класс =254 Имена классов окон OfficeTooltip tooltips_class32 ComboLBox tooltips_class32 tooltips_class32 AgentAnimBalloon AgentAnim tooltips_class32 tooltips_class32 tooltips_class32 tooltips_class32 |
| Пример 6.9. |
| Закрыть окно |
|
Option Explicit Public Declare Function EnumWindows Lib "user32" _ (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long Public Declare Function EnumWindows1 Lib "user32" Alias "EnumWindows" _ (ByVal lpEnumFunc As Long, lParam As Any) As Long Public HandleCol As New Collection Public HandleCol1 As New Collection Public Function EnumWindowsProc(ByVal HandleW As Long, _ ByVal lParam As Long) As Long HandleCol.Add HandleW EnumWindowsProc = 1 End Function Public Function EnumWindowsProc1(ByVal HandleW As Long, _ lParam As Collection) As Long lParam.Add HandleW EnumWindowsProc1 = 1 End Function Public Sub GetHandles() Dim item As Variant Dim Res As Long Res = EnumWindows(AddressOf EnumWindowsProc, 0&) Debug.Print "Number of windows - ", HandleCol.Count Debug.Print "Their handles: " Res = 0 For Each item In HandleCol Debug.Print item Res = Res + 1 If Res > 10 Then Exit For Next item End Sub Public Sub GetHandles1() Dim item As Variant Dim Res As Long Res = EnumWindows1(AddressOf EnumWindowsProc1, HandleCol1) Debug.Print "Number of windows - ", HandleCol1.Count Debug.Print "Their handles: " Res = 0 For Each item In HandleCol1 Debug.Print item Res = Res + 1 If Res > 10 Then Exit For Next item End Sub |
| Пример 6.10. |
| Закрыть окно |
|
'Функции работы с таймером Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, _ ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long 'Глобальная информация Public Counter As Long 'Счетчик числа вызовов Callback функции Public IdEv As Long Public Sub HowManyProc(ByVal HandleW As Long, ByVal msg As Long, _ ByVal idEvent As Long, ByVal TimeSys As Long) 'Функция обратного вызова. Вызывается при обработке сообщения WM_Timer, 'посылаемого таймером, созданным процедурой SetTimer Counter = Counter + 1 Debug.Print "Hi", Counter End Sub Public Sub Start() 'Создает таймер, вызывая Win32 Api функцию SetTimer Counter = 0 IdEv = SetTimer(0&, 0&, 10000, AddressOf HowManyProc) If IdEv = 0 Then MsgBox ("Не удалось создать таймер!") Else Debug.Print "Создан Таймер: Идентификатор = ", IdEv End If End Sub Public Sub Finish() 'Удаляет таймер If IdEv > 0 Then Call KillTimer(0&, IdEv) Debug.Print "Удален Таймер: Идентификатор = ", IdEv IdEv = 0 End If End Sub |
| Пример 6.11. |
| Закрыть окно |
|
Option Explicit ' Класс ВашТаймер служит упаковкой функций WIN32 API работы с таймером 'Интерфейс класса будут составлять две функции: 'СоздатьТаймер, УдалитьТаймер и свойство ИнтервалТаймера 'При работе с классом необходимо описать Callback функцию по следующему образцу: 'Public Sub TimerProc(ByVal HandleW As Long, ByVal msg As Long, _ ' ByVal idEvent As Long, ByVal TimeSys As Long) ' 'Функция обратного вызова. Вызывается при обработке сообщения WM_Timer, ' 'посылаемого таймером, созданным процедурой SetTimer ' ' 'Поместите здесь свой код! ' 'End Sub 'Функции Win32 API для работы с таймером Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, _ ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long 'Свойства: Интервал - хранит значение интервала посылки сообщений Private Интервал As Long 'Идентификатор таймера Private IdEv As Long Public Sub СоздатьТаймер() 'Создает таймер, вызывая Win32 Api функцию SetTimer IdEv = SetTimer(0&, 0&, Интервал, AddressOf TimerProc) If IdEv = 0 Then MsgBox ("Не удалось создать таймер!") Else Debug.Print "Создан Таймер: Идентификатор = ", IdEv End If End Sub Public Sub УдалитьТаймер() 'Удаляет таймер If IdEv > 0 Then Call KillTimer(0&, IdEv) Debug.Print "Удален Таймер: Идентификатор = ", IdEv IdEv = 0 End If End Sub Public Property Get ИнтервалТаймера() As Long ИнтервалТаймера = Интервал End Property Public Property Let ИнтервалТаймера(ByVal NewValue As Long) Интервал = NewValue End Property Private Sub Class_Initialize() Интервал = 1000 End Sub Private Sub Class_Terminate() УдалитьТаймер End Sub |
| Пример 6.12. |
| Закрыть окно |
|
Option Explicit 'Модуль Таймер1 ' Глобальная информация Public Counter As Long 'Счетчик числа вызовов Callback функции Public MyTimer As New ВашТаймер Public Sub Start1() MyTimer.ИнтервалТаймера = 5000 MyTimer.СоздатьТаймер End Sub Public Sub Finish1() MyTimer.УдалитьТаймер End Sub Public Sub TimerProc(ByVal HandleW As Long, ByVal msg As Long, _ ByVal idEvent As Long, ByVal TimeSys As Long) 'Функция обратного вызова. Вызывается при обработке сообщения WM_Timer, 'посылаемого таймером, созданным процедурой SetTimer Counter = Counter + 1 Debug.Print "Hi", Counter End Sub |
| Пример 6.13. |
| Закрыть окно |
