modqqpwd.bas

一个用汇编、VC、VB联合写的破解QQ密码的工具

Attribute VB_Name = "modQQPwd"
Option Explicit

Public Type QQSum
  dwSum(3) As Long
End Type

Public Declare Sub QQMD5 Lib "QQMD5.DLL" (ByVal pPwd As Long, ByVal lPwdLen As Long, ByVal lAST As Long, ByVal pQQSum As Long)
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long

Public Sub Main()
  Load frmQQPwd
  frmQQPwd.Show
End Sub

Public Function INNER_GetQQHash(fsPwd As String, _
                                flAST As Long, _
                                Optional fbByVB As Boolean = False) As String
  Dim k As Long
  Dim lLen As Long
  Dim byt() As Byte
  Dim bytPwd(1000) As Byte '对于大于1000的密码请自行处理,将1000修改为你的密码长度
  Dim TOutQQSum As QQSum
  
  If fbByVB Then '使用VB来计算
      fsPwd = INNER_MD5(fsPwd)
      For k = 1 To flAST - 1
        fsPwd = INNER_MD5(fsPwd, True)
        DoEvents '如果写专业代码，注意退出程序时，在这里要跳出，避免程序无法关闭
      Next k
      '在QQ里，与EF异或
      For k = 1 To 4
        INNER_GetQQHash = INNER_GetQQHash & INNER_Format(Hex$(Val(Val("&H" & Mid(fsPwd, (k - 1) * 8 + 1, 8))) Xor &HEFEFEFEF), "00000000")
      Next k
  Else
      If fsPwd = "" Then GoTo BlankPwdLabel
      byt = INNER_Str2ByteA(fsPwd, lLen)
      If lLen < UBound(bytPwd) Then
        For k = 0 To lLen - 1
          bytPwd(k) = byt(k)
        Next k
BlankPwdLabel:
        '采用固定数组，避免使用动态分配的内存地址，保证程序的稳定运行
        QQMD5 VarPtr(bytPwd(0)), lLen, flAST, VarPtr(TOutQQSum)
        For k = 0 To 3
          INNER_GetQQHash = INNER_GetQQHash & LoFormatHex(TOutQQSum.dwSum(k))
        Next k
      End If
  End If
End Function

Private Function LoFormatHex(flInput As Long) As String
   LoFormatHex = Hex(flInput)
   If Len(LoFormatHex) < 8 Then
     LoFormatHex = String(8 - Len(LoFormatHex), "0") & LoFormatHex
   End If
End Function

Public Function INNER_StrLen(fsData As String) As Long
'    2002-4-13日  在调试程序的过程中，用手机的串口来调试程序发现错误（6-溢出），修改发现：
'系统中对lstrlen函数的应用有问题，不能过于依赖该函数。
'    由于lstrlen是判断尾部为零，故如果fsData中含有0，则长度错误。现改为：
    Dim sSplit
    Dim k As Long
    Dim sString As String
    '"abc赵ca" & Chr(0) & "ssde宾" & Chr(0) & Chr(0) & "abc反对" //23
    'Chr(0) & "abc赵ca" & Chr(0) & "ssde宾" & Chr(0) & Chr(0) & "abc反对" & Chr(0) & Chr(0) //26
    sSplit = Split(fsData, Chr(0))
    For k = 0 To UBound(sSplit)
      INNER_StrLen = INNER_StrLen + lstrlen(sSplit(k) & Chr(0))
    Next k
    INNER_StrLen = INNER_StrLen + UBound(sSplit)
End Function

Public Function INNER_Str2ByteA(fsData As String, Optional ByRef RetLen As Long) As Byte()
    Dim k As Long
    Dim n As Long
    Dim lAscii As Long
    Dim bytTemp() As Byte
    RetLen = INNER_StrLen(fsData)
'    RetLen = 0
    If RetLen = 0 Then
      ReDim bytTemp(0)
    Else
      ReDim bytTemp(0 To RetLen - 1)
      CopyMemory ByVal VarPtr(bytTemp(0)), ByVal StrPtr(StrConv(fsData, vbFromUnicode)), RetLen
'      For k = 1 To Len(fsData)
'        lAscii = Asc(Mid(fsData, k, 1))
'        If lAscii >= 0 Then
'          bytTemp(n) = lAscii
'          n = n + 1
'        Else
'          bytTemp(n) = (65536 + lAscii) \ 256
'          n = n + 1
'          bytTemp(n) = (65536 + lAscii) Mod 256
'          n = n + 1
'        End If
'      Next k
    End If
    INNER_Str2ByteA = bytTemp
End Function

Public Function INNER_ByteA2Hex(fbytInput) As String
    Dim k As Integer
    For k = 0 To UBound(fbytInput)
        INNER_ByteA2Hex = INNER_ByteA2Hex & INNER_Byte2Hex(fbytInput(k))
    Next k
End Function

Public Function INNER_Byte2Hex(ByVal fbytInput As Byte) As String
    Dim sTemp As String
    sTemp = Hex$(fbytInput)
    INNER_Byte2Hex = IIf(Len(sTemp) = 1, "0" & sTemp, sTemp)
End Function

Public Function INNER_Hex2Double(fsHex As String) As Double
  Dim k As Long
  For k = 1 To Len(fsHex) / 2
    INNER_Hex2Double = INNER_Hex2Double + Val("&H" & Mid(fsHex, (k - 1) * 2 + 1, 2)) * (256 ^ (k - 1))
  Next k
End Function