Codigo sin utilidad
 

Cuando estaba buscando información sobre Python me encontré con esta pagina "Useless Python", y la idea en que se basa la pagina me parece interesante o por lo menos entretenida. Se basa en poner trozos de código pequeños, simples y que no tienen porque tener una utilidad concreta, se trata de jugar con el lenguaje y sus posibilidades.

Se me ocurrió hacer algo parecido por aquí, no se muy bien como plantearlo, pero consistiría en colocar en este mismo hilo, por ejemplo, trocitos de código que tengamos por ahí, no tienen que tener una utilidad concreta, pero deben ser simples y estar comentados.

Para dar ejemplo empiezo yo *:

Código Delphi [-]
// Esta funcion dibuja un texto usando letras, jeje
function StrToStr(Str: string): string;
var
  Bitmap: TBitmap;
  i,j: integer;
begin
  Result:= '';
  // Creamos un Bitmap
  Bitmap:= TBitmap.Create;
  try
    // Ajustamos el tipo y tamaño de la fuente
    Bitmap.Canvas.Font.Name:= 'Arial Black';
    Bitmap.Canvas.Font.Size:= 16;
    // Ajustamos el tamaño del Bitmap al tamaño del texto
    Bitmap.Width:= Bitmap.Canvas.TextWidth(Str);
    Bitmap.Height:= Bitmap.Canvas.TextHeight(Str);
    // Escribimos el texto en el bitmap
    Bitmap.Canvas.TextOut(0,0,Str);
    // Vamos leyendo pixel a pixel del bitmap
    for j:= 0 to Bitmap.Height - 1 do
    begin
      for i:= 0 to Bitmap.Width - 1 do
        // Por cada pixel blanco añadimos la letra _ al resultado
        if Bitmap.Canvas.Pixels[i,j] = $FFFFFF then
          Result:= Result + '_'
        else
          // y por cada pixel que no es blanco añadimos una X
          Result:= Result + 'X';
      // Al final de cada fila de pixeles añadimo al resultado un salto de linea
      Result:= Result + #13#10;
    end;
  finally
    // Eliminamos el bitmap, ya no lo necesitamos
    Bitmap.Free;
  end;
end;

// Por ejemplo
ShowMessage(StrToStr('ClubDelphi') );

* Nota: Algunos recordareis esta función de otro hilo, pero dispongo de poco código que no este ya publicado :D . Pero buscare por ahí, seguro que encuentro algo mas.

Ahora uno un poco mas complicado, aunque prometo buscar alguno mas sencillo :p

Pues bien, el siguiente código sirve para montar un servidor de números aleatorios. Cuando se ejecuta la función "Aleator" el programa se pone a escuchar por el puerto 1978, y cuando alguien se conecta a el, comienza a enviarle números aleatorios a intervalos de 100 milisegundos.

Código Delphi [-]
uses
  // Winsock tiene que estar en las uses
  Windows, SysUtils, Winsock;

// Cada conexion se ejecuta en un thread diferente
function ThreadProc(Socket: TSocket): Integer;
var
  Str: String;
begin
  Result:= 0;
  try
    // En este bucle se mandan los numeros
    repeat
      // Un retardo de 100 ms entre numero y numero
      Sleep(100);
      // Convertimos el numero a hexadecimal, para que quede bonito
      Str:= IntToHex(Random(MAXINT),8);
      // y lo mandamos hasta que nuestro cliente se desconecte 
    until send(Socket,PChar(Str)^,Length(Str)+1,0) = SOCKET_ERROR;
  finally
    // Cerramos la conexion
    Shutdown(Socket,SD_SEND);  // SD_SEND = 1;
    CloseSocket(Socket);
    // Terminamos el thread
    EndThread(0);
  end;
end;

// Este es el bucle principal
procedure Aleator;
var
  WSADATA: TWSADATA;
  ServerSocket: TSocket;
  LocalAddr: TSockaddr;
  ClientSocket: TSocket;
  RemoteAddr: TSockaddr;
  AddrSize: Integer;
  FDSet: TFDSet;
  TimeVal: TTimeVal;
  ThreadId: LongWord;
