Analitcs

Pesquisar no conteúdo do blog.atlabs.com.br

quarta-feira, 5 de dezembro de 2012

DELPHI - Trabalhando com Cookies - WebBroker - CGI/ISAP Delphi

Reações: 


Function SetCookieByName(Response : TWebResponse; Request: TWebRequest; CookieName, CookieValue: string) : Boolean;
var
  i : Integer;
  S : String;
begin
  Result := False;
  try
    with Response.Cookies.Add do
    begin
      Expires := IncDay(Now, 1);
      Path := Request.URL;
      Secure := False;
      Name := CookieName;
      Value := CookieValue;
    end;
   // Passa por aqui para não ficar declarando campos do tipo hidden dentro do html
  // no lugar de setar somente o valor para o response, passa também para o request.
    for I := 0 to Request.CookieFields.Count - 1 do
    begin
      S := Request.CookieFields.Strings[i];
      S := Copy(S, 1, Pos('=', S) - 1);
      if UpperCase(S) = UpperCase(CookieName) then
      begin
        Request.CookieFields.Delete(i);
        Break;
      end;
    end;
    Request.CookieFields.Add(CookieName + '=' + CookieValue);
    Result := True;
  except
    Result := False;
  end; 
//----------------------------------------
end;

Function GetCookieByName(Request: TWebRequest; CookieName: String) : String;
var
  i : Integer;
  S : String;
begin
  try
  Result := '';
  for i := 0 to Request.CookieFields.Count -1 do
  begin
    S := Request.CookieFields.Strings[i];
    S := Copy(S, 1, Pos('=', S) - 1);
    if S = CookieName then
    begin
      S := Request.CookieFields.Strings[i];
      Result := Copy(S, Pos('=', S) + 1, Length(S));
      Break;
    end;
  end;
  Finally
  end;
end;

sexta-feira, 23 de novembro de 2012

DELPHI - Calculando e Verificando Hash - Message Digest 5 (MD5)

Reações: 


// Uses IdHashMessageDigest, idHash;

function GetHash (const Value : string) : string;
// Uses IdHashMessageDigest, idHash;
 var
   idMD5 : IdHashMessageDigest.TIdHashMessageDigest5;
begin
  idMD5 := TIdHashMessageDigest5.Create;
  try
    result := idMD5.AsHex(idMD5.HashValue(Value)) ;
  finally
    FreeAndNil(idMD5);
  end;
end;

function VerifyHash (const Value, Hash : string) : Boolean;
// Uses IdHashMessageDigest, idHash;
begin
  Result := Hash = GetHash(Value) ;
end;
/// Função para Indy 10 e DelphiXE3 - Funcionamento testado

function GetHash (const Value : string) : string;
// Uses IdHashMessageDigest, idHash;
 var
   idMD5 : IdHashMessageDigest.TIdHashMessageDigest5;
begin
  idMD5 := TIdHashMessageDigest5.Create;
  try
    result := TIdHash(idMD5).HashStringAsHex(Value);
  finally
    FreeAndNil(idMD5);
  end;
end; 

sábado, 17 de novembro de 2012

DELPHI - Utilizando Funções de Retorno de TabOrder

Reações: 


function TForm1.ValidaItens: Boolean;
var
  i, j, iMaxTabOrder : integer;
  wcObj : TWinControl;
Function IsValidDate(DT : String) : Boolean;
var
  X : TDateTime;
begin
  Result := False;
  try
    X := StrToDateTime(DT);
    Result := True;
  except
    Result := False;
  end;
end;
  Function GetCaptionItem(Tag : Integer) : String;
  var
    X : Integer;
  begin
    for X := 0 to pnlBackItensCliente.ControlCount -1 do
    begin
      if (pnlBackItensCliente.Controls[x] is TLabel) and (Tag = TLabel(pnlBackItensCliente.Controls[x]).Tag) then
      begin
        Result := TLabel(pnlBackItensCliente.Controls[x]).Caption;
        Break;
      end;
    end;
  end;
  Procedure ShowMessageBox(Item : TWinControl);
  begin
    MessageBox(Handle, PChar('O campo "' + GetCaptionItem(Item.Tag) + '" não pode ser nulo. Verifique.'), 'Erro de validação de campo', MB_OK + MB_ICONERROR );
    Item.SetFocus;
  end;
begin
  Result := False;
  iMaxTabOrder := MaxTaborder(pnlBackItensCliente);
  for J := 0 to iMaxTabOrder -1 do
  begin
    wcObj := GetObjectTabOrder(J, pnlBackItensCliente);
    if (wcObj <> nil) and (wcObj is TDBEdit) and (Trim(TDBEdit(wcObj).Text) = '') then
    begin
      ShowMessageBox(wcObj);
      exit;
    end;
    if (wcObj <> nil) and (wcObj is TDBComboBox) and (TDBComboBox(wcObj).ItemIndex = -1) then
    begin
      ShowMessageBox(wcObj);
      exit;
    end;
  end;
  if (not IsValidDate(DBEdit14.Text)) then // DBedit com campo data
  begin
    ShowMessageBox(TWinControl(DBEdit14));
    exit;
  end;
  Result := True;
end;

DELPHI - Retornar Objeto via valor de TabOrder

Reações: 

Function GetObjectTabOrder(TabOrder : Integer; Obj : TWinControl) : TWinControl;
var
  k : integer;
begin
  Result := Nil;
  for K := 0 to Obj.ControlCount -1 do
  begin
    if TWinControl(Obj.Controls[k]).TabOrder = TabOrder then
    begin
      Result := TWinControl(Obj.Controls[k]);
      Break;
    end;
  end;
end;

DELPHI - Retornar Maior TabOrder de Controls

Reações: 
Function MaxTaborder(Obj : TWinControl) : Integer;
var
  k : integer;
begin
  Result := 0;
  for K := 0 to Obj.ControlCount -1 do
  begin
    if TWinControl(Obj.Controls[k]).TabOrder > Result then
    Result := TWinControl(Obj.Controls[k]).TabOrder;
  end;
end;

terça-feira, 13 de novembro de 2012

DELPHI - Página de treinamentos da Embarcadero do Brasil

Reações: 
A Embarcadero do Brasil, lançou em seu evento Delphi Conference 2012, realizado em São Paulo, o site oficial de Treinamentos e Vagas para profissionais do ramo, segue abaixo o Link:

http://www.edobrasil.net/treinamentos/

segunda-feira, 5 de novembro de 2012

DELPHI - Atualizações RAD XE3 - Vale apena conferir

Reações: 
http://now.eloqua.com/es.asp?s=608&e=741069&elq=ab7bf27acb804566a0919b3bb72251b9


Acesse o link acima para visualização das novidades do RAD XE3

"Delphi Linguagem Morta"???

Compilando para o ambiente visual do Windows 8, lançado 2 dias antes do lançamento Mundial da Microsoft.


Quem diz isso não entende de tecnologia!!


quarta-feira, 31 de outubro de 2012

DELPHI - Retornando Texto com valores separados por caractere delimitador (CommaText)

Reações: 
Function GetCommaText(S, Delimiter : String; ColumnIndex : Integer) : String;
var
  StrL : TStringList;
