clifrm.frm

我自己写的查QQ在线用户的程序.本来是用来群发的.后来QQ的程序改了就不能用了.

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form CliFrm 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "用户列表"
   ClientHeight    =   3660
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7320
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   3660
   ScaleWidth      =   7320
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton Command4 
      Caption         =   "计数器清零"
      Height          =   255
      Left            =   840
      TabIndex        =   7
      Top             =   3120
      Width           =   1215
   End
   Begin VB.Timer Timer4 
      Enabled         =   0   'False
      Interval        =   4000
      Left            =   480
      Top             =   3480
   End
   Begin VB.Timer Timer2 
      Enabled         =   0   'False
      Interval        =   4000
      Left            =   960
      Top             =   3480
   End
   Begin VB.Timer Timer3 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   1440
      Top             =   3480
   End
   Begin MSComctlLib.StatusBar SB 
      Align           =   2  'Align Bottom
      Height          =   255
      Left            =   0
      TabIndex        =   6
      Top             =   3405
      Width           =   7320
      _ExtentX        =   12912
      _ExtentY        =   450
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   2
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Object.Width           =   8819
            MinWidth        =   8819
         EndProperty
         BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Object.Width           =   4057
            MinWidth        =   4057
         EndProperty
      EndProperty
   End
   Begin VB.CommandButton Command3 
      Caption         =   "设置"
      Height          =   255
      Left            =   0
      TabIndex        =   5
      Top             =   3120
      Width           =   735
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   0
      Top             =   3480
   End
   Begin VB.CommandButton Command2 
      Caption         =   "结束查找"
      Enabled         =   0   'False
      Height          =   255
      Left            =   6240
      TabIndex        =   3
      Top             =   3120
      Width           =   1095
   End
   Begin VB.CommandButton Command1 
      Caption         =   "开始查找"
      Height          =   255
      Left            =   5040
      TabIndex        =   2
      Top             =   3120
      Width           =   1095
   End
   Begin MSComctlLib.ProgressBar ProgressBar1 
      Height          =   255
      Left            =   0
      TabIndex        =   1
      Top             =   2880
      Width           =   7335
      _ExtentX        =   12938
      _ExtentY        =   450
      _Version        =   393216
      Appearance      =   1
   End
   Begin MSComctlLib.ListView ListView1 
      Height          =   2535
      Left            =   0
      TabIndex        =   0
      Top             =   240
      Width           =   7335
      _ExtentX        =   12938
      _ExtentY        =   4471
      View            =   3
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   3
      BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Text            =   "账号"
         Object.Width           =   2540
      EndProperty
      BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   1
         Text            =   "昵称"
         Object.Width           =   2540
      EndProperty
      BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   2
         Text            =   "来自何处"
         Object.Width           =   2540
      EndProperty
   End
   Begin VB.Label Label2 
      Alignment       =   1  'Right Justify
      BackColor       =   &H8000000A&
      ForeColor       =   &H000000FF&
      Height          =   255
      Left            =   4920
      TabIndex        =   8
      Top             =   0
      Width           =   2415
   End
   Begin VB.Label Label1 
      Caption         =   "已搜索到0个用户"
      Height          =   255
      Left            =   0
      TabIndex        =   4
      Top             =   0
      Width           =   3735
   End
End
Attribute VB_Name = "CliFrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_LEFTDOWN = &H2 '  left button down
Private Const MOUSEEVENTF_LEFTUP = &H4 '  left button up
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
Dim SelBoolean As Boolean
Dim tempQQID As String
Dim 重试次数 As Byte
Dim SendQQID As Long

Private Sub Command1_Click()
Command1.Enabled = False
Command2.Enabled = True

Dim QQHwnd As Long
SelBoolean = False
Timer1.Enabled = True
Test1 = False
Test2 = False
上页ID = 0
下页ID = 0
LVCID = 0


QQHwnd = FindWindow(vbNullString, "QQ2006查找/添加好友")
查找窗体ID = QQHwnd
If QQHwnd <= 0 Then
Label2.Caption = "没有找到查询窗体"
Timer4.Enabled = True
Exit Sub
End If
Label2.Caption = ""

ShowWindow& 查找窗体ID, False
EnumChildWindows QQHwnd, AddressOf EnumClientProc, 0
'GetLVTextAll (Text1.Text)c
DoEvents
PostMessage TabC, TCM_SETCURFOCUS, 1, 0
DoEvents
PostMessage 查找, WM_KEYDOWN, VK_SPACE, 0
PostMessage 查找, WM_KEYUP, VK_SPACE, 0
'Timer2.Enabled = True
Timer3.Enabled = True


End Sub

Private Sub Command2_Click()
Command1.Enabled = True
Command2.Enabled = False
SelBoolean = True
Timer3.Enabled = False
Timer2.Enabled = False
SendQQID = 1
ShowWindow& 查找窗体ID, 1

End Sub