begin  
  Randomize;
  // Inicializamos Winsock
  if WSAStartup(MAKEWORD(1, 1), WSADATA) = 0 then
  try
    // Creamos el Socket del servidor
    ServerSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_IP);
    if ServerSocket <> INVALID_SOCKET then
    begin
      // Configuramos la ip y el puerto que vamos a usar
      with LocalAddr do
      begin
        sin_family := AF_INET;
        // Aqui colocamos el puerto a usar
        sin_port := htons(1978);
        // Aqui indicamos que usaremos cualquier ip de nuestro equipo
        sin_addr.s_addr := htonl(INADDR_ANY);
        // Si queremos limitarnos a una ip en concreto usaremos la siguiente linea
        // sin_addr.s_addr:= Inet_Addr('127.0.0.1');
      end;
      // Ponemos el Socket a la escucha ...
      if bind(ServerSocket, LocalAddr, sizeof(LocalAddr)) <> SOCKET_ERROR then
        if listen(ServerSocket, SOMAXCONN) <> SOCKET_ERROR then
        begin
          repeat
            TimeVal.tv_sec := 0;
            TimeVal.tv_usec := 500;
            FD_ZERO(FDSet);
            FD_SET(ServerSocket, FDSet);
            // Comprobamos el estado del socket
            if select(0, @FDSet, nil, nil, @TimeVal) > 0 then
            begin
              AddrSize := sizeof(RemoteAddr);
              // Aceptamos la nueva conexion y creamos un nuevo Thread
              ClientSocket := accept(ServerSocket, @RemoteAddr, @AddrSize);
              if ClientSocket <> INVALID_SOCKET then
                // Creamos un nuevo tread usando la API
                BeginThread(nil, 0, @ThreadProc, Pointer(ClientSocket),
                  0, ThreadID);
            end;
          until FALSE; // Aquí ponemos la condición que nos apetezca
        end;
    end;
  finally
    WSACleanup();
  end;
end;

Para probarlo solo tenemos que usar, por ejemplo, el telnet:

No creo que haya problema conmigo, la mayoría del código que escribo no tiene utilidad :D :D.

Hablando en serio, las rutinas que escribiste están muy buenas y siempre aprendo mucho de ellas.

Saludos

El siguiente código baja las tiras de Raulito el friki, en el rango especificado. Si se utiliza un rango muy grande tarda un poco así que paciencia.

Código Delphi [-]
uses UrlMon, ShellApi;

procedure Raulito(Min, Max: Integer);
var
  i: Integer;
  Path: Array[0..MAX_PATH] of Char;
