Public Type WI
TitleBarText As String
TitleBarLen As Integer
hWnd As Long
End Type
Public Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Public Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Public WinNum As Integer 'holds the number of windows examined
Public CurrentWindows(299) As WI 'holds information about all of the currently open windows
Public Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Dim WinInfo As WI 'holds information about the window currently being examined
Dim retval As Long 'holds the return value
Dim X As Integer
WinInfo.TitleBarLen = GetWindowTextLength(hWnd) + 1 'find the length of the title bar text of the window currently being examined
If WinInfo.TitleBarLen > 0 And Len(hWnd) > 1 Then 'if the title bar text of the window currently being examined is at least one character long AND the window's handle is > 1
WinInfo.TitleBarText = Space(WinInfo.TitleBarLen) 'initialize the variable that will hold the title bar text
retval = GetWindowText(hWnd, WinInfo.TitleBarText, WinInfo.TitleBarLen) 'retreive the title bar text of the window currently being examined
WinInfo.hWnd = hWnd 'holds the value of this window's handle
CurrentWindows(WinNum).hWnd = WinInfo.hWnd 'store this window's handle in the current windows array
CurrentWindows(WinNum).TitleBarText = WinInfo.TitleBarText 'store this window's title bar text in the current windows array
WinNum = WinNum + 1 'increment the window counter
End If
EnumWindowsProc = 1 'continue enumeration of windows
End Function

КОД ФОРМЫ:

Private Sub Command1_Click()
If Command1.Caption = "Отключить мониторинг" Then
Timer1.Enabled = False
Command1.Caption = "Включить мониторинг"
Else
Timer1.Enabled = True
End If
End Sub

Private Sub Form_Load()
Timer1.Interval = 100
Command1.Caption = "Отключить мониторинг"
Dim X As Integer 'loop variable
Label1.Caption = "Initializing..."
Flash = 0
For X = 0 To 49 'reset/initialize the existing IE windows array
ExistingIEWindows(X) = 0
Next
Call GetExistingIEWindows
End Sub

Private Sub GetExistingIEWindows() 'this sub checks to see if any IE windows are currently open, and "remembers" them if so.
Dim retval As Long 'holds the return value
Dim X As Integer, Y As Integer 'loop variables
Label1.Caption = "Examining currently active system windows..."
WinNum = 0 'initialize number of windows to zero
For X = 0 To 199 'reset/initialize the current windows array
CurrentWindows(X).hWnd = 0
CurrentWindows(X).TitleBarLen = 0
CurrentWindows(X).TitleBarText = ""
Next
retval = EnumWindows(AddressOf EnumWindowsProc, 0) 'enumerate all open windows
Y = 0
For X = 0 To WinNum - 1 'for each window that is currently open
If InStr(1, CurrentWindows(X).TitleBarText, "Microsoft Internet Explorer", vbTextCompare) > 0 Then 'if this window is an IE window...
Label1.Caption = "Storing IE window handle..."
ExistingIEWindows(Y) = CurrentWindows(X).hWnd 'add this window to the list of existing IE windows
Y = Y + 1
End If
Next
If Y > 0 Then 'if any of the existing system windows are IE windows
Label1.Caption = "Enabling popup monitoring..."
Timer1.Enabled = True 'enable the timer that checks for any new IE windows
Label1.Caption = "Monitoring for new IE windows..."
Else 'if none of the existing system windows are IE windows
Label1.Caption = "No IE windows found!"
MsgBox "There are currently no IE windows open!" & vbLf & vbLf & "Please start Internet Explorer before running this program.", vbExclamation + vbOKOnly, "Error" 'if no IE windows are found, display an error message
End 'exit this program
End If
End Sub

Private Sub Timer1_Timer()
Dim retval As Long 'holds the return value
Dim X As Integer, Y As Integer 'loop variables
Dim KillCount As Integer 'holds the value that determines if the current window should be killed
WinNum = 0 'initialize number of windows to zero
For X = 0 To 199 'reset/initialize the current windows array
CurrentWindows(X).hWnd = 0
CurrentWindows(X).TitleBarLen = 0
CurrentWindows(X).TitleBarText = ""
Next
retval = EnumWindows(AddressOf EnumWindowsProc, 0) 'enumerate all open windows
For X = 0 To WinNum - 1 'for each window that is currently open
If InStr(1, CurrentWindows(X).TitleBarText, "Microsoft Internet Explorer", vbTextCompare) > 0 Then 'if this window is an IE window...
KillCount = 0
For Y = 0 To 49
If ExistingIEWindows(Y) <> 0 Then 'if array value holds a valid handle
If ExistingIEWindows(Y) = CurrentWindows(X).hWnd Then 'if the window currently being examined matches any of the existing IE windows
KillCount = KillCount + 1 'increment
End If
End If
Next
If KillCount = 0 Then 'if an IE window that did not previously exist was found
retval = PostMessage(CurrentWindows(X).hWnd, WM_CLOSE, ByVal CLng(0), ByVal CLng(0)) 'post the window close message to the newly created IE window's message queue
End If
End If
Next
Flash = Flash + 1 'increment the flash value
If Flash = 5 Then 'make the status label flash every 0.5 seconds
Flash = 0
If Label1.Visible = True Then
Label1.Visible = False
Else
Label1.Visible = True
End If
End If
End Sub