www.pudn.com > QQ2005Pwd.rar > modQQPwd.bas

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