begin
  FillChar(Path,Sizeof(Path),#0);
  // Obtenemos el directorio temporal
  if GetTempPath(Sizeof(Path)-1, @Path) <> 0 then
  begin
    // Creamos el directorio "Raulito", dentro del temporal, si no existe ya 
    if DirectoryExists((String(Path) + 'Raulito')) or
      CreateDir(String(Path) + 'Raulito') then
    begin
      // Comenzamos el bucle
      for i:= Min to Max do
        // Bajamos la imagen al directorio "Raulito"
        UrlDownloadToFile(nil,
          PChar(Format('http://www.telefonica.net/web2/recurrente/tira/tira%d.png',[i])),
          PChar(String(Path) + Format('Raulito\tira%d.png',[i])),0,nil);
      // Mostramos la carpeta "Raulito"
      Shellexecute(0,nil,PChar(String(Path) + 'Raulito'),nil,nil,SW_SHOW);
    end;
  end;
end;


// Por ejemplo
Raulito(80,89);
// O si queremos todas (hasta hoy)
Raulito(0,89);

Ahora es el turno de un interprete de Brainfucker :D

La wikipedia define este lenguaje de la siguiente manera:
Para saber mas sobre este lenguaje:
http://es.wikipedia.org/wiki/Brainfuck (Español)
http://en.wikipedia.org/wiki/Brainfuck (Ingles)

Ahora que ya sabemos algo sobre el Brainfucker, vamos con su interprete:

Código Delphi [-]
program bf;

{$APPTYPE CONSOLE}

uses Windows, SysUtils, Classes;

// Esta funcion interpreta el codigo
procedure Brainfuck(Codigo: String);
const
  // El tamaño del array, el estandar es 30000
  Size = 30000;
  // Mensajes de error del interprete
  strPointerError = 'El puntero no es valido';
  strBracketError = 'Se encontro un bracket sin pareja';
var
  i,j: Integer;
  Min, Max, P: PByte;
begin
  // Obtenemos memoria para alojar el array de bytes
  GetMem(Min,Size);
  try
    // Inicializamos el array a cero
    FillChar(Min^,Size,#0);
    // Establecemos el limite superior e inferior
    Max:= Min;
    inc(Max,Size - 1);
    // Inicializamos el puntero en la primera posicion del array
    P:= Min;
    i:= 1;
    // Comenzamos a recorrer el codigo
    while (i <= Length(Codigo)) do
    begin
      case Codigo[i] of
        '>': begin  // Incrementamos el puntero
               if P = Max then
                 raise Exception.Create(strPointerError);
               inc(P);
             end;
        '<': begin  // Decrementamos el puntero
               if P = Min then
                 raise Exception.Create(strPointerError);
               dec(P);
             end;
        '+': inc(P^); // Incrementamos el valor actual
        '-': dec(P^); // Leemos el valor actual
        '.': Write(Char(P^)); // Imprimime el valor actual
        ',': Read(Char(P^)); // Lee un valor de la entrada
        '[': if P^ = 0 then // Comienza un bucle
             begin
               j:= 1;
               // Como la condicion es cero saltamos al final del bucle
               repeat
                 inc(i);
                 if i > Length(Codigo) then
                    raise Exception.Create(strBracketError);
                  case Codigo[i] of
                    '[': inc(j);
                    ']': dec(j);
                  end;
               until (j=0);
             end;
        ']': if P^ <> 0 then // Finaliza un bucle
             begin
               j:= 1;
               repeat
                 dec(i);
                 // Como la condicion no es cero saltamos al principio del bucle
                 if i < 1 then
                    raise Exception.Create(strBracketError);
                  case Codigo[i] of
                    '[': dec(j);
                    ']': inc(j);
                  end;
               until (j=0);
             end;
      end;
      inc(i);
    end;
  finally
    // Liberamos la memoria del array
    FreeMem(Min);
  end;
end;

begin
  // Comprobamos que nos han pasado el fichero con el codigo
  if ParamCount = 1 then
  try
    with TStringList.Create do
    try
      // Abrimos el fichero con el codigo
      LoadFromFile(ParamStr(1));
      // Lo interpretamos
      Brainfuck(Text);
    finally
      Free;
    end;
  except
    // Si ocurre una excepcion la imprimimos
    On E: Exception do
    begin
      Writeln(E.Message);
    end;
  end;
end.

Ya tenemos nuestro flamante interprete de Brainfucker, pero haciendo honor a su nombre, es jodidamente complicado programar en este lenguaje :D . Así que sera mejor que pongamos algunos ejemplo para probarlo.

El hola mundo:
La serie de Fibbonaci:
Este es la leche, introduces un numero y el lo dibuja girado 45 grados:
Como podéis ver, este interprete si que es algo de lo mas inútil en el mundo real, pero puede resultar fascinante para algún friki como yo :D

PD: La función de entrada ',' no termina de convencerme como esta implementada, si alguien se anima a mejorarla ...

Hola,

Joroba con el BrainFucker... :D :D :D

Pues mira, quería aportar mi granito a este hilo, y de momento va a ser que no. Parece que todo lo que hago resulta útil :D :D .
Esto no es código pero buscando en la sección de trucos un poco de código, resulta que me he encontrado con algo que me ha resultado inútil...

• si buscas por sector: no devuelve nada
• si buscas por cluster: no devuelve nada
• si buscas por sector cluster: el resultado es inútil...:D

Palíndromos....
 

A ver si esto puede resultar inútil....

Código Delphi [-]
//Esta función invierte el contenido del texto pasado (Upper)
Function Invertir(Texto: String) : String;
Var I : Integer;
Begin
    For I := Length(Texto) downto 1 DO
        Result := Result + Texto[i];
    Result := UpperCase(Result);
End;



// Algunos ejemplos inútiles 
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage( Invertir('SOMETEMOS'));
ShowMessage( Invertir('RECONOCER'));
ShowMessage( Invertir('SOLDADLOS'));
ShowMessage( Invertir('Amigo no gima.'));
ShowMessage( Invertir('Sé verlas al revés.') );
ShowMessage( Invertir('Se lo creí, mareada. Era miércoles') );
ShowMessage( Invertir('No solo no lo son') );
ShowMessage( Invertir('Nada, yo soy Adán') );
ShowMessage( Invertir('La ruta nos aportó otro paso natural') );
ShowMessage( Invertir('Dábale arroz a la zorra el abad') );
ShowMessage( Invertir('Anita lava la tina'));
ShowMessage( Invertir('Anita la gorda lagartona no traga la droga latina'));
end;

:D Eso es porque no sabes como buscar
http://www.clubdelphi.com/trucos/index.php?id=356

:( O porque nadie mira mis hilos
http://www.clubdelphi.com/foros/showthread.php?t=34186
http://www.clubdelphi.com/foros/show...83&postcount=8

Pero estamos hablando de código inútil, ya veo que tu te has animado. Haber si alguien mas se anima ... :D Vale cualquier cosa ...

Hola,

Hombre, este Hilo parece pensado para cierto ¿programa? que escribí hace tiempo para ilustrar no sé qué Hilo de estos Foros. Nótese que no he tocado una coma del código para publicarlo en este Hilo:

Código Delphi [-]
{*******************************************************}
{                                                       }
{       Pelota Loca, un programa inútil (?)             }
{                                                       }
{       Copyright (c) 2006 David Esperalta              }
{                                                       }
{               GNU Public License                      }
{                                                       }
{*******************************************************}

program PelotaLoca;

{$APPTYPE CONSOLE}

uses
  Forms,
  Windows,
  Classes,
  SysUtils,
  Controls,
  ExtCtrls,
  Graphics;

const
  CANTIDAD_MOVIMIENTO = 15; { Cantidad de movimiento }

var
  FForm  : TForm;
  FShape : TShape;

type
  TAuxiliar = class
  private
    FTimer: TTimer;
    procedure TimerTick(Sender: TObject);
    procedure KeyDownEvent(Sender: TObject;
               var Key: Word; Shift: TShiftState);
  public
    constructor Create;
    destructor Destroy; override;
  end;

{ TAuxiliar }

constructor TAuxiliar.Create;
begin
  FTimer := TTimer.Create(nil);
  FTimer.Interval := 100;
  FTimer.Enabled  := true;
  FTimer.OnTimer  := TimerTick;
end;

destructor TAuxiliar.Destroy;
begin
  FTimer.Free;
  inherited Destroy;
end;

procedure TAuxiliar.KeyDownEvent(Sender: TObject;
  var Key: Word; Shift: TShiftState);
begin
  with FShape do case Key of
    VK_UP:    Top  := Top  - CANTIDAD_MOVIMIENTO;
    VK_RIGHT: Left := Left + CANTIDAD_MOVIMIENTO;
    VK_DOWN:  Top  := Top  + CANTIDAD_MOVIMIENTO;
    VK_LEFT:  Left := Left - CANTIDAD_MOVIMIENTO;
  end;
end;

procedure TAuxiliar.TimerTick(Sender: TObject);
resourcestring
  rsCaption = 'Top: %d - Left: %d';
begin
  with FShape do
  begin
    FForm.Caption := Format(rsCaption, [Top, Left]);

    if (Left > FForm.Width)  then Left := 2;
    if (Top  > FForm.Height) then Top  := 2;

    if (Left < 0) then Left := (FForm.Width  - Width);
    if (Top  < 0) then Top  := (FForm.Height - Height);

    if (GetKeyState(VK_UP) and $4000) > 0
      then Top  := Top  - CANTIDAD_MOVIMIENTO;

    if (GetKeyState(VK_DOWN) and $4000) > 0
      then Top  := Top  + CANTIDAD_MOVIMIENTO;

    if (GetKeyState(VK_LEFT) and $4000) > 0
      then Left := Left - CANTIDAD_MOVIMIENTO;

    if (GetKeyState(VK_RIGHT) and $4000) > 0
      then Left := Left + CANTIDAD_MOVIMIENTO;
  end;
end;

procedure Inicializar();
var
  FAuxilar: TAuxiliar;
begin
  FAuxilar := TAuxiliar.Create;
  FForm    := TForm.Create(nil);
  FShape   := TShape.Create(FForm);

  with FForm do
  begin
    Width       := 400;
    Height      := 300;
    Color       := clWhite;
    KeyPreview  := true;
    BorderStyle := bsDialog;
    Position    := poDesktopCenter;
    OnKeyDown   := FAuxilar.KeyDownEvent;
  end;

  with FShape do
  begin
    Width       := 20;
    Height      := 20;
    Parent      := FForm;
    Brush.Color := clRed;
    Pen.Color   := clWhite;
    Shape       := stCircle;
    Top         := CANTIDAD_MOVIMIENTO;
    Left        := CANTIDAD_MOVIMIENTO;
  end;

  try
    FForm.ShowModal;
  finally
    FForm.Free;
    FAuxilar.Free;
  end;
end;

begin { application }

  Inicializar();

end.

Reconozco que no es tan bueno como el código de Seoane, pero, es que Seoane es mucho Seoane. :)

Ah. Lo que hace el programa es mostrar un formulario y dentro de este una "pelota". El usuario puede mover la pelota por el formulario utilizando las teclas/flechas.

Hola de nuevo,

Ya en el colmo de la inutilidad tengo este código por aquí... que en su momento también fue publicado en estos Foros. Se trata de una unidad que contiene un procedimiento capaz de mostrar un formulario al estilo "MSN Messenger"... con un mensaje dentro y todo. :D

Código Delphi [-]
{··············································}
{······························· dec - 20005 ··}
{··············································}
{·} unit UMsgPopup; interface {················}
{·} uses Forms,{···}StdCtrls, {················}
{·} Windows,Classes,Graphics; {················}
{·} procedure MsgPopup(const msg: {············}
{·} string; const wait: integer); {············}
{·} implementation {···························}
{·} procedure MsgPopup(const msg: {············}
{·} string; const wait: integer); {············}
{·} var {······································}
{·····} i,max: integer; {······················}
{·····} lbMsg:{}TLabel; {······················}
{·····} fmMsg:{·}TForm; {······················}
{·····} panel:{·}TRect; {······················}
{·} begin {····································}
{···} fmMsg := TForm.Create(nil); {············}
{···} try {····································}
{·····} with fmMsg do {························}
{·····} begin {································}
{·······} Width  := 350; {·····················}
{·······} Height := 110; {·····················}
{·······} Color := clWhite; {··················}
{·······} Caption:=' '+msg; {··················}
{·······} SystemParametersInfo {···············}
{·······} (48, 0, @panel,  0); {···············}
{·······} Top := panel.Bottom; {···············}
{·······} BorderStyle := bsToolWindow; {·······}
{·······} FormStyle{·}:=  fsStayOnTop; {·······}
{·······} lbMsg:=TLabel.Create(fmMsg); {·······}
{·······} Left := panel.Right-fmMsg.Width-2; {·}
{·······} max :=panel.Bottom-fmMsg.Height-2; {·}
{·······} with lbMsg do {······················}
{·······} begin {······························}
{·········} Top{}:= 30; {······················}
{·········} Left := 10; {······················}
{·········} Height:=30; {······················}
{·········} Parent {}:=fmMsg; {················}
{·········} AutoSize :=false; {················}
{·········} Caption{}:=  msg; {················}
{·········} Font.Size :={}14; {················}
{·········} Font.Name := 'Arial'; {············}
{·········} Font.Color{}:= clRed; {············}
{·········} Alignment:= taCenter; {············}
{·········} Font.Style:=[fsBold]; {············}
{·········} Width := fmMsg.Width; {············}
{·······} end ; {······························}
{·······} Show; {······························}
{·······} i := Top; {··························}
{·······} while(i>=max)do {····················}
{·······} begin {······························}
{·········} Top := i; {························}
{·········} Dec(i,2); {························}
{·········} Refresh ; {························}
{·······} end; {·······························}
{·····} end; {·································}
{···} finally {································}
{·····} Sleep(wait); {·························}
{·····} fmMsg.Free;; {·························}
{···} end; {···································}
{·} end; {·····································}
{.} end. {·····································}
{························ www.ClubDelphi.com ·····}
{··············································}

Ya.. :D Esto es que me llevo mal con el php de los trucos y siempre me espeta algo..
También Ya..:D
Eso es porque tú tienes :eek: tu enciclopedia :eek: privada en este lugar y sabes como buscar en ella.

Parece que de ese código falta la otra midad...
Si al código le aplicas mi función invertir, y juntas ambas mitades, tendrías un árbol de navidad o algo similar..:D

:D Eso también es verdad, utilizo el foro como mi repositorio particular. A veces creo que tengo mas código aquí que en mi disco duro :p

Truco: Cuando no encuentres algo, busca por Seoane :cool: :p :D

Hola,

Je, je, je... :D :D :D

Fuera de bromas... aquí la palabra seoane es mágica, a aunque ahora mismo se obtuvieran 1.867 respuestas por buscarla, seguramente que lo buscado aparecería...
Por cierto ¿Que farmacias hay de guardia hoy.?:D

Vuelvo a la carga con mi código inútil :D

Este que os traigo hoy, se puede considerar como uno de los mayores derroches de CPU de la historia. Se trata de ponerle fondo musical a nuestros programas utilizando el altavoz interno del PC. Solo hay que añadir la siguiente unit a un proyecto, y ella solita se encarga de reproducir la musica en un thread en segundo plano.

Código Delphi [-]
// **********************************************************
// Este código esta basado, y MUCHO, en este otro
// http : / / perso.wanadoo.es/plcl/speaker/playspkr.html
// En la misma pagina podéis encontrar otra canciones.
// **********************************************************
unit Beeper;

interface

uses Windows, SysUtils, Classes;

type
  // Esta la clase del thread que reproduce la cancion
  TBeeper = class(TThread)
  private
    procedure PlayString(Str: String);
    procedure PlayTone(Pitch, Value, Sustain: Integer) ;
  protected
    procedure Execute; override;
  public
    constructor Create; 
    destructor Destroy; override;
  end;

implementation

// Las siguinetes constantes y variables tienen que ver con "cosas" musicales,
// y como de musica no tengo ni idea, pues no se para que sirven.
var
  Octave: Integer;
  Whole: Integer;
  Value: Integer;
  Fill: Integer;
  Octtrack: Boolean;
  Octprefix: Boolean;

const
  HZ = 1000;

  SECS_PER_MIN = 60;
  WHOLE_NOTE = 4;
  MIN_VALUE  = 64;
  DFLT_VALUE = 4;
  FILLTIME = 8;
  STACCATO = 6;
  NORMAL = 7;
  LEGATO = 8;
  DFLT_OCTAVE  = 4;
  MIN_TEMPO  = 32;
  DFLT_TEMPO = 120;
  MAX_TEMPO  = 255;
  NUM_MULT  = 3;
  DENOM_MULT  = 2;
  Notetab: array ['A'..'G'] of Integer = (9, 11, 0, 2, 4, 5, 7);

  OCTAVE_NOTES = 12;
  Pitchtab: array[0..83] of Integer =
(
(*        C     C#    D     D#    E     F     F#    G     G#    A     A#    B*)
(* 0 *)   65,   69,   73,   78,   82,   87,   93,   98,  103,  110,  117,  123,
(* 1 *)  131,  139,  147,  156,  165,  175,  185,  196,  208,  220,  233,  247,
(* 2 *)  262,  277,  294,  311,  330,  349,  370,  392,  415,  440,  466,  494,
(* 3 *)  523,  554,  587,  622,  659,  698,  740,  784,  831,  880,  932,  988,
(* 4 *) 1047, 1109, 1175, 1245, 1319, 1397, 1480, 1568, 1661, 1760, 1865, 1975,
(* 5 *) 2093, 2217, 2349, 2489, 2637, 2794, 2960, 3136, 3322, 3520, 3729, 3951,
(* 6 *) 4186, 4435, 4698, 4978, 5274, 5588, 5920, 6272, 6644, 7040, 7459, 7902
);

  
  // Wish you a Merry Christmas
  Cancion = 'T160' +
            'd gL8gagf# L4ece' +
            'aL8abag L4f#df# bL8b>c< ba' +
            'L4ged8d8 eaf#g2d ggg' +
            'f#2f# gf#e d2a bL8aagg' +
            'L4>d< dd8d8 L4eaf#g1';

{ TBeeper }

// Creamos el trhead y inicializamos las variables
constructor TBeeper.Create;
begin
  inherited Create(FALSE);
  Octave:= DFLT_OCTAVE;
  Whole:= (HZ * SECS_PER_MIN * WHOLE_NOTE) div DFLT_TEMPO;
  Fill:= NORMAL;
  Value:= DFLT_VALUE;
  Octtrack:= FALSE;
  Octprefix:= TRUE;
end;

destructor TBeeper.Destroy;
begin
  inherited;
end;

// Reproducimos la cancion en un bucle hasta que el thread termina
procedure TBeeper.Execute;
begin
  inherited;
  while not Terminated do
  begin
     // Reproducir cancion
     PlayString(Cancion);
     // Hacer una pequeña pausa
     Sleep(200); // Pausa
  end;
end;

// Esta función devuelve el valor de un numero dentro de una cadena de texto.
// La variable i termina apuntando a la ultima cifra del numero.
function GetNum(Str: String; var i: Integer): Integer;
var
  j: Integer;
begin
  // Inicializamos el resultado
  Result:= 0;  
  while TryStrToInt(Copy(Str,i+1,1),j) do
  begin
    Result:= (Result * 10) + j;
    inc(i);
  end;
end;

// Esto reproduce la canción. Básicamente analiza la cadena y la convierte
// en tonos que se envían al altavoz. Otra vez "cosas" musicales, jeje
procedure TBeeper.PlayString(Str: String);
var
  Pitch, OldFill, LastPitch, i: Integer;
  Sustain, Timeval, Tempo: Integer;
begin
  LastPitch:= OCTAVE_NOTES * DFLT_OCTAVE;
  Str:= Uppercase(Str);
  i:= 1;
  while i <= Length(Str) do
  begin
    case Str[i] of
      'A'..'G': begin
        Pitch:= Notetab[Str[i]] + Octave * OCTAVE_NOTES;
        if (Copy(Str,i+1,1) = '#') or  (Copy(Str,i+1,1) = '+') then
        begin
          inc(Pitch);
          inc(i);
        end else if Copy(Str,i+1,1) = '-' then
        begin
          dec(Pitch);
          inc(i);
        end;
        if Octtrack and not Octprefix then
        begin
          if abs(Pitch-Lastpitch) > abs(Pitch+OCTAVE_NOTES-LastPitch) then
          begin
              inc(Octave);
              inc(Pitch,OCTAVE_NOTES);
          end;
          if abs(Pitch-Lastpitch) > abs((Pitch-OCTAVE_NOTES)-LastPitch) then
          begin
              dec(Octave);
              dec(Pitch,OCTAVE_NOTES);
          end;
        end;
        Octprefix:= FALSE;
        LastPitch:= Pitch;
        Timeval:= GetNum(Str,i);
        if (Timeval <= 0) or (Timeval > MIN_VALUE) then
          Timeval:= Value;
        Sustain:= 0;
        while Copy(Str,i+1,1) = '.' do
        begin
          inc(Sustain);
          inc(i);
        end;
        Oldfill:= Fill;
        if Copy(Str,i+1,1) = '_' then
        begin
          Fill:= LEGATO;
          inc(i);
        end;
        Playtone(Pitch, Timeval, Sustain);
        Fill:= OldFill;
      end;
      'O': begin
        if Copy(Str,i+1,1) = 'N' then
        begin
          Octprefix:= FALSE;
          Octtrack:= FALSE;
          inc(i);
        end else if Copy(Str,i+1,1) = 'L' then
        begin
          Octtrack:= TRUE;
          inc(i);
        end else
        begin
          Octave:= GetNum(Str,i);
          if Octave >= (High(Pitchtab) div OCTAVE_NOTES) then
            Octave:= DFLT_OCTAVE;
          Octprefix:= TRUE;
        end;
      end;
      '>': begin
        if (Octave < (High(Pitchtab) div OCTAVE_NOTES) - 1) then
          inc(Octave);
          Octprefix:= TRUE;
        end;
      '<': begin
          if (Octave > 0) then
            dec(Octave);
          Octprefix:= TRUE;
      end;
      'N': begin
        Pitch:= GetNum(Str,i);
        Sustain:= 0;
        while Copy(Str,i+1,1) = '.' do
        begin
          inc(i);
          inc(Sustain);
        end;
        Oldfill:= Fill;
        if Copy(Str,i+1,1) = '_' then
        begin
          Fill:= LEGATO;
          inc(i);
        end;
        Playtone(Pitch - 1, Value, Sustain);
        Fill:= OldFill;
      end;
      'L': begin
        Value:= GetNum(Str,i);
        if (Value <= 0) or (Value > MIN_VALUE) then
          Value:= DFLT_VALUE;
      end;
      'P','~': begin
        Timeval:= Getnum(Str,i);
        if (Timeval <= 0) or (Timeval > MIN_VALUE) then
          Timeval:= Value;
        Sustain:= 0;
        while Copy(Str,i+1,1) = '.' do
        begin
          inc(i);
          inc(Sustain);
        end;
        PlayTone(-1, Timeval, Sustain);
      end;
      'T': begin
        Tempo:= GetNum(Str,i);
        if (Tempo < MIN_TEMPO) or (Tempo > MAX_TEMPO) then
          Tempo:= DFLT_TEMPO;
        Whole:= (HZ * SECS_PER_MIN * WHOLE_NOTE) div tempo;
      end;
      'M': begin
         if Copy(Str,i+1,1) = 'N' then
          begin
            Fill:= NORMAL;
            inc(i);
          end else if Copy(Str,i+1,1) = 'L' then
          begin
            Fill:= LEGATO;
            inc(i);
          end else if Copy(Str,i+1,1) = 'S' then
          begin
            Fill:= STACCATO;
            inc(i);
          end;
      end;
    end;
    inc(i);
  end;
end;

// Esta funcion envia un tono al altavoz
procedure TBeeper.PlayTone(Pitch, Value, Sustain: Integer);
var
  Sound, Silence, Snum, Sdenom: Integer;
begin
  Snum:= 1;
  Sdenom:= 1;
  while Sustain > 0 do
  begin
    Snum:= Snum * NUM_MULT;
    Sdenom:= Sdenom * DENOM_MULT;
    dec(Sustain);
  end;
  if Pitch = -1 then
    Sleep(Whole * Snum div (Value * Sdenom))
  else begin
    Sound:= (Whole * Snum) div (Value * Sdenom)
          - (Whole * (FILLTIME - Fill)) div (Value * FILLTIME);
    Silence:= Whole * (FILLTIME - Fill) * Snum div (FILLTIME * Value * Sdenom);
  Windows.Beep(Pitchtab[Pitch],Sound);
  if Fill <> LEGATO then
    Sleep(Silence);
  end;
end;

// Aqui creamos el thread al cargarse la unidad
initialization
  with TBeeper.Create do
    // Le indicamos que se destruya al terminarr
    FreeOnTerminate:= TRUE;
finalization

end.

El código es una adaptación a Delphi del encontrado aquí:
http://perso.wanadoo.es/plcl/speaker/playspkr.html

Código Delphi [-]
Begin      
      ShowMessage('Hello World '); 
end;

Perdon, era muy tentador hacer esto....
Muy buena la idea loco... :D

Lo siento, pero esto me produce un error...
Project1 ya existe... alguna solución.. ?:)

Vaya pues, he querido participar en este hilo pero me he encontrado con un detalle, necesito espacio para postear todos mis proyectos, todos son inutiles....:rolleyes:

Saludos.