软件绑定QQ VB源码

基本原理是：获取本机登录的QQ号是否与绑定注册的QQ号一致，再判定QQ号是否在线，未在线的话不能使用全部功能或干脆退出。

实现代码，本人用vb6.0开发的，实现代码如下：

'Option Explicit
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const READ_CONTROL As Long = &H20000
Private Const STANDARD_RIGHTS_REQUIRED As Long = &HF0000
Private Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
Private Const STANDARD_RIGHTS_EXECUTE As Long = (READ_CONTROL)
Private Const STANDARD_RIGHTS_ALL As Long = &H1F0000
Private Const STANDARD_RIGHTS_WRITE As Long = (READ_CONTROL)
Private Const SYNCHRONIZE As Long = &H100000
Private Const PROCESS_ALL_ACCESS As Long = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF)
Private Const PROCESS_TERMINATE As Long = (&H1)
Private Declare Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Const WM_USER As Long = &H400
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 Const TB_BUTTONCOUNT As Long = (WM_USER + 24)
Private Const TB_HIDEBUTTON As Long = (WM_USER + 4)
Private Const TB_GETBUTTON As Long = (WM_USER + 23)
Private Const TB_GETBITMAP As Long = (WM_USER + 44)
Private Const TB_DELETEBUTTON As Long = (WM_USER + 22)
Private Const TB_ADDBUTTONS As Long = (WM_USER + 20)
Private Const TB_INSERTBUTTON As Long = (WM_USER + 21)
Private Const TB_ISBUTTONHIDDEN As Long = (WM_USER + 12)
Private Const ILD_NORMAL As Long = &H0
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function WriteProcessMemory Lib "kernel32.dll" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32.dll" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function VirtualAllocEx Lib "kernel32.dll" (ByVal hProcess As Long, lpAddress As Any, ByRef dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32.dll" (ByVal hProcess As Long, lpAddress As Any, ByRef dwSize As Long, ByVal dwFreeType As Long) As Long
Private Const PROCESS_VM_OPERATION As Long = (&H8)
Private Const PROCESS_VM_READ As Long = (&H10)
Private Const PROCESS_VM_WRITE As Long = (&H20)
Private Const MEM_RESERVE As Long = &H2000
Private Const MEM_COMMIT As Long = &H1000
Private Const MEM_RELEASE As Long = &H8000
Private Const PAGE_READWRITE As Long = &H4

Private Function ConverNull(ByVal S As String) As String
    Dim nullpos As Long
    nullpos = InStr(S, Chr$(0))
    If nullpos > 0 Then
        ConverNull = Left(S, nullpos - 1)
    Else
        ConverNull = S
    End If
End Function