Private Sub Command3_Click()
SelFrm.Show
End Sub
Function GetLVText(mHwnd As Long) As String
    Dim i As Long, s As String
    Dim dwProcessId As Long, hProcess As Long
    Dim dwBytesRead As Long, dwBytesWrite As Long
    Dim bSuccess As Long
    Call GetWindowThreadProcessId(mHwnd, dwProcessId)
    Dim lpListItemRemote As Long, lpTextRemote As Long
    Dim nMaxLen As Long
    nMaxLen = 1023
    Dim szBuf() As Byte
    ReDim szBuf(nMaxLen)
    Dim lvItemLocal As LV_ITEM
    Dim bWriteOK As Long
    
    
    hProcess = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE, 0&, dwProcessId)
    If hProcess <> 0 Then
        lpTextRemote = VirtualAllocEx(ByVal hProcess, ByVal 0&, nMaxLen + 1, MEM_COMMIT, PAGE_READWRITE)
        lpListItemRemote = VirtualAllocEx(ByVal hProcess, ByVal 0&, Len(lvItemLocal), MEM_COMMIT, PAGE_READWRITE)
        bWriteOK = WriteProcessMemory(ByVal hProcess, ByVal lpTextRemote, szBuf(0), nMaxLen + 1, dwBytesWrite)
        lvItemLocal.iItem = 0
        lvItemLocal.iSubItem = lSubItemIndex
        lvItemLocal.mask = LVIF_TEXT
        lvItemLocal.cchTextMax = nMaxLen
        lvItemLocal.pszText = lpTextRemote
        dwBytesWrite = 0
        bWriteOK = WriteProcessMemory(ByVal hProcess, ByVal lpListItemRemote, ByVal VarPtr(lvItemLocal), Len(lvItemLocal), dwBytesWrite)
        i = SendMessage(mHwnd, LVM_GETITEMTEXT, 0, ByVal lpListItemRemote)
        bSuccess = ReadProcessMemory(ByVal hProcess, ByVal lpTextRemote, szBuf(0), nMaxLen + 1, dwBytesRead)
        Call VirtualFreeEx(hProcess, ByVal lpListItemRemote, 0, MEM_DECOMMIT)
        Call VirtualFreeEx(hProcess, ByVal lpTextRemote, 0, MEM_DECOMMIT)
    End If
    CloseHandle hProcess
    
    '*************** 显示结果
    GetLVText = StrConv(LeftB(szBuf, InStrB(szBuf, ChrB(0))), vbUnicode)
    
    '*************** 显示结果
End Function

Public Function GetLVTextAll(mHwnd As Long) As Boolean
    Dim i As Long, s As String
    Dim dwProcessId As Long, hProcess As Long
    Dim dwBytesRead As Long, dwBytesWrite As Long
    Dim bSuccess As Long
    Call GetWindowThreadProcessId(mHwnd, dwProcessId)
    Dim lpListItemRemote As Long, lpTextRemote As Long
    Dim nMaxLen As Long
    nMaxLen = 1023
    Dim szBuf() As Byte
    ReDim szBuf(nMaxLen)
    Dim lvItemLocal As LV_ITEM
    Dim bWriteOK As Long
    Dim lItemIndex As Long
    Dim NewLV
    Dim sItemText As String
    
    Dim lSubItemIndex As Long
    
    Dim lListItemCount As Long, lSubItemCount As Long, k As Long, j As Long
    
    lListItemCount = SendMessage(mHwnd, LVM_GETITEMCOUNT, 0&, ByVal 0&)
    lSubItemCount = GetColumnHeaderCount(mHwnd) - 1
    
    hProcess = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE, 0&, dwProcessId)
    If hProcess <> 0 Then
        lpTextRemote = VirtualAllocEx(ByVal hProcess, ByVal 0&, nMaxLen + 1, MEM_COMMIT, PAGE_READWRITE)
        lpListItemRemote = VirtualAllocEx(ByVal hProcess, ByVal 0&, Len(lvItemLocal), MEM_COMMIT, PAGE_READWRITE)
        
        For k = 0 To lListItemCount - 1
            lItemIndex = k
            For j = 0 To lSubItemCount
                lSubItemIndex = j
                bWriteOK = WriteProcessMemory(ByVal hProcess, ByVal lpTextRemote, szBuf(0), nMaxLen + 1, dwBytesWrite)
                lvItemLocal.iItem = lItemIndex
                lvItemLocal.iSubItem = lSubItemIndex
                lvItemLocal.mask = LVIF_TEXT
                lvItemLocal.cchTextMax = nMaxLen
                lvItemLocal.pszText = lpTextRemote
                dwBytesWrite = 0
                bWriteOK = WriteProcessMemory(ByVal hProcess, ByVal lpListItemRemote, ByVal VarPtr(lvItemLocal), Len(lvItemLocal), dwBytesWrite)
                i = SendMessage(mHwnd, LVM_GETITEMTEXT, lItemIndex, ByVal lpListItemRemote)
                bSuccess = ReadProcessMemory(ByVal hProcess, ByVal lpTextRemote, szBuf(0), nMaxLen + 1, dwBytesRead)
                i = InStrB(szBuf, ChrB(0))
                If i > 1 Then i = i - 1
                sItemText = StrConv(LeftB(szBuf, i), vbUnicode)
            If j = 0 Then
            If IsListview(sItemText) Then
            Set NewLV = ListView1.ListItems.Add(, , sItemText)
            Else
            Exit For
            End If
            Else
            NewLV.SubItems(j) = sItemText
            End If
            Next
            If SelBoolean = True Then Exit For
            DoEvents
            Label1.Caption = "已搜索到" & ListView1.ListItems.Count & "个用户"
        Next
        
        Call VirtualFreeEx(hProcess, ByVal lpListItemRemote, nMaxLen + 1, MEM_DECOMMIT)
        Call VirtualFreeEx(hProcess, ByVal lpTextRemote, Len(lvItemLocal), MEM_DECOMMIT)
        CloseHandle hProcess
    End If
    GetLVTextAll = True
  '  Close #lFreefile
