一键关闭QQ

一键关闭QQ(只适用我QQ2008版)

Form代码：

Private Sub Command1_Click()
    Call QQ_Ext(0)

End Sub

Sub ListAdd()
    List1.Clear
    List1.AddItem "QQ号码" & Space(15 - 6) & "PID"
    List1.AddItem "---------------------------"
    EnumWindows AddressOf EnumWindowsProc, ByVal 0&     '查找已经在线的QQ列表
End Sub

Private Sub Label2_Click()
    Label2.Caption = IIf(Label2.Caption = ">>>", "<<<", ">>>")
    Me.Width = IIf(Label2.Caption = ">>>", 3780, 6240)
    If Label2.Caption = "<<<" Then Call ListAdd
End Sub

Private Sub List1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    '如果单击鼠标右键弹出菜单
    If Button = vbRightButton Then
        If List1.ListCount < 2 Then Exit Sub
        If Val(List1.List(List1.ListIndex)) = 0 Then Exit Sub
        Me.PopupMenu mnuMen
    End If
End Sub

Private Sub mnu_CLOSE_Click()
    Dim tmpQQ As String
    tmpQQ = List1.List(List1.ListIndex)
    tmpQQ = Mid(tmpQQ, 15)
    Call QQ_Ext(Val(tmpQQ))
    List1.RemoveItem (List1.ListIndex)
End Sub

模块代码：

 

Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthW" (ByVal HWnd 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

Public Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Boolean
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal HWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal HWnd As Long, ByVal nIndex As Long) As Long

Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_ID = (-12)

Private Const WM_COMMAND = &H111
Private Const WM_QUIT = &H12

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal HWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function EnumProcessModules Lib "psapi.dll" ( _
    ByVal hProcess As Long, _
    ByRef lphModule As Long, _
    ByVal cb As Long, _
    ByRef lpcbNeeded As Long) As Long
Private Declare Function GetModuleFileNameEx Lib "psapi.dll" _
    Alias "GetModuleFileNameExA" ( _
    ByVal hProcess As Long, _
    ByVal hModule As Long, _
    ByVal lpFilename As String, _
    ByVal nSize As Long) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)
   
Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_READ = 16

Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long

'对应程序路径
Public Function GetEXEFromHandle(Optional ByVal nHWnd As Long = 0) As String
    Dim nProcID As Long
    Dim nResult As Long
    Dim nTemp As Long
    Dim lModules(1 To 200) As Long
    Dim sFile As String
    Dim hProcess As Long '
    If nHWnd = 0 Then Exit Function
    If GetWindowThreadProcessId(nHWnd, nProcID) <> 0 Then
        hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or _
        PROCESS_VM_READ, 0, nProcID)
        If hProcess <> 0 Then
            nResult = EnumProcessModules(hProcess, lModules(1), _
              200, nTemp)
            If nResult <> 0 Then
                sFile = Space$(260)
                nResult = GetModuleFileNameEx(hProcess, 0, sFile, Len(sFile))
                sFile = LCase$(Left$(sFile, nResult))
                GetEXEFromHandle = sFile
            End If
            CloseHandle hProcess
        End If
    End If
End Function

Sub Main()
    If App.PrevInstance Then End '只允许
    Frm1.Show
End Sub

'回调
Public Function EnumWindowsProc(ByVal HWnd As Long, ByVal lParam As Long) As Boolean
    Dim lTilet$, rtn&
    Dim I&, QQCount&
    Dim pid As Long     ' 储存进程标识符( Process Id )
    Dim QQCode As Long
   
    rtn = GetWindowTextLength(HWnd)
    lTilet = Space(rtn)
    GetWindowText HWnd, lTilet, rtn + 1
    If InStr(LCase(lTilet), "_qqmusic_smallclient") > 0 Then
        QQCode = Val(Replace(LCase(lTilet), "_qqmusic_smallclient", Empty)) '分离出QQ号码
        GetWindowThreadProcessId HWnd, pid                                  ' 取得进程标识符
        Frm1.List1.AddItem QQCode & Space(15 - lstrlen(QQCode)) & pid
   
    End If
    EnumWindowsProc = True
End Function

'退出QQ
Function QQ_Ext(Optional proid As Long) As Boolean
    Dim HWnd As Long
    Dim g_hWnd As Long
    Dim nProcID As Long
    Const context = "Tencent_QQBar"

    HWnd = FindWindowEx(0, 0, "#32770", vbNullString)
    Do While HWnd <> 0
        g_hWnd = FindWindowEx(HWnd, 0, context, vbNullString)
        If g_hWnd Then
            If proid = Empty Then
                PostMessage HWnd, WM_COMMAND, 40105, 0          '全部QQ退出
            Else
                '按Q号退出
                If GetWindowThreadProcessId(HWnd, nProcID) <> 0 Then
                    If nProcID = proid Then
                        PostMessage HWnd, WM_COMMAND, 40105, 0  '退出QQ
                        Exit Do
                    End If
                End If
            End If
        End If
        HWnd = FindWindowEx(0, HWnd, "#32770", vbNullString)
    Loop
    QQ_Ext = True
End Function