begin
  StrL := TStringList.Create;
  try
    StrL.Text := StringReplace(S, Delimiter, #13#10, [rfReplaceAll, rfIgnoreCase]);
      if StrL.Count <= ColumnIndex then
      Result    := ''
      else
      Result    := StrL.Strings[ColumnIndex];
  finally
    FreeAndNil(StrL);
  end;
end;

(* Usando a função

 Adicionar 3 Edits com os nomes de EdtV1, EdtV2, EdtV3 e um botão, com o evento de onclick conforme abaixo*)

procedure TForm1.Button1Click(Sender: TObject);
Const
  S = 'TextoColuna1;TextoColuna2   ;   TextoColuna3';
begin
  EdtV1.Text := GetCommaText(S, ';', 0);
  EdtV2.Text := GetCommaText(S, ';', 1);
  EdtV3.Text := GetCommaText(S, ';', 2);
end;

segunda-feira, 15 de outubro de 2012

DELPHI - Função de String para Hexadecimal / Hexadecimal para String

Reações: 
function StringToHex (S : string) : string;
var
  Str : String;
  i   : Integer;
begin
  for I := 0 to Length(S) - 1 do
  begin
    Str := Str + IntToHex(Ord(S[I + 1]), 2) + ' ';
  end;
  Delete(Str, Length(Str), 1);
  Result := Str;
end;

function HexToString(S : string) : string;
var
  Str : String;
  i   : Integer;
begin
  I := 1;
  while I <= Length(S) do
  begin
    Str := Str + Char(StrToInt('$' + Copy(S, I, 2)));
    I := I + 3;
  end;
  Result := Str;
end;

sábado, 6 de outubro de 2012

WINDOWS - Ferramenta de Listagem de Processos - Process Explorer

Reações: 
Ferramenta de Exibição Detalhada de Processos do Windows - 100% Free!!!!

Mais Informações:
http://technet.microsoft.com/en-us/sysinternals/bb896653.aspx


Download:
http://download.sysinternals.com/files/ProcessExplorer.zip


Download Direto do Blog (esses caras tem mania de tirar o download do ar, ou cobrar pela ferramenta quando de torna famosa)
http://www.atlabs.com.br/blog/download/ProcessExplorer.zip

GERAL - Obrigado a todos!

Reações: 
Obrigado a todos os que acessaram e utilizaram-se dos códigos fonte...


Espero ter ajudado, e espero postar e ajudar cada dia mais pessoas... Abraços!!!

WINDOWS - Windows 7 - Desativar e Excluir Arquivo de Hibernação - Hiberfil.sys

Reações: 
Na instalação do windows seven a hibernação fica ativada como padrão e quando é desativada no painel de controle o arquivo hiberfil.sys que é gerado quando está ativado não é excluído. O problema que o arquivo tem o mesmo tamanho da quantidade de ram e é um espaço ocupado desnecessário. Para desativar é simples:

1– Menu iniciar
2 – CMD
3 – Rodar como administrador
4 – digite o comando e dê enter: POWERCFG -H OFF
Simples e fácil, Agora ficará desativada a hibernação e o arquivo será excluído e você tera 3GB mais livre no seu HD.


Retirado do Site:
http://infornews.org/2010/03/windows-7-%E2%80%93-desativar-excluir-arquivo-de-hibernacao-hiberfil-sys/

quinta-feira, 4 de outubro de 2012

DELPHI - Função - Copiar até o 1º Espaço da String

Reações: 
// Função - Copiar até o 1º Espaço da String
  Function CopiaAteEspaco(S : String) : String;
  var
    L : Integer;
  begin
    L := Pos(' ', S);
    if L <= 0 then // Caso não haja espaço
      L := MaxInt; // Iguala a Variavel ao Maior Inteiro Definido Pelo Sistema
    Result := Copy(S, 1, L - 1);
  end;

WINDOWS - Process Explorer - Ferramenta Microsoft de Analise de Processos

Reações: 
http://technet.microsoft.com/en-us/sysinternals/bb896653.aspx

quarta-feira, 3 de outubro de 2012

DELPHI - Teste de Conexão - TCP Port - Indy 10

Reações: 
// Procurei na internet e não achei

//Segue abaixo:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls

  , IdBaseComponent, IdComponent // Units Base
  , IdTCPConnection, IdTCPClient // Unit TCP Client
  ;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    Function TestPortTCP(Host : String; Port : Word; Timeout : Integer = 3000) : Boolean;
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

// FUNÇÃO DE CONEXÂO DE PORTA - TCP PORT TEST DELPHI - Indy 10

function TForm1.TestPortTCP_ATLABS(Host: String; Port: Word;
  Timeout: Integer): Boolean;
var
  IdTCPClient: TIdTCPClient;
begin
  try
    Result := False;
    IdTCPClient := TIdTCPClient.Create(Nil);
    IdTCPClient.ReadTimeout := Timeout;
    IdTCPClient.Host := Host;
    IdTCPClient.Port := Port;
    try
    IdTCPClient.Connect;
    except
      IdTCPClient.Disconnect;
      Result := False;
      Exit;
    end;
    IdTCPClient.Disconnect;
    Result := True; // Passou pela conexão
  finally
    FreeAndNil(IdTCPClient);
  end;
end;
 

// TESTANDO!!!!
procedure TForm1.Button1Click(Sender: TObject);
begin
  if TestPortTCP_ATLABS('localhost', 80, 1000) then
  ShowMessage('OK')
  Else
  ShowMessage('Erro');
end;

end.


//ACONSELHO FORÇAR O TESTE COM UMA PORTA Q N ESTEJA ABERTA: 65535 por EX.

segunda-feira, 1 de outubro de 2012

DELPHI - Função de Preenchimento de Caractere Direita

Reações: 
Function PreencheCaracDir(Str, Carac :String; Qtd : Integer) : String;
var
  i : Integer;
  S : String;
begin
  Carac := Carac[1]; // Pega somente o primeiro caractere enviado
  Result := Str;
  if Length(Str) = Qtd then
    Exit;
  if Length(Str) > Qtd then
  begin
    Result := Copy(Str, 1, Qtd);
    Exit;
  end;
  For I := 1 to Qtd do
  begin
    S := S + Carac;
    if Length(S + Str) = Qtd then
    begin
      Result := Str +S;
      Break;
    End;
  end;
end;

//Uso:

Edit1.Text := PreencheCaracDir(Edit1.Text, '0', 14);

DELPHI - Retirando Caracteres a Direita

Reações: 
function TrimCaracRight(Carac: String;const S: string): string;
var
  I: Integer;
begin
  I := Length(S);
  while (I > 0) and (S[I] <= Carac) do Dec(I);
  Result := Copy(S, 1, I);
end;

DELPHI - Retirarndo Caracteres a Esquerda

Reações: 
function TrimCaracLeft(Carac: String; const S: string): string;
var
  I, L: Integer;
begin
  Carac := Carac[1];
  L := Length(S);
  I := 1;
  while (I <= L) and (S[I] <= Carac) do Inc(I);
  Result := Copy(S, I, Maxint);
end;

DELPHI - Função de Preenchimento de Caractere Esquerda

Reações: 
Function PreencheCaracEsq(Str, Carac :String; Qtd : Integer) : String;
var
  i : Integer;
  S : String;
begin
  Carac := Carac[1]; // Pega somente o primeiro caractere enviado
  Result := Str;
  if Length(Str) = Qtd then
    Exit;
  if Length(Str) > Qtd then
  begin
    Result := Copy(Str, 1, Qtd);
    Exit;
  end;
  For I := 1 to Qtd do
  begin
    S := S + Carac;
    if Length(S + Str) = Qtd then
    begin
      Result := S + Str;
      Break;
    End;
  end;
end;

//Uso:

Edit1.Text := PreencheCaracEsq(Edit1.Text, '0', 14);

DELPHI - Validação CNPJ

Reações: 
// Adequada a função de CPF

Function ValidacaoCNPJ(CNPJ:string):boolean;
var
  I               : integer;
  Want            : char;
  Wvalid          : boolean;
  Wdigit1,Wdigit2 : integer;
  Function StrNumber(S : String) : String;
  var
    X : Integer;
  begin
    Result := '';
    For X := 1 To Length(S) do
    begin
      Case Char(S[X]) of
        '0'..'9' : Result := Result + S[X];
      End;
    end;
  end;
begin
  Wdigit1 := 0;
  Wdigit2 := 0;
  Want    := CNPJ[1];//variavel para testar se o CNPJ é repetido como 111.111.111-11
  CNPJ := StrNumber(CNPJ); // Limpa o que não for numero
  if Length(CNPJ) < 14 then
  begin
    Result := False;
    exit;
  end;
  //testar se o CNPJ é repetido como 111.111.111-11
  for I := 1 to length(CNPJ) do
  begin
    if CNPJ[i] <> Want then
    begin
      Wvalid := True;  // se o CNPJ possui um digito diferente ele passou no primeiro teste
      Break;
    end;
  end;
  // se o CNPJ é composto por numeros repetido retorna falso
  if not Wvalid then
  begin
    Result := False;
    Exit;
  end;
  //executa o calculo para o primeiro verificador
  for i := 1 to 12 do
  begin
    if I+1 <= 9 then
      Wdigit1 := Wdigit1 + (StrToInt(CNPJ[13-i])*(I+1))
    else
    if I+1 > 9 then
      Wdigit1 := Wdigit1 + (StrToInt(CNPJ[13-i])*(I-7));
  end;
  Wdigit1:= 11 - (Wdigit1 mod 11);
  if Wdigit1 >= 10 then Wdigit1 := 0;
  //verifica se o 1° digito confere
  if IntToStr(Wdigit1) <> CNPJ[13] then
  begin
    Result := false;
    Exit;
  end;
  Wdigit2 := Wdigit1 * 2;
  for i := 1 to 12 do
  begin
    if I <= 7 then
      Wdigit2 := Wdigit2 + (StrToInt(CNPJ[13-i])*(I+2))
    else
    if I > 7 then
      Wdigit2 := Wdigit2 + (StrToInt(CNPJ[13-i])*(I-6));
  end;
  Wdigit2 := 11 - (Wdigit2 mod 11);
  if Wdigit2 >= 10 then Wdigit2 := 0;
  // confere o 2° digito verificador
  if IntToStr(Wdigit2) <> CNPJ[14] then
  begin
    Result := False;
    Exit;
  end;
  //se chegar até aqui o CNPJ é valido
  Result := True;
end;


// Usando:
  if ValidacaoCNPJ(Edit1.Text) then
    ShowMessage('Válido')
  else
    ShowMessage('Invalido');

DELPHI - Validação CPF

Reações: 
//Retirei do planeta delphi, identei e criei função de limpeza de caracteres:

Function ValidacaoCPF(CPF:string):boolean;
var
  I               : integer;
  Want            : char;
  Wvalid          : boolean;
  Wdigit1,Wdigit2 : integer;
  Function StrNumber(S : String) : String;
  var
    X : Integer;
  begin
    Result := '';
    For X := 1 To Length(S) do
    begin
      Case Char(S[X]) of
        '0'..'9' : Result := Result + S[X];
      End;
    end;
  end;
begin
  Wdigit1 := 0;
  Wdigit2 := 0;
  Want    := CPF[1];//variavel para testar se o cpf é repetido como 111.111.111-11
  CPF := StrNumber(CPF); // Limpa o que não for numero
  if Length(CPF) < 11 then
  begin
    Result := False;
    exit;
  end;
  //testar se o cpf é repetido como 111.111.111-11
  for I := 1 to length(CPF) do
  begin
    if CPF[i] <> Want then
    begin
      Wvalid := True;  // se o cpf possui um digito diferente ele passou no primeiro teste
      Break;
    end;
  end;
  // se o CPF é composto por numeros repetido retorna falso
  if not Wvalid then
  begin
    Result := False;
    Exit;
  end;
  //executa o calculo para o primeiro verificador
  for i := 1 to 9 do
  begin
    Wdigit1 := Wdigit1 + (StrToInt(CPF[10-i])*(I+1));
  end;
  {formula do primeiro verificador
  soma=1°*2+2°*3+3°*4.. até 9°*10
  digito1 = 11 - soma mod 11
  se digito > 10 digito1 =0}
  Wdigit1:= ((11 - (Wdigit1 mod 11))mod 11) mod 10;
  //verifica se o 1° digito confere
  if IntToStr(Wdigit1) <> CPF[10] then
  begin
    Result := false;
    Exit;
  end;
  for i:=1 to 10 do
  begin
    Wdigit2 := Wdigit2 + (StrToInt(CPF[11-i])*(I+1));
  end;
  {formula do segundo verificador
  soma=1°*2+2°*3+3°*4.. até 10°*11
  digito1 = 11 - soma mod 11
  se digito > 10 digito1 =0}
  Wdigit2 := ((11 - (Wdigit2 mod 11))mod 11) mod 10;
  // confere o 2° digito verificador
  if IntToStr(Wdigit2) <> CPF[11] then
  begin
    Result := False;
    Exit;
  end;
  //se chegar até aqui o CPF é valido
  Result := True;end;
// Usando:
procedure TForm1.Button1Click(Sender: TObject);
begin
  if ValidacaoCPF(Edit1.Text) then
    ShowMessage('Válido')
  else
    ShowMessage('Invalido');
end;

sexta-feira, 28 de setembro de 2012

DELPHI - Função igual a LowerCase Retornando Tipo Char

Reações: 
function  LowCase( ch : Char ) : Char;
begin
  Result := ch;
  case Result of
    'A'..'Z':  Dec(Result, Ord('A') - Ord('a'));
  end;
end;

DELPHI - Validando Teclas Digitadas

Reações: 
Function KeyControls(Key : Char) : Boolean;
begin
  Result := False;
  case Key of
    #13 : Result := True; // Enter
    #27 : Result := True; // Escape
    #8  : Result := True; // BackSpace
    #9  : Result := True; // Tab
  end;
end;
Function KeyNumber(Key : Char) : Char;
begin
  if not KeyControls(Key) then
    case key of
      '0'..'9' : Result := Key;
      Else
      Result := #0;
    end;
end;

Function KeyNumberFloat(Key : Char) : Char;
begin
  if not KeyControls(Key) then
    case key of
      '.' : Result := Key;
      ',' : Result := Key;
      Else
      Result := #0;
    end;
end;

function  LowCase( ch : Char ) : Char;
begin
  Result := ch;
  case Result of
    'A'..'Z':  Dec(Result, Ord('A') - Ord('a'));
  end;
end;

Function KeyAZ(Key : Char; CharCase: TEditCharCase) : Char;
begin
  //CharCase in ecNormal, ecUpperCase, ecLowerCase
  Result := Key;
  if not KeyControls(Key) then
  begin
    case key of
      ' ' : Result := Key;
      'A'..'Z' : begin
                   If CharCase = ecLowerCase then
                     Result := LowCase(Key)
                   Else
                   If CharCase = ecUpperCase then
                     Result := UpCase(Key)
                   Else
                     Result := Key;
                 end;
      'a'..'z' : begin
                   If CharCase = ecLowerCase then
                     Result := LowCase(Key)
                   Else
                   If CharCase = ecUpperCase then
                     Result := UpCase(Key)
                   Else
                     Result := Key;
                 end;
       else
       Result := #0;
    end;
  end;
end;


Function KeyAZNumber(Key : Char; CharCase: TEditCharCase) : Char;
begin
  //CharCase in ecNormal, ecUpperCase, ecLowerCase
  Result := Key;
  if not KeyControls(Key) then
  begin
    case key of
      ' '      : Result := Key;
      '0'..'9' : Result := Key;
      'A'..'Z' : begin
                   If CharCase = ecLowerCase then
                     Result := LowCase(Key)
                   Else
                   If CharCase = ecUpperCase then
                     Result := UpCase(Key)
                   Else
                     Result := Key;
                 end;
      'a'..'z' : begin
                   If CharCase = ecLowerCase then
                     Result := LowCase(Key)
                   Else
                   If CharCase = ecUpperCase then
                     Result := UpCase(Key)
                   Else
                     Result := Key;
                 end;
       else
       Result := #0;
    end;
  end;
end;


Function KeyAZNumberFloat(Key : Char; CharCase: TEditCharCase = ecNormal) : Char;
begin
  //CharCase in ecNormal, ecUpperCase, ecLowerCase
  Result := Key;
  if not KeyControls(Key) then
  begin
    case key of
           ' ' : Result := Key;
      '0'..'9' : Result := Key;
      '.' : Result := Key;
      ',' : Result := Key;
      'A'..'Z' : begin
                   If CharCase = ecLowerCase then
                     Result := LowCase(Key)
                   Else
                   If CharCase = ecUpperCase then
                     Result := UpCase(Key)
                   Else
                     Result := Key;
                 end;
      'a'..'z' : begin
                   If CharCase = ecLowerCase then
                     Result := LowCase(Key)
                   Else
                   If CharCase = ecUpperCase then
                     Result := UpCase(Key)
                   Else
                     Result := Key;
                 end;
       else
       Result := #0;
    end;
  end;
end;

// Utilizando:

procedure TForm1.Edit1KeyPress(Sender: TObject;
  var Key: Char);
begin
  key := KeyNumber(Key); // retorna somente numeros digitados
end;

procedure TForm1.Edit2KeyPress(Sender: TObject;
  var Key: Char);
begin
  key := KeyNumberFloat(Key); // retorna numeros com opção de ponto flutuante (ponto ou virgula)
end;

procedure TForm1.Edit3KeyPress(Sender: TObject;
  var Key: Char);
begin
  key := KeyAZ(Key,ecUpperCase); // Retorna Letras de A a Z (caso precise de maiuscula/Minuscula/Normal troque o parametro da função)
end;

procedure TForm1.Edit4KeyPress(Sender: TObject;
  var Key: Char);
begin
  key := KeyAZNumber(Key,ecUpperCase); // retorna Alfanumerico (caso precise de maiuscula/Minuscula/Normal troque o parametro da função)
end;

procedure TForm1.Edit5KeyPress(Sender: TObject;
  var Key: Char);
begin
  key := KeyAZNumberFloat(Key,ecUpperCase); // retorna Alfanumerico ou numeros ou ponto ou virgula, (caso precise de maiuscula/Minuscula/Normal troque o parametro da função)
end;

segunda-feira, 24 de setembro de 2012

DELPHI - Versões do Delphi

Reações: 

Versões do delphi para Diretivas e afins

  • SYMBOL - COMPILER VERSION
  • VER80 - Delphi 1
  • VER90 - Delphi 2
  • VER100 - Delphi 3
  • VER120 - Delphi 4
  • VER130 - Delphi 5
  • VER140 - Delphi 6
  • VER150 - Delphi 7
  • VER160 - Delphi 8
  • VER170 - Delphi 2005
  • VER180 - Delphi 2006
  • VER180 - Delphi 2007
  • VER185 - Delphi 2007
  • VER200 - Delphi 2009
  • VER210 - Delphi 2010
  • VER220 - Delphi XE
  • VER230 - Delphi XE2
  • WIN32 - Indicates that the operating environment is the Win32 API.
  • LINUX - Indicates that the operating environment is Linux
  • MSWINDOWS - Indicates that the operating environment is the MS Windows/li]
  • CONSOLE - Indicates that an application is being compiled as a console application
  • segunda-feira, 10 de setembro de 2012

    DELPHI - Desenhando circulos (Quadrados, Retangulos, Elipses) em TImage

    Reações: 
     Coloque uma imagem qualquer no conteúdo do componente Image1.Picture, não subi no exemplo para não estender a dica aqui no blog. No demo tem uma imagem dos pinguins demo do W7
    Link do demo
    http://www.atlabs.com.br/blog/download/DesenhaCirculos.rar
    ///////////////UNIT1.pas
    unit Unit1;
    
    interface
    
    uses
      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
      Dialogs, ExtCtrls, jpeg, StdCtrls;
    
    type
    
      TfrmPosicaoTela = class(TForm)
        Image1: TImage;
        Shape1: TShape;
        SaveDialog1: TSaveDialog;
        ckbTransparente: TCheckBox;
        procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
          Shift: TShiftState; X, Y: Integer);
        procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
          Y: Integer);
        procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
          Shift: TShiftState; X, Y: Integer);
        procedure ckbTransparenteClick(Sender: TObject);
      private
        _start, _end: TPoint;
        _Desenhando : Boolean;
        procedure CopyCanvas;
        { Private declarations }
      public
        { Public declarations }
      end;
    
    var
      frmPosicaoTela: TfrmPosicaoTela;
    
    implementation
    
    {$R *.dfm}
    
    procedure TfrmPosicaoTela.CopyCanvas;
    var
      DC: HDC;
      Image: TBitmap;
    begin
      DC:= GetDC(GetDesktopWindow);
      try
        Image := TBitmap.Create;
        Image.Width   := Image1.Width;
        Image.Height  := Image1.Height;
        BitBlt(Image.Canvas.Handle, 0,0, Image.Width, Image.Height, DC, Image1.ClientOrigin.X, Image1.ClientOrigin.Y, SRCCOPY);
        SaveDialog1.InitialDir := 'C:\';
        SaveDialog1.FileName   := 'ImagemAlterada' + FormatDateTime('ddMMyyyyHHmmss', now) + '.bmp';
        if SaveDialog1.Execute then
        begin
          Image.SaveToFile(SaveDialog1.FileName);
        end;
      finally
        FreeAndNil(Image);
        ReleaseDC(GetDesktopWindow, DC);
      end;
    end;
    
    procedure TfrmPosicaoTela.Image1MouseDown(Sender: TObject;
      Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    begin
      self._start.X := X;
      self._start.Y := Y;
      self.Shape1.Width := 0;
      self.Shape1.Height:= 0;
      self.Shape1.Left  := X;
      self.Shape1.Top   := Y;
      self.Shape1.Show;
      self.Shape1.Update;
      _Desenhando := True;
    end;
    
    
    procedure TfrmPosicaoTela.Image1MouseMove(Sender: TObject;
      Shift: TShiftState; X, Y: Integer);
    begin
      if _Desenhando then
      begin
        self.Shape1.Width := X - self._start.X;
        self.Shape1.Height:= Y - self._start.Y;
      end;
    end;
    
    procedure TfrmPosicaoTela.Image1MouseUp(Sender: TObject;
      Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    begin
      try
        CopyCanvas;
      finally
        _Desenhando := False;
        self.Shape1.Hide;
      end;
    end;
    
    procedure TfrmPosicaoTela.ckbTransparenteClick(Sender: TObject);
    begin
      if ckbTransparente.Checked then
      Shape1.Brush.Style := bsClear;
    end;
    end.
    ///////////////UNIT1.pas
    
    
    ///////////////UNIT1.dfm
    object frmPosicaoTela: TfrmPosicaoTela
      Left = 414
      Top = 163
      BorderStyle = bsSingle
      ClientHeight = 769
      ClientWidth = 1025
      Color = clBtnFace
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -11
      Font.Name = 'MS Sans Serif'
      Font.Style = []
      OldCreateOrder = False
      Position = poDesktopCenter
      PixelsPerInch = 96
      TextHeight = 13
      object Image1: TImage
        Left = 0
        Top = 0
        Width = 1025
        Height = 769
        Align = alClient
        OnMouseDown = Image1MouseDown
        OnMouseMove = Image1MouseMove
        OnMouseUp = Image1MouseUp
      end
      object Shape1: TShape
        Left = 42
        Top = 84
        Width = 137
        Height = 94
        Brush.Color = clRed
        Pen.Color = clRed
        Shape = stEllipse
        Visible = False
      end
      object ckbTransparente: TCheckBox
        Left = 0
        Top = 0
        Width = 97
        Height = 17
        Caption = 'Transparente'
        TabOrder = 0
        OnClick = ckbTransparenteClick
      end
      object SaveDialog1: TSaveDialog
        Left = 525
        Top = 69
      end
    end
    ///////////////UNIT1.dfm
    

    quarta-feira, 29 de agosto de 2012

    GERAL - Adobe Reader - URL Download offline - Instalações completas

    Reações: 
    ftp://ftp.adobe.com/pub/adobe/reader/win/10.x/10.1.0/pt_BR/

    Este é o diretório atual da versão na data desta postagem em português do Brasil.

    Caso precise navegue nos diretórios.

    quarta-feira, 8 de agosto de 2012

    DELPHI - Inicializar aplicação com parâmetros

    Reações: 
    //Caso a execução da sua aplicação contenha parâmetros (ParamStr(Integer), ex: ParamStr(1) = '/param') você pode depura-la no editor do delphi informando este parametro no menu "Run>Parameters[Combo Parameters]".
    
    //Esta dica vale também para criar associações do seu programa com algum tipo de arquivo, por exemplo: vc cria um editor de texto e quer associar a extensão *.txt a ele, vc deve configurar no windows seu programa com a extensão na tela: Ferramentas>Opções de Pasta> Guia Tipos de Arquivos   ou crie a associação com o botão direito do mouse sobre o arquivo com a extensão escolhida, para a associação via programação, consulte as classes do windows no registro (regedit.exe)
    //no evento OnCreate do editor do texto você coloca o seguinte comando:
    
    var
     i : integer
    begin
      if FileExists(ParamStr(1)) then
      // Cria a execução que vc precisar, OU
      for i := 1 to ParamCount -1 do // usando um looping para pegar os parâmetros
        if FileExists(ParamStr(1)) then
        // Cria a execução que vc precisar
    //Atte.
    //Felipe Leal
    

    terça-feira, 7 de agosto de 2012

    DELPHI - Listando formulários abertos da aplicação

    Reações: 
    //Adicionar um memo em uma aplicação nova, e um botão, no evento do botão Onclick adicionar:
    var
      i : integer;
    begin
      Memo1.Lines.Clear;
      for i := 0 to Screen.FormCount -1 do
      begin
        Memo1.Lines.Add(Screen.Forms[i].Name);
      end;
    end;
    
    //Pode-se chamar um form especifico por exemplo:
    
    var
      i : integer;
    begin
      Memo1.Lines.Clear;
      for i := 0 to Screen.FormCount -1 do
      begin
        if (Screen.Forms[i] is TFrmPrincipal) then
        begin
          Screen.Forms[i].Show;
          Break;
        end;
      end;
    end;
    
    //Obs. Somente para forms.
    

    quinta-feira, 2 de agosto de 2012

    DELPHI - Retornando lista de diretórios

    Reações: 
    // unit1.pas inicio
    unit Unit1;
    
    interface
    
    uses
    
      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
      Dialogs, StdCtrls, FileCtrl;
    
    type
      TForm1 = class(TForm)
        Button1: TButton;
        Memo1: TMemo;
        procedure Button1Click(Sender: TObject);
      private
        sStrs : TStringList;
        { Private declarations }
      public
        procedure ListFiles(const PathName, FileName : string; const InDir : boolean; Limit : Integer = 0);
        { Public declarations }
      end;
    
    var
      Form1: TForm1;
    
    
    implementation
    
    {$R *.dfm}
    
    
    procedure TForm1.ListFiles(const PathName, FileName : string; const InDir : boolean; Limit : Integer);
    var Rec  : TSearchRec;
        Path : string;
    begin
      if not DirectoryExists(PathName) then exit;
    
      try
      if sStrs = nil then
      sStrs := TStringList.Create;
        Path := IncludeTrailingBackslash(PathName);
        if FindFirst(Path + FileName, faAnyFile - faDirectory, Rec) = 0 then
         try
           repeat
              if (Limit > 0) and (sStrs.Count >= Limit) then
              begin
                Exit;
              end
              else
              sStrs.Add(Path + Rec.Name);
           until FindNext(Rec) <> 0;
         finally
           FindClose(Rec);
         end;
    
        If not InDir then Exit;
    
        if FindFirst(Path + '*.*', faDirectory, Rec) = 0 then
         try
           repeat
            if ((Rec.Attr and faDirectory) <> 0)  and (Rec.Name<>'.') and (Rec.Name<>'..') then
             ListFiles(Path + Rec.Name, FileName, True, Limit);
           until FindNext(Rec) <> 0;
         finally
           FindClose(Rec);
         end;
    
       except
          sStrs.Destroy;
       raise;
       end;
    end;
    
    
    procedure TForm1.Button1Click(Sender: TObject);
    var
      Diretorio: String;
    Const
      CaminhoPadrao = 'D:\tmp\';
    begin
    
      if FileCtrl.SelectDirectory('Selecione o Diretório', '', Diretorio) then
      begin
        if Diretorio <> '' then
          if Diretorio[Length(Diretorio)] <> '\' then
            Diretorio := Diretorio + '\';
      end
      else
        Diretorio := CaminhoPadrao;
      if sStrs <> nil then
      FreeAndNil(sStrs);  
    
      ListFiles(Diretorio, '*.*', True, 30);
      Self.Caption := 'Linhas: ' + IntToStr(sStrs.Count);
      Memo1.Lines := sStrs;
    end;
    end.
    
    // Unit1.pas fim
    
    
    
    //Unit1.dfm inicio
    
    object Form1: TForm1
      Left = 192
      Top = 124
      Width = 455
      Height = 331
      Caption = 'Form1'
      Color = clBtnFace
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -11
      Font.Name = 'MS Sans Serif'
      Font.Style = []
      OldCreateOrder = False
      DesignSize = (
        439
        293)
      PixelsPerInch = 96
      TextHeight = 13
      object Button1: TButton
        Left = 21
        Top = 12
        Width = 75
        Height = 25
        Caption = 'Button1'
        TabOrder = 0
        OnClick = Button1Click
      end
      object Memo1: TMemo
        Left = 111
        Top = 24
        Width = 318
        Height = 260
        Anchors = [akLeft, akTop, akRight, akBottom]
        Lines.Strings = (
          'Memo1')
        ScrollBars = ssBoth
        TabOrder = 1
      end
    end
    //Unit1.dfm fim
    //Na instrução da linha:
    ListFiles(Diretorio, '*.*', True, 30);
    
    
    //O retorno será de 30 arquivos, para retornar mais suprima o valor, ex:
    
    ListFiles(Diretorio, '*.*', True);
    

    DELPHI - Abrir caixa de seleção de Diretório (pasta)

    Reações: 
    //Declare na seção uses:
    FileCtrl;
    
    procedure TForm1.Button1Click(Sender: TObject);
    var
      Diretorio: String;
    Const
      CaminhoPadrao = 'D:\tmp\';
    begin
      if FileCtrl.SelectDirectory('Selecione o Diretório', '', Diretorio) then
      begin
        if Diretorio <> '' then
          if Diretorio[Length(Diretorio)] <> '\' then
            Diretorio := Diretorio + '\';
      end
      else
        Diretorio := CaminhoPadrao;
    End;
    

    quinta-feira, 26 de julho de 2012

    DICIONARIO - Lista de palavras Junho/2012 - Dicionário PT_BR

    Reações: 

    Segue abaixo dicionario de palavras em formato txt para criação de inúmeros corretores ortográficos em Português do Brasil.


    Este arquivo contém somente as palavras no formato txt

    Base de informações decompilada do site 
    http://www.broffice.org/files/

    Link: DICIONARIO_PT_BR_BROFFICE_062012.rar
    Senha para abertura do arquivo: atlabs

    Obs. O programa incluso no arquivo (UnMunch.exe) compactado serve para decriptar arquivos .dic e .aff (inclusos no arquivo compactado também)

    Exemplo de uso: 
    Abra o prompt do windows no diretório aonde se encontra os arquivo *.dic e *.aff e o arquivo UnMunch.exe
    digite:
    UnMunch.exe arquivo.dic arquivo.aff > arquivodesaida.txt

    quarta-feira, 18 de julho de 2012

    DELPHI - Retornando a idade (Ano Separado de Mês)

    Reações: 


    //ATLabs 18-07-2012
    // Declarar na Uses: DateUtils
    
    function RetornaIdade(DataNasc: TDate): Double;
    var
      Anos, Meses: Integer;
    begin
      Result := -1;
      try
        if DataNasc <= Now then
        begin
          Anos := YearsBetween(Now, DataNasc);
          Meses := MonthsBetween(Now, DataNasc) - (Anos * 12);
          if (Anos = 0) and (Meses = 0) then
             Result := 0
          else
          begin
            if (Meses = 0) then
            Result := Anos
            else
            Result := Anos + (Meses * 0.1) ;
          end;
        end
        Else
        Result := 0;
      Except
      End;
    end;
    
    
    //Testando:
    
    procedure TForm1.Button1Click(Sender: TObject);
    begin
      Button1.Caption := FloatToStr(RetornaIdade(DateTimePicker1.Date));
    end;
    

    quarta-feira, 27 de junho de 2012

    DELPHI/FIREBIRD - Criação de banco (Firebird/Interbase) em RunTime (tempo de execução) e Execução de script de criação.

    Reações: 


    // ATLabs 27-06-2012
    // Unit1.pas inicio
    
    Unit Unit1;
    
    interface
    
    uses
    
      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
      Dialogs, StdCtrls, DB, IBDatabase, IBCustomDataSet, IBQuery, DBXpress,
      SqlExpr, Gauges;
    
    type
    
      TForm1 = class(TForm)
        IBDatabase1: TIBDatabase;
        Button1: TButton;
        IBTransaction1: TIBTransaction;
        IBQuery1: TIBQuery;
        OpenDialog1: TOpenDialog;
        Gauge1: TGauge;
        procedure Button1Click(Sender: TObject);
      private
        { Private declarations }
        procedure ExecutaScript(DBNAME, sArquivo: String);
        procedure CommitWork;
        Function ExecutaSQL(S : String; Var sError : String) : Boolean;
      public
        { Public declarations }
      end;
    
    var
      Form1: TForm1;
    
    Const
        fProcedures = 'STORED PROCEDURES';
        fViews      = 'VIEWS';
        fTables     = 'TABLES';
        fInsert     = 'INSERT INTO ';
        fDelete     = 'DELETE FROM ';
        fSetGen     = 'SET GENERATOR ';
        fCommit     = 'COMMIT WORK;';
    
    implementation
    
    {$R *.dfm}
    
    procedure TForm1.Button1Click(Sender: TObject);
    const
      DataBaseName = 'C:\TMP\BASE.GDB';
    var
      i : Integer;  
    begin
      IBDatabase1.DatabaseName := DataBaseName;
      IBDatabase1.LoginPrompt := false;
      if not FileExists(DataBaseName) then
      begin
        IBDatabase1.Params.Text :=
          ' USER ''SYSDBA'' PASSWORD ''masterkey'' ' +
          ' PAGE_SIZE 8192 ' +
          ' DEFAULT CHARACTER SET NONE COLLATION NONE ';
        IBDatabase1.CreateDatabase;
        ShowMessage('Banco de dados ' + DataBaseName + ' criado com sucesso!');
      end;
      IBDatabase1.Close;
      IBDatabase1.Params.Clear;
      IBDatabase1.Params.Add('user_name=sysdba');
      IBDatabase1.Params.Add('password=masterkey');
    
      IBDatabase1.Open;
      if OpenDialog1.Execute then
      begin
        Gauge1.Visible := True;
        try
        Self.ExecutaScript(DataBaseName, OpenDialog1.FileName);
        finally
          Gauge1.Visible := False;
        end;
      end;
      IBDatabase1.Close;
    end;
    
    procedure TForm1.CommitWork;
    var
      ibqCommit : TIBQuery;
    begin
      Try
        ibqCommit             := TIBQuery.Create(Nil);
        ibqCommit.Database    := IBDatabase1;
        ibqCommit.Transaction := IBDatabase1.DefaultTransaction;
        ibqCommit.Close;
        ibqCommit.SQL.Text := 'Commit Work';
        ibqCommit.ExecSQL;
      Finally
        FreeAndNil(ibqCommit);
      End;
    end;
    
    
    procedure TForm1.ExecutaScript(DBNAME, sArquivo: String);
    var
      Strs, sSQL : TStringList;
      SQL, sItem, scTipo, sNProc, cEnd, sMSG, sError : String;
      I, Itens, ItensProc, ItensNProc,
      ErrorCode : Integer;
      SQLConnection : TSQLConnection;
    Const
    
      cView0  = 'CREATE VIEW ';
      cView1  = 'CREATE OR ALTER VIEW ';
      cSP0    = 'CREATE PROCEDURE ';
      cSP1    = 'ALTER PROCEDURE ';
      cSP2    = 'CREATE OR ALTER PROCEDURE ';
    
      cCreate       = 'CREATE ';
      cCreateErr0   = 'CREATE DATABASE ';
    
      cAlter        = 'ALTER ';
      cInsert       = 'INSERT ';
      cDelete       = 'DELETE ';
      cDescrib      = 'DESCRIBE ';
      cDeclareExt   = 'DECLARE EXTERNAL ';
      cSet          = 'SET ';
      cSetErr0      = 'SET SQL ';
      cSetErr1      = 'SET NAMES ';
      cSetErr2      = 'SET TERM ';
      cCommit       = 'COMMIT ';
      cEndP         = '^';
      cEndAll       = ';';
    
      procedure LimpaVars;
      begin
        sSQL.Clear;
        sSQL.text := '';
        SQL := '';
        scTipo := '';
        sItem := '';
      end;
    
      function ValidaItem(SQL : String) : Boolean;
      begin
        Result := False;
        if (
           ((POS(cCreate, UpperCase(SQL)) = 1)
           and (POS(cCreateErr0, UpperCase(SQL)) = 0)
           )
        or (POS(cView0, UpperCase(SQL)) = 1)
        or (POS(cView1, UpperCase(SQL)) = 1)
        or (POS(cSP0, UpperCase(SQL)) = 1)
        or (POS(cSP1, UpperCase(SQL)) = 1)
        or (POS(cSP2, UpperCase(SQL)) = 1)
        or (POS(cAlter, UpperCase(SQL)) = 1)
        or (POS(cInsert, UpperCase(SQL)) = 1)
        or (POS(cDelete, UpperCase(SQL)) = 1)
        or (POS(cDescrib, UpperCase(SQL)) = 1)
        or (POS(cDeclareExt, UpperCase(SQL)) = 1)
        or ((POS(cSet, UpperCase(SQL)) = 1)
             and (POS(cSetErr0, UpperCase(SQL)) = 0)
             and (POS(cSetErr1, UpperCase(SQL)) = 0)
           )
        or (POS(cCommit, UpperCase(SQL)) = 1)) then
        Result := True;
      end;
    
      Procedure SetItem(SQL : String);
      begin
        scTipo := '';
        if ValidaItem(SQL) then
        begin
          if (POS(cCreate, UpperCase(SQL)) = 1) then
            scTipo := cCreate;
          if (POS(cView0, UpperCase(SQL)) = 1) then
            scTipo := cView0;
          if (POS(cView1, UpperCase(SQL)) = 1) then
            scTipo := cView1;
          if (POS(cSP0, UpperCase(SQL)) = 1) then
            scTipo := cSP0;
          if (POS(cSP1, UpperCase(SQL)) = 1) then
            scTipo := cSP1;
          if (POS(cSP2, UpperCase(SQL)) = 1) then
            scTipo := cSP2;
    
          if (POS(cAlter, UpperCase(SQL)) = 1) then
            scTipo := cAlter;
    
          if (POS(cInsert, UpperCase(SQL)) = 1) then
            scTipo := cInsert;
          if (POS(cDelete, UpperCase(SQL)) = 1) then
            scTipo := cDelete;
          if (POS(cDescrib, UpperCase(SQL)) = 1) then
            scTipo := cDescrib;
          if (POS(cDeclareExt, UpperCase(SQL)) = 1) then
            scTipo := cDeclareExt;
          if (POS(cSet, UpperCase(SQL)) = 1) then
            scTipo := cSet;
          if (POS(cCommit, UpperCase(SQL)) = 1) then
            scTipo := cCommit;
        end;
      end;
    
      procedure SetValuecEnd(SQL : String);
      begin
        if ValidaItem(SQL) then
        begin
          cEnd := cEndAll;
          if (POS(cSP0, UpperCase(SQL)) = 1)
          or (POS(cSP1, UpperCase(SQL)) = 1)
          or (POS(cSP2, UpperCase(SQL)) = 1) then
          cEnd := cEndP;
        end;  
      end;
    
      Function SQLValido (SQL : TStringList) : Boolean;
      begin
        Result := False;
        if (POS(UpperCase(scTipo), UpperCase(SQL.Strings[0])) = 1) then
          Result := True
        Else
          LimpaVars;
      end;
    begin
    
      try
    
        Strs := TStringList.Create;
        SQLConnection := TSQLConnection.Create(Nil);
        SQLConnection.ConnectionName := 'IBLocal';
        SQLConnection.DriverName     := 'Interbase';
        SQLConnection.GetDriverFunc  := 'getSQLDriverINTERBASE';
        SQLConnection.LibraryName    := 'dbexpint.dll';
        SQLConnection.Params.Text :=
          'BlobSize=-1' + #13#10 +
          'CommitRetain=False' + #13#10 +
          'Database=' + DBNAME + #13#10 +
          'DriverName=Interbase' + #13#10 +
          'ErrorResourceFile=' + #13#10 +
          'LocaleCode=0000' + #13#10 +
          'Password=masterkey' + #13#10 +
          'RoleName=RoleName' + #13#10 +
          'ServerCharSet=' + #13#10 +
          'SQLDialect=3' + #13#10 +
          'Interbase TransIsolation=ReadCommited' + #13#10 +
          'User_Name=sysdba' + #13#10 +
          'WaitOnLocks=True';
        SQLConnection.VendorLib := 'GDS32.DLL';
        SQLConnection.Open;
    
       if FileExists(sArquivo) then
        begin
          try
          sSQL := TStringList.Create;
          Strs.LoadFromFile(sArquivo);
          Gauge1.MinValue := 0;
          Gauge1.MaxValue := Strs.Count;
    
          I := 0;
          Itens := 0;
          ItensProc := 0;
          ItensNProc := 0;
          LimpaVars;
    
          while I <= Strs.Count - 1 do
          begin
            if (trim(StringReplace(Strs.Strings[i], #$D#$A, '', [rfReplaceAll, rfIgnoreCase])) = '')  and (sSQL.Count = 0) then
            begin
              Inc(I);
              Continue;
            end;
    
    
            if (sSQL.Count > 0)
            and (SQLValido(sSQL))
            and (POS(cEnd, sSQL.text) > 0)
            and (StringReplace(sSQL.text, #$D#$A, '', [rfReplaceAll, rfIgnoreCase]) <> '')
            and (ValidaItem(sSQL.Strings[0]))
            then
            begin
              Sleep(1);
              Application.ProcessMessages;
              SQL := sSQL.text;
                if cEnd = cEndP then
                begin
                  Delete(SQL, Pos(cEnd,sSQL.text), 1);
                  sSQL.text := SQL;
                  try
    
                  ErrorCode := SQLConnection.ExecuteDirect(sSQL.text);
                  SQLConnection.ExecuteDirect('COMMIT WORK');
                  except
                    on e: Exception do
                    begin
                      if POS(UpperCase('ALREADY EXISTS'), UpperCase(E.Message)) = 0 then
                      ShowMessage('Erro: ' + E.Message);
                      end;
                  end;
                  if ErrorCode <> 0 then
                  begin
                    sNProc := sNProc + ' ' + sItem;
                    Inc(ItensNProc);
                  end
                  else
                  Inc(ItensProc);
                end;
    
              if (cEnd = cEndAll) and (POS(cEndAll, sSQL.text) > 0) then
              begin
                Delete(SQL, Pos(cEnd,sSQL.text), 1);
                sSQL.text := SQL;
    
                if Self.ExecutaSQL(sSQL.text, sError) then
                begin
                  Inc(ItensProc);
                  Self.CommitWork;
                end
                else
                begin
                  if POS(UpperCase('ALREADY EXISTS'), UpperCase(sError)) = 0 then
                  begin
                    sNProc := sNProc + ' ' + sItem;
                    Inc(ItensNProc);
                  end;
                end;
              end;
    
              LimpaVars;
              inc(Itens);
            end;
    
    
            if (trim(Strs.Strings[i]) <> '') then
            begin
              if (scTipo = '') then
                LimpaVars;
    
              SQL := Strs.Strings[i];
    
              if ValidaItem(SQL) then
              begin
                SetValuecEnd(SQL);
                if (POS(cView0, UpperCase(SQL)) > 0) then
                begin
                  SQL := StringReplace(SQL, cView0, cView1, [rfReplaceAll, rfIgnoreCase]);
                  scTipo := cView1;
                end;
    
                if (POS(cSP1, UpperCase(SQL)) > 0) then
                begin
                  SQL := StringReplace(SQL, cSP1, cSP2, [rfReplaceAll, rfIgnoreCase]);
                  scTipo := cSP2;
                end;
    
                SetItem(SQL);
    
                if  Pos('(', SQL) > 0 then
                begin
                  sItem := Copy(SQL, POS(scTipo, UpperCase(SQL)) + Length(scTipo), Pos('(', SQL) - (POS(scTipo, UpperCase(SQL)) + Length(scTipo)));
                  if  Pos(' ', sItem) > 0 then
                  sItem := Copy(sItem, POS(' ', UpperCase(sItem)), Length(sItem));
                end
                else
                  if (POS(cEnd, SQL) > 0) then
                    sItem := SQL;
              end;
              Self.Caption := sItem;
              sSQL.Add(SQL);
            end;
    
            Inc(i);
            Gauge1.Progress := i;
          end;
    
          finally
            Gauge1.Progress := Strs.Count;
            FreeAndNil(sSQL);
            SQLConnection.Close;
            FreeAndNil(SQLConnection);
            Self.CommitWork;
            sMSG := 'Resumo Arquivo : ' + ExtractFileName(sArquivo) + #$D#$A +
                    'Linhas: ' + inttostr(I) + #$D#$A +
                    'Qtd. Itens: ' + inttostr(Itens) + #$D#$A +
                    'Qtd. Itens Processados: ' + inttostr(ItensProc) + #$D#$A +
                    'Qtd. Itens Não Processados: ' + inttostr(ItensNProc) + #$D#$A +
                    TrimLeft(sNProc);
    
           ShowMessage(sMSG);
          end;
    
       end
        else
        begin
          ShowMessage('O arquivo: "' + sArquivo + '" não foi localizado. Cancelado.');
        end;
      finally
        FreeAndNil(Strs);
      end;
    end;
    
    function TForm1.ExecutaSQL(S : String; Var sError : String): Boolean;
    var
      ibqExecSql : TIBQuery;
    begin
    
      Try
        Result                 := False;
        ibqExecSql             := TIBQuery.Create(Nil);
        ibqExecSql.Database    := IBDatabase1;
        ibqExecSql.Transaction := IBDatabase1.DefaultTransaction;
    
        ibqExecSql.Close;
        ibqExecSql.SQL.Text := S;
        try
          ibqExecSql.ExecSQL;
          Result := True;
          sError := '';
        Except
          on E: Exception do
          begin
            Result := False;
            sError := E.Message;
          end;
        end;
      Finally
        FreeAndNil(ibqExecSql);
      End;
    end;
    end.
    // Unit1.pas Fim
    
    
    // Unit1.dfm Inicio
    
    object Form1: TForm1
      Left = 175
      Top = 117
      Width = 169
      Height = 121
      Caption = 'Form1'
      Color = clBtnFace
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -11
      Font.Name = 'MS Sans Serif'
      Font.Style = []
      OldCreateOrder = False
      PixelsPerInch = 96
      TextHeight = 13
      object Gauge1: TGauge
        Left = 0
        Top = 73
        Width = 161
        Height = 14
        Align = alBottom
        Progress = 0
        Visible = False
      end
      object Button1: TButton
        Left = 43
        Top = 31
        Width = 75
        Height = 25
        Caption = 'Cria Base'
        TabOrder = 0
        OnClick = Button1Click
      end
      object IBDatabase1: TIBDatabase
        DatabaseName = 'C:\TMP\BASE.GDB'
        Params.Strings = (
          'user_name=sysdba'
          'password=masterkey')
        LoginPrompt = False
        DefaultTransaction = IBTransaction1
        IdleTimer = 0
        SQLDialect = 3
        TraceFlags = []
        Left = 27
        Top = 15
      end
      object IBTransaction1: TIBTransaction
        Active = False
        AutoStopAction = saNone
        Left = 27
        Top = 45
      end
      object IBQuery1: TIBQuery
        Database = IBDatabase1
        Transaction = IBTransaction1
        BufferChunks = 1000
        CachedUpdates = False
        Left = 75
        Top = 6
      end
      object OpenDialog1: TOpenDialog
        Filter = 'Arquivos *.sql|*.sql'
        Left = 114
        Top = 6
      end
    end
    // Unit1.dfm Fim
    

    terça-feira, 26 de junho de 2012

    DELPHI - Alterando Configurações Regionais (dd/MM/yyyy)

    Reações: 


    // ATLabs 26-06-2012
    
    SetLocaleInfo(LOCALE_SYSTEM_DEFAULT,  LOCALE_SSHORTDATE, PChar('dd/MM/yyyy'));
    
    // Há outras configurações que podem ser alteradas, altere a constante LOCALE_SSHORTDATE pressionando o ctrl+espaco em LOCALE_S
    

    DELPHI - Formatando CNPJ/CPF

    Reações: 


    //ATLabs 26-06-2012
    
    
    //Formatar CNPJ
    
    function FormataCNPJ(const Valor : String) : string;
    Const
      ZEROS = '000000000000000000'; // 18 Caracteres
    Var S : String;
    begin
       S := ZEROS + Valor;
       S :=       Copy(S, length(S) - 13, 2) +
            '.' + Copy(S, length(S) - 11, 3) +
            '.' + Copy(S, length(S) - 8, 3) +
            '/' + Copy(S, length(S) - 5, 4) +
            '-' + Copy(S, length(S) - 1, 2);
       result := Copy(S, Length(S) - 18, 18); // Tamanho 18 já com a formatação 00.000.000/0000-00
    end;
    
    //Formatar CPF
    function FormataCPF(const Valor : String) : string;
    Const
      ZEROS = '00000000000000'; // 14 Caracteres
    Var S : String;
    begin
       S := ZEROS + Valor;
       S :=       Copy(S, length(S) - 10, 3) +
            '.' + Copy(S, length(S) - 7, 3) +
            '.' + Copy(S, length(S) - 4, 3) +
            '-' + Copy(S, length(S) - 1, 2);
       result := Copy(S, Length(S) - 14, 14); // Tamanho 14 já com a formatação 000.000.000-00
    end;
    

    segunda-feira, 25 de junho de 2012

    DELPHI - Listando Processos da Memória

    Reações: 


    // Dados da Unit1.Pas
    
    // Unit1.pas - Inicio
    
    unit Unit1;
    
    interface
    
    uses
    
      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
      Dialogs, ExtCtrls, StdCtrls;
    
    type
    
      TForm1 = class(TForm)
        Timer1: TTimer;
        ListBox1: TListBox;
        procedure FormShow(Sender: TObject);
        procedure Timer1Timer(Sender: TObject);
      private
        { Private declarations }
      public
        lp : Integer;
        { Public declarations }
      end;
    
    var
      Form1: TForm1;
    
    implementation
    
    {$R *.dfm}
    
    function EnumProcess(hHwnd: HWND; lParam : integer): boolean; stdcall;
    var
      pPid : DWORD;
      title, ClassName, Extra : string;
    begin
      //Se retornar nulo, cancela e sai
      if (hHwnd=NULL) then
      begin
        result := false;
      end
      else
      begin
        //Pega o Numero Identificado Do Processo(PID)
        GetWindowThreadProcessId(hHwnd,pPid);
        //ClassName do Processo
        SetLength(ClassName, 255);
        SetLength(ClassName,
                  GetClassName(hHwnd,
                               PChar(className),
                               Length(className)));
        SetLength(title, 255);
        //Titulo do Processo
        SetLength(title, GetWindowText(hHwnd, PChar(title), Length(title)));
        //Exibe a informação em uma lista (Componente Visual)
        Form1.ListBox1.Items.Add
          ('Class Name = ' + className +
           '; Title = ' + title +
           '; HWND = ' + IntToStr(hHwnd) +
           '; Pid = ' + IntToStr(pPid));
        Result := true;
      end;
    end;
    
    procedure TForm1.FormShow(Sender: TObject);
    begin
      Timer1Timer(Self); 
    end;
    
    procedure TForm1.Timer1Timer(Sender: TObject);
    begin
      ListBox1.Clear;
      if not EnumWindows(@EnumProcess,lp) then exit; // A cada 10 segundos exibe o q está em memória
    end;
    
    end.
    
    //Unit1.pas Fim
    
    
    // Unit1.dfm - Inicio (Form1)
    
    object Form1: TForm1
      Left = 192
      Top = 114
      Width = 1179
      Height = 585
      Caption = 'Form1'
      Color = clBtnFace
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -11
      Font.Name = 'MS Sans Serif'
      Font.Style = []
      OldCreateOrder = False
      OnShow = FormShow
      PixelsPerInch = 96
      TextHeight = 13
      object ListBox1: TListBox
        Left = 0
        Top = 0
        Width = 1171
        Height = 551
        Align = alClient
        ItemHeight = 13
        TabOrder = 0
      end
      object Timer1: TTimer
        Interval = 10000
        OnTimer = Timer1Timer
        Left = 69
        Top = 33
      end
    end
    // Unit1.dfm - Fim (Form1)
    

    sexta-feira, 22 de junho de 2012

    DELPHI - Listando tamanho das áreas de trabalho - TScreen

    Reações: 


    // ATLabs 22-06-2012
    
    procedure TForm1.FormCreate(Sender: TObject);
    begin
    
      Label1.Caption := // Largura do monitor principal
                        ' Screen.Width: ' + IntToStr(Screen.Width)+ #13#10 +
                        //------------------------------------
    
                        // Largura Total de monitores, monitor[0].width + monitor[1].width), depende do posicionamento dos monitores (Top - Left - Bottom - Right)
                        ' Screen.DesktopWidth: ' + IntToStr(Screen.DesktopWidth)+ #13#10 +
                        //--------------------------------------------------------------
    
                        // Largura do monitor principal menos a largura da barra de iniciar (se estiver na vertical)
                        ' Screen.WorkAreaWidth: ' + IntToStr(Screen.WorkAreaWidth)+ #13#10 +
                        //------------------------------------------------------------------
    
                        // Largura do monitor 0
                        ' Screen.Monitors[0].Width: ' + IntToStr(Screen.Monitors[0].Width)+ #13#10 +
                        //---------------------
    
                        // Largura do monitor 1// Somente se tiver + de um monitor (este seria o segundo monitor)
                        ' Screen.Monitors[1].Width: ' + IntToStr(Screen.Monitors[1].Width)+ #13#10 +
                        //---------------------
    
                        // Altura do monitor principal
                        ' Screen.Height: ' + IntToStr(Screen.Height)+ #13#10 +
                        //----------------------------
    
                        // Maior Largura Total dos monitores, depende do posicionamento dos monitores  (Top - Left - Bottom - Right)
                        ' Screen.DesktopHeight: ' + IntToStr(Screen.DesktopHeight)+ #13#10 +
                        //------------------------------------------------------------------
    
                        // Altura do monitor principal menos a largura da barra de iniciar (se estiver na horizontal)
                        ' Screen.WorkAreaHeight: ' + IntToStr(Screen.WorkAreaHeight)+ #13#10 +
                        //--------------------------------------------------------------------
    
    
                        // Altura do monitor 0
                        ' Screen.Monitors[0].Height: ' + IntToStr(Screen.Monitors[0].Height)+ #13#10 +
                        //--------------------
    
                        // Altura do monitor 1 // Somente se tiver + de um monitor (este seria o segundo monitor)
                        ' Screen.Monitors[1].Height: ' + IntToStr(Screen.Monitors[1].Height);
                        //--------------------
    end;
    
    //Aconselho o teste dentro de uma Virtual Machine (VMWarePlayer) para conseguir simular casos de area de trabalho e multiplos monitores.
    
    
    

    quinta-feira, 21 de junho de 2012

    DELPHI - Altura da StartBar - Barra do Menu Iniciar

    Reações: 


    ShowMessage(IntToStr(Screen.DesktopHeight - Screen.WorkAreaHeight));
    

    sábado, 2 de junho de 2012

    DELPHI - Upload via Web Server Application - DELPHI

    Reações: 


    //ATLabs - Postado no site Planetadelphi.com.br - Quase 20.000 views
    
    {
    ATENÇÃO: POR MOTIVOS ÓBVIOS, SEMPRE TENTE UTILIZAR A VERSÃO MAIS ATUAL DO DELPHI PARA COMPILAÇÕES WEB, VOCÊ PODERÁ TER PROBLEMAS DE INCOMPATIBILIDADE COM O SERVIDOR DO IIS OU APACHE
    // ULTIMO TESTE REALIZADO EM PLATAFORMA DELPHI XE
    E LÁ VAMOS NÓS DE NOVO.
    FIQUEI 4 DIAS PARA DESCOBRIR COMO FUNCIONA, E COMO O JÁ POSTADO
    NOS MEUS OUTROS POSTS NÃO ENCONTREI NADA NA INTERNET DAI EU ME VIREI...
    VOU INDICAR COMO SE FAZ UPLOAD DE ARQUIVO VIA WEB SERVER APPLICATION, TESTEI OS FONTES VIA ISAPI (*.DLL) E VIA CGI STAND-ALONE (*.EXE) E FUNCIONOU PERFEITAMENTE.
    VAMOS DO COMEÇO, LEMBRANDO QUE EU NÃO VOU DAR DICAS DE HTML, VOU POSTAR SOMENTE O QUE PRECISA PARA QUE FUNCIONE, E
    LEMBRANDO SEMPRE QUE EU POSTO O QUE JÁ ESTÁ EM PRATICA NOS MEUS FONTES, POR ESTE MOTIVO ELES FUNCIONAM:
    O FORMULÁRIO DO HTML DEVE CONTER A SEGUINTE SINTAXE:
    //    form enctype="multipart/form-data" method="post" runat="server" action="../appweb.exe/sobe_arq" name="f_envio">
    REPARE NA OPÇÃO [enctype="multipart/form-data"] SE NÃO FOR DECLARADA NÃO FUNCIONA!!!!
    SEGUE ABAIXO AS FUNCÕES PARA RESGATAR OS VALORES DO UPLOAD:
    EXPLICAÇÃO:
    // RETORNA OS VALORES DE CAMPOS DOS FORMULARIOS, DO TIPO TEXTFIELD POR EXEMPLO
    function ValorCampoMultipartFormData(const Content: String; Chave,
      NomeCampo: String): String;
    // RETORNA O VALOR DO NOME DO ARQUIVO ENVIADO PELO USUARIO FINAL, ELA NÃO RETORNA O CAMINHO, SOMENTE O VALOR
    function NomeOriginalArqMultipartFormData(const Content: String; Chave: String): String;
    // RETORNA O ARQUIVO EM UMA STRNG GIGANTESCA, SE FOR O CASO DE ARQUIVO ZIP POR EX.
    function ValorArquivoMultipartFormData(const Content: String; Chave, TipoArquivo: String): String;
    }
    
    function ValorCampoMultipartFormData(const Content: String; Chave,
      NomeCampo: String): String;
    Var
     S : String;
    begin
    // NO HTML INFORMAR:  form enctype="multipart/form-data" method="post" runat="server" action="[ACTION QUE PROCESSARÁ ESTE CODIGO]">
    // REPARE NA OPÇÃO ENCTYPE="MULTPART/FORM-DATA" METHOD="POST" ELA QUE IRÁ PASSAR A INFORMAÇÃO DO ARQUIVO DE UPLOAD, SEM ELA O HTML NÃO ENVIA O ARQUIVO PARA A MEMORIA DO SERVIDOR
    // Content => PASSAR O VALOR DE REQUEST.CONTENT;
    // Chave => PASSAR O VALOR DE REQUEST.CONTENTFIELDS.STRINGS[0]; // ZERO PORQUE ELE IRÁ RETORNAR NA POSIÇÃO ZERO A CHAVE DE IDENTIFICAÇÃO DAKELE POST
    // NomeCampo => NOME DO TEXTFIELD QUE SE DESEJA RESGATAR A INFORMAÇÃO
    S := Content;
    Delete(S, 1, pos(NomeCampo, S) + length(NomeCampo) + 1);
    Result := copy(S, 1, pos(Chave, S) - 2);
    end;
    
    function NomeOriginalArqMultipartFormData(const Content: String; Chave: String): String;
    Var
     S : String;
    begin
    
    // NO HTML INFORMAR: form enctype="multipart/form-data" method="post" runat="server" action="[ACTION QUE PROCESSARÁ ESTE CODIGO]">
    // REPARE NA OPÇÃO ENCTYPE="MULTPART/FORM-DATA" METHOD="POST" ELA QUE IRÁ PASSAR A INFORMAÇÃO DO ARQUIVO DE UPLOAD, SEM ELA O HTML NÃO ENVIA O ARQUIVO PARA A MEMORIA DO SERVIDOR
    // Content => PASSAR O VALOR DE REQUEST.CONTENT;
    // Chave => PASSAR O VALOR DE REQUEST.CONTENTFIELDS.STRINGS[0]; // ZERO PORQUE ELE IRÁ RETORNAR NA POSIÇÃO ZERO A CHAVE DE IDENTIFICAÇÃO DAKELE POST
    S := Content;
    Delete(S, 1, pos('filename', S) + length('filename') + 1);
    Result := copy(S, 1, pos('Content-Type:', S) - 4);
    end;
    
    function ValorArquivoMultipartFormData(const Content: String; Chave, TipoArquivo: String): String;
    Var
     S : String;
    begin
    // NO HTML INFORMAR: form enctype="multipart/form-data" method="post" runat="server" action="[ACTION QUE PROCESSARÁ ESTE CODIGO]">
    // REPARE NA OPÇÃO ENCTYPE="MULTPART/FORM-DATA" METHOD="POST" ELA QUE IRÁ PASSAR A INFORMAÇÃO DO ARQUIVO DE UPLOAD, SEM ELA O HTML NÃO ENVIA O ARQUIVO PARA A MEMORIA DO SERVIDOR
    // Content => PASSAR O VALOR DE REQUEST.CONTENT;
    // Chave => PASSAR O VALOR DE REQUEST.CONTENTFIELDS.STRINGS[0]; // ZERO PORQUE ELE IRÁ RETORNAR NA POSIÇÃO ZERO A CHAVE DE IDENTIFICAÇÃO DAKELE POST
    // TipoArquivo => PASSAR O VALOR DE REQUEST.CONTENTFIELDS.STRINGS[3]; // RETORNA O VALOR: EX.:  "Content-Type: application/octet-stream" - OBS. SEM AS ASPAS
    // CASO O VALOR NÃO SEJA DA 3ª STRING, FAÇA UM LOOPING PARA PEGAR O TEXTO "Content-Type:" DENTRO DA OPÇÃO CONTENTFIELDS DO REQUEST
    // ContentField2 => PASSAR O VALOR DE REQUEST.CONTENTFIELDS.STRINGS[2]; // RETORNA O VALOR: EX.:  [filename="acordosg.sql"] - OBS. SEM AS CHAVES
    S := Content;
    Delete(S, 1, pos(TipoArquivo, S) + length(TipoArquivo) + 3);
    Result := copy(S, 1, pos(Chave, S) - 3);
    end;
    
    {
    INFORMANDO ESTAS FUNÇÕES NA APLICAÇÃO EU VOU EXPLICAR SOMENTE A VALOR DO ARQUIVO, POIS ELA É A UNICA MAIS CRITICA PARA EXPLICAÇÃO.
    COLOQUE UMA NOVA WEBACTION (QUE VAR SER A AÇÃO DO FORMULÁRIO JÁ DESCRITO COM O ENCTYPE)
    DECLARE AS VARIAVEIS: }
    
    VAR
    F : File;
    Arq, LocalArqUpLoad,
    ContType : String;
    TamArq, TamW, I : Integer;
    BEGIN
      try
      ContType := '';
      for i := 0 to Request.ContentFields.Count - 1 do
       begin
        if pos('Content-Type:', Request.ContentFields.Strings[i]) > 0 then
         ContType := Request.ContentFields.Strings[i];
       end; 
       LocalArqUpLoad := 'C:TMP';
       Arq := ValorArquivoMultipartFormData(Request.Content, Request.ContentFields.Strings[0], ContType);
       TamArq := Length(Arq);
       AssignFile(F, LocalArqUpLoad + NomeOriginalArqMultipartFormData(Request.Content, Request.ContentFields.Strings[0]));
       Rewrite(F, 1);
       for TamW := 1 to TamArq do
        begin
         BlockWrite(F, arq[TamW], 1);
        end;
     finally
      CloseFile(f);
     end;
     RESPONSE.CONTENT := 'UPLOAD EFETUADO COM SUCESSO!!!';
     HANDLED := TRUE;
    END;
    
    {AS OUTRAS FUNÇÕES VÃO SER PASSADAS CONFORME O DESCRITO NA EXPLICAÇÃODE CADA FUNÇÃO
    ESPERO TER AJUDADO E VOTEM NA DICA, CASO VOCÊS NÃO TENHAM ENTENDIDO, POR FAVOR NÃO PONTUE O POST COM UM VALOR BAIXO
    ATT. FELIPE LEAL
    }
    //-----------------------
    

    DELPHI - Boleto - Codigo de Barras e Linha Digitavel

    Reações: 


    // ATLabs - Postado no site planetadelphi.com.br + de 35.000  views - Gostaria da divisão de lucros dos ADSENSE da pagina que foi postada
    {
    Saudações queridos colegas programadores;
    Já que não achei nenuma solução na web que funcionasse corretamente, decidi criar a minha baseada no componente de boletos da GBSoft
    Creio que baixei este componente aqui da do site do planeta delphi...
    Esta dica contém as funções/procedures abaixo:
    Modulo10, Modulo11, Formatar, CalcularFatorVencimento, CorrigeSTR, GeraCodBarras, GeraLinhaDigitavel
    Para explicar melhor para aqueles que vão ler esta mensagem:
    Primeiro gera-se o código de barras depois gera-se a linha digitável, um depende do outro
    }
    
    ///////////// Inicio - retirados do componente da GBSoft
    
    function Modulo10(Valor: String) : string;
    {
       Rotina usada para cálculo de alguns dígitos verificadores
       Pega-se cada um dos dígitos contidos no parâmetro VALOR, da direita para a
       esquerda e multiplica-se por 2121212...
       Soma-se cada um dos subprodutos. Caso algum dos subprodutos tenha mais de um
       dígito, deve-se somar cada um dos dígitos. (Exemplo: 7*2 = 14 >> 1+4 = 5)
       Divide-se a soma por 10.
       Faz-se a operação 10-Resto da divisão e devolve-se o resultado dessa operação
       como resultado da função Modulo10.
       Obs.: Caso o resultado seja maior que 9, deverá ser substituído por 0 (ZERO).
    }
    
    var
    
       Auxiliar : string;
       Contador, Peso : integer;
       Digito : integer;
    begin
       Auxiliar := '';
       Peso := 2;
       for Contador := Length(Valor) downto 1 do
       begin
          Auxiliar := IntToStr(StrToInt(Valor[Contador]) * Peso) + Auxiliar;
          if Peso = 1 then
             Peso := 2
          else
             Peso := 1;
       end;
       Digito := 0;
       for Contador := 1 to Length(Auxiliar) do
       begin
          Digito := Digito + StrToInt(Auxiliar[Contador]);
       end;
       Digito := 10 - (Digito mod 10);
       if (Digito > 9) then
          Digito := 0;
       Result := IntToStr(Digito);
    end;
    
    function Modulo11(Valor: String; Base: Integer = 9; Resto : boolean = false) : string;
    {
       Rotina muito usada para calcular dígitos verificadores
       Pega-se cada um dos dígitos contidos no parâmetro VALOR, da direita para a
       esquerda e multiplica-se pela seqüência de pesos 2, 3, 4 ... até BASE.
       Por exemplo: se a base for 9, os pesos serão 2,3,4,5,6,7,8,9,2,3,4,5...
       Se a base for 7, os pesos serão 2,3,4,5,6,7,2,3,4...
       Soma-se cada um dos subprodutos.
       Divide-se a soma por 11.
       Faz-se a operação 11-Resto da divisão e devolve-se o resultado dessa operação
       como resultado da função Modulo11.
       Obs.: Caso o resultado seja maior que 9, deverá ser substituído por 0 (ZERO).
    }
    var
       Soma : integer;
       Contador, Peso, Digito : integer;
    begin
       Soma := 0;
       Peso := 2;
       for Contador := Length(Valor) downto 1 do
       begin
          Soma := Soma + (StrToInt(Valor[Contador]) * Peso);
          if Peso < Base then
             Peso := Peso + 1
          else
             Peso := 2;
       end;
       if Resto then
          Result := IntToStr(Soma mod 11)
       else
       begin
          Digito := 11 - (Soma mod 11);
          if (Digito > 9) then
             Digito := 0;
          Result := IntToStr(Digito);
       end
    end;
    
    function Formatar(Texto : string; TamanhoDesejado : integer; AcrescentarADireita : boolean = true; CaracterAcrescentar : char = ' ') : string;
    {
       OBJETIVO: Eliminar caracteres inválidos e acrescentar caracteres à esquerda ou à direita do texto original para que a string resultante fique com o tamanho desejado
       Texto : Texto original
       TamanhoDesejado: Tamanho que a string resultante deverá ter
       AcrescentarADireita: Indica se o carácter será acrescentado à direita ou à esquerda
          TRUE - Se o tamanho do texto for MENOR que o desejado, acrescentar carácter à direita
                 Se o tamanho do texto for MAIOR que o desejado, eliminar últimos caracteres do texto
          FALSE - Se o tamanho do texto for MENOR que o desejado, acrescentar carácter à esquerda
                 Se o tamanho do texto for MAIOR que o desejado, eliminar primeiros caracteres do texto
       CaracterAcrescentar: Carácter que deverá ser acrescentado
    }
    var
       QuantidadeAcrescentar,
       TamanhoTexto,
       PosicaoInicial,
       i : integer;
    begin
       case CaracterAcrescentar of
          '0'..'9','a'..'z','A'..'Z' : ;{Não faz nada}
          else
             CaracterAcrescentar := ' ';
       end;
       Texto := Trim(AnsiUpperCase(Texto));
       TamanhoTexto := Length(Texto);
       for i := 1 to (TamanhoTexto) do
       begin
          if Pos(Texto[i],' 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ`~''"!@#$%^&*()_-+=|/{}[]:;,.<>') = 0 then
          begin
             case Texto[i] of
                'Á','À','Â','Ä','Ã' : Texto[i] := 'A';
                'É','È','Ê','Ë' : Texto[i] := 'E';
                'Í','Ì','Î','Ï' : Texto[i] := 'I';
                'Ó','Ò','Ô','Ö','Õ' : Texto[i] := 'O';
                'Ú','Ù','Û','Ü' : Texto[i] := 'U';
                'Ç' : Texto[i] := 'C';
                'Ñ' : Texto[i] := 'N';
                else Texto[i] := ' ';
             end;
          end;
       end;
       QuantidadeAcrescentar := TamanhoDesejado - TamanhoTexto;
       if QuantidadeAcrescentar < 0 then
          QuantidadeAcrescentar := 0;
       if CaracterAcrescentar = '' then
          CaracterAcrescentar := ' ';
       if TamanhoTexto >= TamanhoDesejado then
          PosicaoInicial := TamanhoTexto - TamanhoDesejado + 1
       else
          PosicaoInicial := 1;
       if AcrescentarADireita then
          Texto := Copy(Texto,1,TamanhoDesejado) + StringOfChar(CaracterAcrescentar,QuantidadeAcrescentar)
       else
          Texto := StringOfChar(CaracterAcrescentar,QuantidadeAcrescentar) + Copy(Texto,PosicaoInicial,TamanhoDesejado);
       Result := AnsiUpperCase(Texto);
    end;
    function CalcularFatorVencimento(DataDesejada : TDateTime) : string;
    {O fator de vencimento é a quantidade de dias entre 07/Nov/1997 e a data de vencimento do título}
    begin
       Result := IntToStr( Trunc(DataDesejada - EncodeDate(1997,10,07)));
    end;
    ///////////// Fim - retirados do componente da GBSoft
    
    function CorrigeSTR(Str : string; CaracTroca : string; CaracNovo : string) : string;
    var i, int : integer;
    S : string;
    begin
    i := 0;
    int := 0;
     while i <= length(str) do
     begin
      if copy(Str,i,1) = CaracTroca then
       begin
        Delete(Str,i,1);
        s := copy(Str,1,i-1) + CaracNovo + copy(Str,i , length(str) - i + 1);
        str := s;
        inc(i);
        inc(int);
       end;
     inc(i);
     end;
     if int <> 0 then
     result := s
     else
     result := str;
    end;
    
    Function StrZero(S: String; Tam: Integer): String;
    var
       wZeros : String;
       wCont  : Integer;
    begin
    wCont := 0;
    wZeros := '';
         for wCont := 1 to tam - length(s) do
             wZeros := '0' + wZeros;
       Result := wZeros + S;
    end;
    /////////////////Inicio - Função alterada do componente da GBSoft
    
    function GeraCodBarras(Banco, Moeda, AG, Operacao, Carteira, NNumero, Valor, Vencto: String):String;
    var
    AFatorVencimento, ACampoLivre, ACodigoBarras, ADigitoCodigoBarras : string;
    begin
       {Primeira parte do código de barras}
       AFatorVencimento := Formatar(CalcularFatorVencimento(StrToDate(Vencto)),4,false,'0');
       //Valor; {Formata o valor com 10 dígitos, incluindo as casas decimais, mas não mostra o ponto decimal}
       {Segunda parte do código de barras - Campo livre - Varia de acordo com o banco}
       ACampoLivre := StrZero(AG,4) +
                      StrZero(Carteira,3) +
                      StrZero(Operacao,7) +
                      StrZero(NNumero +  Modulo10(AG + Carteira + NNumero),11);
       {Calcula o dígito e completa o código de barras}
       ACodigoBarras := StrZero(Banco,3) +
                        StrZero(Moeda,1) +
                        StrZero(AFatorVencimento,4) +
                        StrZero(CorrigeSTR(Valor,',',''),10) +
                        ACampoLivre;
       ADigitoCodigoBarras := Modulo11(ACodigoBarras,9);
       if ADigitoCodigoBarras = '0' then
          ADigitoCodigoBarras := '1';
       Result := Copy(ACodigoBarras,1,4) + ADigitoCodigoBarras + Copy(ACodigoBarras,5,length(ACodigoBarras)-4);
    // *)
    end;
    
    function GeraLinhaDigitavel(Banco, Moeda, AG, Operacao, Carteira, NNumero, Valor, Vencto : string):String;
    var
       p1, p2, p3, p4, p5, p6,
       Campo1, Campo2, Campo3, Campo4, Campo5,
       Codigo : string;
    begin
      Codigo := GeraCodBarras(Banco, Moeda, AG, Operacao, Carteira, NNumero, Valor, Vencto);
       p1 := Copy(Codigo,1,4);
       p2 := Copy(Codigo,20,5);
       p3 := Modulo10(p1+p2);
       p4 := p1+p2+p3;
       p5 := Copy(p4,1,5);
       p6 := Copy(p4,6,5);
       Campo1 := p5+'.'+p6;
       {
          Campo 2 - composto pelas posiçoes 6 a 15 do campo livre
          e DV (modulo10) deste campo
       }
       p1 := Copy(Codigo,25,10);
       p2 := Modulo10(p1);
       p3 := p1+p2;
       p4 := Copy(p3,1,5);
       p5 := Copy(p3,6,6);
       Campo2 := p4+'.'+p5;
       {
          Campo 3 - composto pelas posicoes 16 a 25 do campo livre
          e DV (modulo10) deste campo
       }
       p1 := Copy(Codigo,35,10);
       p2 := Modulo10(p1);
       p3 := p1+p2;
       p4 := Copy(p3,1,5);
       p5 := Copy(p3,6,6);
       Campo3 := p4+'.'+p5;
       {
          Campo 4 - digito verificador do codigo de barras
       }
       Campo4 := Copy(Codigo,5,1);
       {
          Campo 5 - composto pelo valor nominal do documento, sem indicacao
          de zeros a esquerda e sem edicao (sem ponto e virgula). Quando se
          tratar de valor zerado, a representacao deve ser 000 (tres zeros).
       }
       Campo5 := Copy(Codigo,6,14);
       Result := Campo1 + ' ' + Campo2 + ' ' + Campo3 + ' ' + Campo4 + ' ' + Campo5;
    End;
    
    /////////////////Fim - Função alterada do componente da GBSoft
    {
    Vou dar o resultado da linha digitavel com os seguintes parametros:
    Banco = 623
    Moeda = 9 // 9 para real (creio que seja para a moeda local), e 0 para outras
    AG = 1
    Operacao = 27
    Carteira = 121
    NNumero = 0260279393
    
    Valor = 153,39
    Vencto = 21/09/2009
    Linha digitavel = 62390.00117 21000.002705 26027.939367 1 43670000015339
    Cod de barras = 62391436700000153390001121000002702602793936
    Obs.
    No rave reports o código de barras de nome "I2of5BarCode" é o código de barras do boleto
    ele está na guia "Bar Code" ele é o segundo item
    bem, o resto agora é voce colocar os valores da variavél as funcoes:
    GeraCodBarras e GeraLinhaDigitavel e exibi-las
    Separei as funções pois fica a critério da pessoa enviar o boleto com o código de barras ou informar somente a linha digitável (via fone por ex)
    Espero que tenham gostado.
    Atte:
    Felipe Leal
    }
    //-------------- 
    

    DELPHI - Ping com IdIcmpClient (Indy 10) - Plataformas aceitas: Win32, Win64, Android, OS X, iOS

    Reações: 


    // Corrigida em 14-06-2012 - Testada na mesma data
    
    
    unit Unit1;
    
    interface
    
    uses
      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
      IdBaseComponent, IdComponent // Objeto Base Indy
      , IdRawBase, IdRawClient, IdIcmpClient, // Objeto para Ping
      Dialogs, StdCtrls;
    
    type
      TForm1 = class(TForm)
        Button1: TButton;
        procedure Button1Click(Sender: TObject);
      private
        { Private declarations }
      public
        _PingOK : Boolean;
        procedure ICMPStatus(ASender: TObject; const AStatus: TIdStatus; const                 AStatusText: string);
        procedure ICMPReply(ASender: TComponent; const AReplyStatus: TReplyStatus);
    
        Function Ping(HostName: String): boolean;
        { Public declarations }
      end;
    
    var
      Form1: TForm1;
    
    implementation
    
    
    {$R *.dfm}
    procedure TForm1.ICMPReply(ASender: TComponent;
      const AReplyStatus: TReplyStatus);
    begin
      try
        if AReplyStatus.BytesReceived > 0 then    
        _PingOK := True
        else
        _PingOK := False;
      except
        _PingOK := False;
      end;
    end;
    
    
    procedure TForm1.ICMPStatus(ASender: TObject; const AStatus: TIdStatus;
      const AStatusText: string);
    begin
      Exit;
      try
        _PingOK := True;
      except
        _PingOK := False;
      end;
    end;
    
    Function TForm1.Ping(HostName: String): boolean;
    var
     ICMP : TIdIcmpClient;
    begin
    try
    
      ICMP := TIdIcmpClient.Create(Application);
      try
       ICMP.OnStatus       := Form1.ICMPStatus;
       ICMP.OnReply        := Form1.ICMPReply;
       ICMP.Host           := HostName;
       ICMP.ReceiveTimeout := 500;
       ICMP.port           := 80;
        {$IFDEF ANDROID}
         {$DEFINE LINUX}
           ICMP.Ping;
         {$UNDEF LINUX}
       {$ELSE}
         ICMP.Ping;
       {$ENDIF}
       Sleep(1);
       Application.ProcessMessages;
       Result := _PingOK;
      except
       result := false;
      end;
    
    finally
     FreeAndNil(ICMP);
    end;
    
    rnd;
    
    
    procedure TForm1.Button1Click(Sender: TObject);
    const
      Host = 'www.google.com.br';
    begin
     if Ping(Host) then
     showmessage(host + ' OK')
     else
      showmessage(host + ' ERR');
    end;
    
    end.
    //-------------
    

    DELPHI - Acesso ao ClipBoard

    Reações: 


    // ATLabs 02/06/2012
    
    // Lendo a area de transferencia do pc:
    // Declarar na USES:
    Clipbrd
    //Para acessar basta ler o objeto:
    
    ClipBoard.AsText;
    //ou
    ClipBoard.Assign(image1.picture);
    //----------------------
    

    sexta-feira, 1 de junho de 2012

    DELPHI - Validação de endereço de E-Mail

    Reações: 


    // ATLabs 01-06-2012
    function ValidaEnderecoEMailATLabs(S: String): Boolean;
    var
      X : String;
      I : Integer;
    begin
      Result := True;
      if S = '' then exit;
      i := 0;
      X := S;
      while (Pos('@', X) > 0) do
      begin
        X := StringReplace(X, '@', '', [rfIgnoreCase]);
        Inc(i);
      end;
      if  (Pos(' ', S) > 0) // Espaco
       or (Pos('@', S) = 0) // @
       or (Pos('.', S) = 0) // Ponto
       or (Copy(S, 1, 1) = '@') // Item antes do @
       or (Copy(S, Pos('@', S) + 1, 1) = '') // Item pos  @
       or (Copy(S, Pos('.', S) - 1, 1) = '@') // Item antes do .
       or (Copy(S, Pos('.', S) + 1, 1) = '') // Item Pos .
       or (Pos('.', Copy(S, Pos('@', S) + 1, Length(S))) = 0) // valida . depois do @
       or (I > 1) // I Conta a quantidade de @ no texto
       then
      begin
        Result := False;
        ShowMessage('O formato de endereço de E-Mail deve seguir o seguinte padrão: "usuario@dominio.ext". Cancelado.');
      end;
    end;
    //-----------------
    

    quinta-feira, 31 de maio de 2012

    DELPHI - Envio de E-Mail no Delphi (Indy 10) - Funciona com Servidor SSL

    Reações: 



    Site das DLL'S: https://indy.fulgan.com/SSL/

    // ATLabs 07/02/2013
    Uses
    // Declarar na seção uses
     , IdBaseComponent, IdComponent // Units Genéricas do Indy
     , IdIOHandler, IdIOHandlerSocket, IdIOHandlerStack, IdSSL, IdSSLOpenSSL // Objeto SSL
     , IdTCPConnection, IdTCPClient, IdExplicitTLSClientServerBase, IdMessageClient, IdSMTPBase, IdSMTP // Objeto SMTP
     , IdMessage // Objeto de Mensagem
     , IdAttachmentFile // Objeto de Arquivos Anexos
    
    // DLL'S para funcionamento da função: 
    // http://www.atlabs.com.br/blog/download/DLL_SSL_INDY.rar
    // OU DEMO + DLLS - Adicionado em 24-09-2012
    // 
    // http://www.atlabs.com.br/blog/download/DemoIndProject10_EnvioDeEmail_Mais_Dlls.rar
    //--------------------------------------------
    
    
    function EnviarEmail(aHost : String; aPort : Integer; aLogin, aSenha,aListaEmail, aAssunto, aCorpo : String; aAuth, aAuthSSL : Boolean) : Boolean;
    var
     AuthSSL : TIdSSLIOHandlerSocketOpenSSL;
     IdSMTP    : TIdSMTP;
     IdMessage : TIdMessage;
    Const
     ArqTeste = 'c:\teste.txt';
    begin
      Result:= False;
      IdSMTP    := TIdSMTP.Create(nil);
      IdMessage := TIdMessage.Create(nil);
      try
        IdSMTP.Host     := aHost;
        IdSMTP.Port     := aPort;
        IdSMTP.AuthType := satDefault;
        IdSMTP.Username := aLogin;
        IdSMTP.Password := aSenha;
        if aAuthSSL then
        begin
          AuthSSL                   := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
          IdSMTP.IOHandler          := AuthSSL;
          IdSMTP.UseTLS             := utUseImplicitTLS;
          AuthSSL.SSLOptions.Method := sslvSSLv3;
          AuthSSL.SSLOptions.Mode   := sslmClient;
        end;
        if aAuth then
          IdSMTP.AuthType := satDefault
        else
          IdSMTP.AuthType := satNone; 
        try
        IdSMTP.Connect;
        IdMessage.From.Address               := aLogin;
        IdMessage.Recipients.EMailAddresses  := aListaEmail;
        IdMessage.Subject                    := aAssunto;
        IdMessage.Body.Text:=                'Data/Hora: ' + FormatDateTime('dd/MM/yyyy HH:mm:ss', Now) +
                                             #13#10#13#10 +
                                             aCorpo;
        IdMessage.Body.SaveToFile(ArqTeste);
        IdMessage.MessageParts.Clear; // Limpa os anexos da lista
        TIdAttachmentFile.Create(IdMessage.MessageParts, TFileName(ArqTeste)); // adiciona anexo na lista, pode ser utilizado com looping
    
        IdSMTP.Send(IdMessage);
        ShowMessage('E-Mail Enviado com sucesso para: ' +  aListaEmail);
        except
          on E: Exception do
          begin
            ShowMessage('Erro ao enviar E-Mail:'+#13#10+e.Message);
            Exit;
          end;
        end;
      finally
        IdSMTP.Disconnect;
        FreeAndNil(IdSMTP);
        FreeAndNil(IdMessage);
        if AuthSSL <> nil then
        FreeAndNil(AuthSSL);
      end;
      Result:= True;
    end;
    
    procedure TForm1.Button1Click(Sender: TObject);
    begin
      EnviarEmail('smtp.gmail.com', 465, 'conta@gmail.com','senha','destinatario@gmail.com','Envio de email','CORPO DA MENSAGEM', True, True);
    end;
    
    /*TESTADO EM 14-06-2012*/
    //----------------------
    
    //Andre Santos 6 de junho de 2014 19:33//Fiz o teste com o Gmail e está OK.
    
    //Para funcionar com o HOTMAIL vc tem q mudar a seguinte linha: 
    
    //DE:
    
    //IdSMTP.UseTLS := utUseImplicitTLS;
    
    //PARA:
    IdSMTP.UseTLS := utUseExplicitTLS;
    
    //Para a mudança ficar automática eu acrescentei ao código, da //seguinte forma:
    
    if (copy(aLogin,pos('@',aLogin),Length(aLogin)) = '@hotmail.com') then
      IdSMTP.UseTLS := utUseExplicitTLS
    else
      IdSMTP.UseTLS := utUseImplicitTLS; 
    
    //Lembrando que o HOTMAIL utiliza as seguintes configurações:
    
    //Servidor SMTP: smtp.live.com
    
    //Porta: 25
    
    //Autenticação: True 
    
    //SSL: True 
    
    //Teste realizado: 06/06/2014 - Funcionando 
    
    //Utilizo os componentes INDY do DELPHI XE 5 - Andre Santos 6 de junho de 2014 19:33
    
    // E Caso precisem  
    
    Validação de endereço de email
    
    http://blog.atlabs.com.br/2012/06/validacao-de-endereco-de-e-mail.html  
    

    WINDOWS - Instalação do ODBC MySQL no windows 7 (x64)

    Reações: 



    // ATLabs 31-05-2012
    PQP... depois de madrugadas sem fazer funcionar esta merda!!! Consegui!! Fica ai pro futuro:


    Instalar o conector: mysql-connector-odbc-3[1].51.25-win32.msi


    Abrir o programa: C:\Windows\SysWOW64\odbcad32.exe

    Cadastrar as configurações do alias


    Simples assim.


    Nota: Continuar não usando o conector 5.1, não funciona para conexões com o delphi.
    //-----------------

    Max Gehringer