End Function
Private Function IsListview(strs As String) As Boolean

Dim i As Integer, b As Boolean
If ListView1.ListItems.Count <= 0 Then
IsListview = True
Exit Function
End If

For i = 1 To ListView1.ListItems.Count
If ListView1.ListItems(i).Text = strs Then
b = True
IsListview = False
Exit Function
End If
Next
IsListview = True
End Function
Function GetColumnHeaderCount(ByVal hLVWnd As Long) As Long
    Dim hHD As Long
    hHD = SendMessage(hLVWnd, LVM_GETHEADER, 0, ByVal 0)
    If hHD = 0 Then Exit Function
    GetColumnHeaderCount = SendMessage(hHD, HDM_GETITEMCOUNT, 0, ByVal 0)
End Function



Private Sub Form_Load()

ReDim mClassName(0) As String
SendQQID = 1

SetLvCou True
End Sub
Private Sub SetLvCou(Cls As Boolean)
If Cls = True Then
ListView1.ColumnHeaders.Clear
ListView1.ColumnHeaders.Add , , "QQ号", 1500
ListView1.ColumnHeaders.Add , , "昵称", 1500
ListView1.ColumnHeaders.Add , , "性别", 629
ListView1.ColumnHeaders.Add , , "年龄", 629
ListView1.ColumnHeaders.Add , , "来自", 2220
ListView1.ColumnHeaders.Add , , "状态", 675
Else
ListView1.ColumnHeaders.Clear
ListView1.ColumnHeaders.Add , , "QQ号", 1500
ListView1.ColumnHeaders.Add , , "昵称", 1500
ListView1.ColumnHeaders.Add , , "来自何处", 4200
End If



End Sub
'Private Sub Timer1_Timer()
'If SelBoolean = True Then
'Timer1.Enabled = False
'ProgressBar1.Value = 99
'End If
'If ProgressBar1.Value >= 100 Then ProgressBar1.Value = 0
'ProgressBar1.Value = ProgressBar1.Value + 1
'End Sub

Private Sub Timer2_Timer()
On Error GoTo lwt
If Not SendQQID > ListView1.ListItems.Count Then
    If Dir(App.Path & "\Timwp.exe") = "" Then
        Unload SelFrm
        Unload CliFrm
    Else
        SB.Panels(1).Text = "QQ号:" & ListView1.ListItems(SendQQID).Text & "   昵称:" & ListView1.ListItems(SendQQID).SubItems(1)
        SB.Panels(2).Text = "记数器:" & SendQQID
        
        EnumWindows AddressOf EnumSendMsg, 0
        Shell App.Path & "\Timwp.exe tencent://Message/?menu=yes&exe=&uin=" & ListView1.ListItems(SendQQID).Text & "&websiteName=未知区域&info=", vbNormalFocus
        SendQQID = SendQQID + 1
    End If
End If
Exit Sub

lwt:
Timer2.Enabled = False
Label2.Caption = "QQ被关闭,请重新启动"


End Sub

Private Sub Timer3_Timer()
If IsWindowEnabled(下页(0)) = 1 Then

If Not tempQQID = GetLVText(LVC(0)) Then
GetLVTextAll (LVC(0))
tempQQID = GetLVText(LVC(0))
PostMessage 下页(0), WM_KEYDOWN, VK_SPACE, 0
PostMessage 下页(0), WM_KEYUP, VK_SPACE, 0
Else
If 重试次数 > 2 Then
重试次数 = 0
Call Command1_Click
End If

重试次数 = 重试次数 + 1

End If

Else
PostMessage 上页(0), WM_KEYDOWN, VK_SPACE, 0
PostMessage 上页(0), WM_KEYUP, VK_SPACE, 0
PostMessage 下页(0), WM_KEYDOWN, VK_SPACE, 0
PostMessage 下页(0), WM_KEYUP, VK_SPACE, 0
End If


End Sub

Private Sub Timer4_Timer()
Timer4.Enabled = False
Call Command1_Click
End Sub