Visual Basic Kod Bankası - Windows' ta Alt+Tab Uygulaması.

Windows' ta Alt+Tab Uygulaması.

Formunuza bir tane Picturebox yerleştirin ismini Picture1(0) olarak değiştirin. Bir tanede Timer1 ekleyin,Bir adet de Command1 ekleyip Aşagıdaki işlemleri takip ediniz.

'ClassModule eklenecek Kod
Option Explicit
Private Declare Function GetTopWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As Long, ByVal wFlag As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetClassname Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, lParam As Any, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function LoadIcon Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, lpIconName As Any) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2
Private Const ICON_SMALL = 0
Private Const ICON_BIG = 1
Private Const GCL_HICON = (-14)
Private Const GCL_HICONSM = (-34)
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_HWNDPARENT = (-8)
Private Const WS_EX_TOOLWINDOW = &H80
Private Const WM_NULL = &H0
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_GETICON = &H7F
Private Const WM_SETICON = &H80
Private Const SMTO_NORMAL = &H0
Private Const SMTO_BLOCK = &H1
Private Const SMTO_ABORTIFHUNG = &H2
Private Const SW_RESTORE = 9
Private Const IDI_WINLOGO = 32517&
Private Const IDI_APPLICATION = 32512&
Private Const ERROR_TIMEOUT = 1460
Private Type TaskListItems
hWnd As Long
hIcon As Long
hIconSm As Long
Caption As String
End Type
Private m_Count As Long
Private m_tasks() As TaskListItems
Private m_hFlagIcon As Long
Private m_hAppIcon As Long
Private m_Mode As TaskListModes
Private m_HungTimeout As Long
Private Const defHungTimeout = 500
Private Const ArrayBump = 20
Public Enum TaskListModes
tlAltTab = 0
tlTaskMgr = 1
End Enum
Public Enum TaskStatus
tlStatusOK = 0
tlStatusHung = 1
End Enum
Private Sub Class_Initialize()
m_hFlagIcon = LoadIcon(0, ByVal IDI_WINLOGO)
m_hAppIcon = LoadIcon(0, ByVal IDI_APPLICATION)
m_Mode = tlAltTab
m_HungTimeout = defHungTimeout
ReDim m_tasks(0 To ArrayBump - 1) As TaskListItems
End Sub

Private Sub Class_Terminate()
'
End Sub
Public Property Let HungTimeout(ByVal NewVal As Long)
If NewVal > 0 Then
m_HungTimeout = NewVal
End If
End Property

Public Property Get HungTimeout() As Long
HungTimeout = m_HungTimeout
End Property

Public Property Let Mode(ByVal NewVal As TaskListModes)
Select Case NewVal
Case tlAltTab, tlTaskMgr
m_Mode = NewVal
Case Else
End Select
End Property

Public Property Get Mode() As TaskListModes
Mode = m_Mode
End Property
Public Property Get Caption(ByVal Index As Long) As String
If Index > 0 And Index <= m_Count Then
Caption = m_tasks(Index - 1).Caption
End If
End Property

Public Property Get Count() As Long
Count = m_Count
End Property

Public Property Get hWnd(ByVal Index As Long) As Long
If Index > 0 And Index <= m_Count Then
hWnd = m_tasks(Index - 1).hWnd
End If
End Property

Public Property Get hIcon(ByVal Index As Long) As Long
If Index > 0 And Index <= m_Count Then
If m_tasks(Index - 1).hIcon <> 0 Then
hIcon = m_tasks(Index - 1).hIcon
Else
Select Case m_Mode
Case tlAltTab
hIcon = m_hFlagIcon
Case tlTaskMgr
hIcon = m_hAppIcon
End Select
End If
End If
End Property

Public Property Get hIconSm(ByVal Index As Long) As Long
If Index > 0 And Index <= m_Count Then
If m_tasks(Index - 1).hIconSm <> 0 Then
hIconSm = m_tasks(Index - 1).hIconSm
Else
hIconSm = Me.hIcon(Index)
End If
End If
End Property

Public Property Get Status(ByVal Index As Long) As TaskStatus
Static nRet As Long
Static lpdwResult As Long
Const flags As Long = SMTO_ABORTIFHUNG 'Or SMTO_BLOCK
If Index > 0 And Index <= m_Count Then
Status = tlStatusOK
nRet = SendMessageTimeout(m_tasks(Index - 1).hWnd, WM_NULL, 0&, 0&, flags, m_HungTimeout, lpdwResult)
If nRet = 0 Then
Status = tlStatusHung
End If
End If
End Property

Public Property Get Valid(Optional ByVal Index As Long, Optional ByVal hWnd As Long) As Boolean
Dim i As Long
If hWnd <> 0 Then
For i = 0 To m_Count - 1
If m_tasks(i).hWnd = hWnd Then
Index = i + 1
Exit For
End If
Next i
End If