Public Function getQQ() As String
    Dim lngTemp As Long
    Dim lngTray
    Dim lngPID As Long
    Dim lngPID2 As Long
    Dim hProcess As Long
    Dim lngProcess As Long
    Dim lngAddress As Long
    Dim lngCount As Long
    Dim lngButtons As Long
    Dim ret As Long
    Dim lngTextAdr As Long
    Dim lngHwndAdr As Long
    Dim lngButtonID As Long
    Dim hIcon As Long
    Dim lngHwnd As Long
    Dim lpFileName As String * 1024
    Dim i As Long
    Dim strBuff(1024) As Byte
    Dim strText As String
    Dim lngTrayDC As Long
    Dim Start As Long
    Dim str As String
    lngTemp = FindWindow("Shell_TrayWnd", vbNullString)
    lngTemp = FindWindowEx(lngTemp, 0, "TrayNotifyWnd", vbNullString)
    lngTemp = FindWindowEx(lngTemp, 0, "SysPager", vbNullString)
        lngTray = FindWindowEx(lngTemp, 0, "ToolbarWindow32", vbNullString)
    Debug.Print "lngTray="; lngTray
    ret = GetWindowThreadProcessId(lngTray, lngPID)
    hProcess = OpenProcess(PROCESS_ALL_ACCESS Or PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE, 0, lngPID)
    lngAddress = VirtualAllocEx(hProcess, ByVal 0&, ByVal 4096&, MEM_COMMIT, PAGE_READWRITE)
    lngButtons = SendMessage(lngTray, TB_BUTTONCOUNT, 0, 0)
    For i = 0 To lngButtons - 1
        ret = SendMessage(lngTray, TB_GETBUTTON, ByVal i, ByVal lngAddress)
        ret = ReadProcessMemory(hProcess, ByVal lngAddress + 16, ByVal VarPtr(lngTextAdr), ByVal 4, ByVal 0&)
        If lngTextAdr <> -1 Then
            ret = ReadProcessMemory(hProcess, ByVal lngTextAdr, ByVal VarPtr(strBuff(0)), ByVal 1024, ByVal 0&)
            ret = ReadProcessMemory(hProcess, ByVal lngAddress + 12, ByVal VarPtr(lngHwndAdr), ByVal 4, ByVal 0&)
            ret = ReadProcessMemory(hProcess, ByVal lngHwndAdr, ByVal VarPtr(lngHwnd), ByVal 4, ByVal 0&)
            ret = ReadProcessMemory(hProcess, ByVal lngAddress + 4, ByVal VarPtr(lngButtonID), ByVal 4, ByVal 0&)
            strText = ConverNull(strBuff)

              If Left(strText, 3) = "QQ:" Then
                 '仅提取QQ号码
                 Dim l1 As Integer
                 Dim l2 As Integer
                 l1 = InStr(strText, "(")
                 l2 = InStr(strText, ")")

                 str = Mid(strText, l1 + 1, l2 - l1 - 1)

                 getQQ = str
              End If
         End If
    Next i
    VirtualFreeEx hProcess, ByVal lngAddress, ByVal 4096&, MEM_RELEASE
    CloseHandle hProcess
End Function

'判断QQ是否在线
Public Function if_QQonline(qq_str As String) As Boolean
On Error Resume Next
Dim QQUrl As String
Dim QQ As String

If qq_str <> getQQ Then
   m = MsgBox("你绑定的QQ号未在当前使用的电脑上登录，不能使用全部功能！", vbExclamation)
   if_QQonline = False
   Exit Function
End If

QQ = qq_str
QQUrl = "" & QQ & ":7"
Dim rlt() As Byte

rlt = 总控窗体.Inet1.OpenURL(QQUrl, icByteArray)

If rlt(13) = &H34 Then
   if_QQonline = False
ElseIf rlt(13) = &H52 Then
      if_QQonline = True
   Else
      if_QQonline = False
End If

End Function

Public Function if_registQQonline(ifdisp As Boolean) As Boolean
'ifdisp变量为是否弹出警告框
if_registQQonline = False

Set adocon = New ADODB.Connection
Set rsado = New ADODB.Recordset
adocon.Open "Provider=Microsoft.jet.OLeDB.4.0;Data Source=" & App.Path & "\data\综合设置.mdb;"
Set rsado.ActiveConnection = adocon
rsado.LockType = adLockOptimistic
rsado.CursorLocation = adUseClient
Dim str As String

'看注册方式是否为绑定QQ，不是的话则退出
str = "select * from 注册信息 where 项目名称='注册方式' "
rsado.Open str
If rsado.EOF Then
   l = MsgBox(mybase64.DecodeBase64String(Mymsg3), vbExclamation)
   adocon.Close
   End
End If
rsado.MoveFirst
If IsNull(rsado.Fields("设置值").value) Then
   adocon.Close
   GoTo out
End If
registname = rsado.Fields("设置值").value
rsado.Close
If registname = "0" Then
   if_registQQonline = True
   adocon.Close
   GoTo out
End If


'读取存于数据库中的QQ号
str = "select * from 注册信息 where 项目名称='QQ号' "
rsado.Open str
If rsado.EOF Then
   l = MsgBox(mybase64.DecodeBase64String(Mymsg3), vbExclamation)
   adocon.Close
   End
End If
rsado.MoveFirst
If IsNull(rsado.Fields("设置值").value) Then
   adocon.Close
   GoTo out
End If
registname = rsado.Fields("设置值").value
rsado.Close
adocon.Close

If if_QQonline(CStr(registname)) = True Then
   if_registQQonline = True
Else
   'if_registQQonline = False
   If ifdisp Then m = MsgBox(mybase64.DecodeBase64String(Mymsg8), vbExclamation) '不在线提示
End If

out:
End Function