If Index > 0 And Index <= m_Count Then
If IsTask(m_tasks(Index - 1).hWnd) Then
Valid = True
Else
m_tasks(Index - 1).hWnd = 0
m_Count = CompactCache()
Valid = False
End If
End If
End Property
Public Function Activate(Optional ByVal Index As Long, Optional ByVal hWnd As Long) As Boolean
Dim i As Long
If hWnd <> 0 Then
For i = 0 To m_Count - 1
If m_tasks(i).hWnd = hWnd Then
Index = i + 1
Exit For
End If
Next i
End If
If Index > 0 And Index <= m_Count Then
With m_tasks(Index - 1)
If Len(.Caption) Then
If IsIconic(.hWnd) Then
Call ShowWindow(.hWnd, SW_RESTORE)
End If
Call SetForegroundWindow(.hWnd)
Activate = (GetForegroundWindow = .hWnd)
End If
End With
End If
End Function

Public Sub Refresh()
Dim i As Long
Dim hWnd As Long

For i = 0 To m_Count - 1
If IsWindow(m_tasks(i).hWnd) = 0 Then
m_tasks(i).hWnd = 0
End If
Next i
m_Count = CompactCache()
hWnd = GetTopWindow(0)
Do While hWnd
If IsTask(hWnd) Then Call AddTask(hWnd)
hWnd = GetNextWindow(hWnd, GW_HWNDNEXT)
Loop
End Sub
Private Sub AddTask(ByVal hWnd As Long)
Dim nIndex As Long
Dim hWndIcon As Long
Dim hIcon As Long
Dim hIconSm As Long
Dim Caption As String
Dim lpdwResult As Long
Dim nLen As Long
Dim nRet As Long
Dim i As Long
Const flags As Long = SMTO_ABORTIFHUNG ' Or SMTO_BLOCK
For i = 0 To m_Count - 1
If hWnd = m_tasks(i).hWnd Then
nIndex = i + 1
Exit For
End If
Next i
nRet = SendMessageTimeout(hWnd, WM_GETTEXTLENGTH, 0&, ByVal 0&, flags, m_HungTimeout, lpdwResult)
If nRet = 0 Then
Debug.Print "Timeout on &h" & Hex(hWnd)
If nIndex Then Exit Sub
Else
nLen = lpdwResult + 1
End If
If nLen > 1 Then
Caption = String$(nLen, 0)
nRet = SendMessageTimeout(hWnd, WM_GETTEXT, nLen, ByVal Caption, flags, m_HungTimeout, lpdwResult)
If nRet Then
nLen = lpdwResult
hWndIcon = GetWindowLong(hWnd, GWL_HWNDPARENT)
If hWndIcon = 0 Then hWndIcon = hWnd
If SendMessageTimeout(hWndIcon, WM_GETICON, ICON_BIG, ByVal 0&, flags, m_HungTimeout, lpdwResult) Then
If lpdwResult Then
hIcon = lpdwResult
Else
hIcon = GetClassLong(hWndIcon, GCL_HICON)
End If
End If
If SendMessageTimeout(hWndIcon, WM_GETICON, ICON_SMALL, ByVal 0&, flags, m_HungTimeout, lpdwResult) Then
If lpdwResult Then
hIconSm = lpdwResult
Else
hIconSm = GetClassLong(hWndIcon, GCL_HICONSM)
End If
End If
If m_Count > UBound(m_tasks) Then
ReDim Preserve m_tasks(0 To UBound(m_tasks) + ArrayBump) As TaskListItems
End If
If nIndex Then
nIndex = nIndex - 1
Else
nIndex = m_Count
m_Count = m_Count + 1
End If
m_tasks(nIndex).hWnd = hWnd
m_tasks(nIndex).hIcon = hIcon
m_tasks(nIndex).hIconSm = hIconSm
m_tasks(nIndex).Caption = Left$(Caption, nLen)
End If
End If
End Sub

Private Function Classname(ByVal hWnd As Long) As String
Dim nRet As Long
Dim Class As String
Const MaxLen As Long = 256
Class = String$(MaxLen, 0)
nRet = GetClassname(hWnd, Class, MaxLen)
If nRet Then Classname = Left$(Class, nRet)
End Function

Private Function CompactCache() As Long
Dim i As Long, j As Long
If m_Count Then
For i = 0 To UBound(m_tasks) - 1
If m_tasks(i).hWnd = 0 Then
For j = i To UBound(m_tasks) - 1
m_tasks(j).hWnd = m_tasks(j + 1).hWnd
m_tasks(j).hIcon = m_tasks(j + 1).hIcon
m_tasks(j).hIconSm = m_tasks(j + 1).hIconSm
m_tasks(j).Caption = m_tasks(j + 1).Caption
Next j
End If
Next i
End If
For i = 0 To UBound(m_tasks)
If m_tasks(i).hWnd = 0 Then
CompactCache = i
Exit For
End If
Next i
End Function

Private Function IsTask(ByVal hWnd As Long) As Boolean
Dim hWndOwner As Long
Select Case m_Mode
Case tlAltTab
If IsWindowVisible(hWnd) Then
If GetParent(hWnd) = 0 Then
hWndOwner = GetWindowLong(hWnd, GWL_HWNDPARENT)
If (hWndOwner = 0) Or IsToolWindow(hWndOwner) Then
If Not IsToolWindow(hWnd) Then
IsTask = True
End If
End If
End If
End If
Case tlTaskMgr
If IsWindowVisible(hWnd) Then
If GetParent(hWnd) = 0 Then
If GetWindowLong(hWnd, GWL_HWNDPARENT) = 0 Then
If IsToolWindow(hWnd) Then
If Classname(hWnd) <> "Progman" Then
IsTask = True
End If
Else
IsTask = True
End If
End If
End If
End If
End Select
End Function

Private Function IsToolWindow(ByVal hWnd As Long) As Boolean
IsToolWindow = ((GetWindowLong(hWnd, GWL_EXSTYLE) And WS_EX_TOOLWINDOW) = WS_EX_TOOLWINDOW)
End Function

' forma Eklenecek Kısım

Option Explicit
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Const SM_CXICON = 11
Private Const SM_CYICON = 12
Private Const VK_LBUTTON = &H1
Private Const m_Margin = 10
Private m_tasks As Class1
Private m_MouseDown As Boolean
Private Sub Command1_Click()
Call RefreshTaskList(True)
End Sub
Private Sub Form_Load()
Command1.Caption = "Tabı Yenile"
Timer1.Interval = 1000
With Picture1(0)
.Width = GetSystemMetrics(SM_CXICON) * Screen.TwipsPerPixelX
.Height = GetSystemMetrics(SM_CYICON) * Screen.TwipsPerPixelY
End With
End Sub
Private Sub Form_Paint()
If GetKeyState(VK_LBUTTON) >= 0 Then
On Error Resume Next
Call RefreshTaskList
On Error GoTo 0
End If
End Sub
Private Sub Form_Resize()
Dim margin As Long
On Error Resume Next
margin = m_Margin * Screen.TwipsPerPixelX
Command1.Move Me.ScaleWidth - Command1.Width - margin
Call ArrangePictureBoxes
End Sub

Private Sub Picture1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Static LastIndex As Integer
Dim Caption As String
If Index <> LastIndex Then
Caption = m_tasks.Caption(Index)

End If
End Sub

Private Sub Picture1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
m_tasks.Activate Index
Call RefreshTaskList
End Sub
Private Sub Timer1_Timer()
Call RefreshTaskList
End Sub
Private Sub RefreshTaskList(Optional DebugDump As Boolean = False)
Dim i As Long
Set m_tasks = New Class1
With m_tasks
.Mode = tlAltTab
.Refresh
LoadPictureBoxes (.Count)
For i = 1 To .Count
Picture1(i).Cls
Call DrawIcon(Picture1(i).hDC, 0, 0, .hIcon(i))
Picture1(i).ToolTipText = "hWnd: &h" & Hex(.hWnd(i))

If DebugDump Then
Debug.Print "hWnd: &h"; Hex(.hWnd(i)); " -- "; .Caption(i)
End If
Next i
End With
End Sub

Private Sub LoadPictureBoxes(ByVal Num As Long)
Dim i As Long

If Num > Picture1.UBound Then
For i = Picture1.UBound + 1 To Num
Load Picture1(i)
With Picture1(i)
.AutoRedraw = True
.BorderStyle = 0
.Left = -(.Width * 2)
.Visible = True
End With
Next i

ElseIf Num < Picture1.UBound Then
For i = Picture1.UBound To (Num + 1) Step -1
Unload Picture1(i)
Next i
End If
Call ArrangePictureBoxes
End Sub

Private Sub ArrangePictureBoxes()
Dim i As Long
Dim X As Long, Y As Long
Dim margin As Long
Dim maxwidth As Long
margin = m_Margin * Screen.TwipsPerPixelX
maxwidth = Me.ScaleWidth - Command1.Width - (margin * 2)
X = margin
Y = margin
For i = 1 To Picture1.UBound
With Picture1(i)
.Move X, Y
X = X + .Width + margin
If (X + .Width) > maxwidth Then
X = margin
Y = Y + .Height + margin
End If
End With
Next i
End Sub