Lendo o XML com o TXMLDocument

begin
  vXMLDoc := TXMLDocument.Create(self);
  // le os dados do arquivo salvo
  vXMLDoc.LoadFromFile('c:\tempo\navcom\nfe\retConsLote_001c.xml');
  // ou simplesmente pega a string retWS que contem o XML retorno
  // vXMLDoc.xml.Add(retWS);
  // vXMLDoc.active = true;
 
  // ou para ler o arquivo do recibo da NFe
  motivo := vXMLDoc.DocumentElement.ChildNodes['xMotivo'].text;
  NodePai := vXMLDoc.DocumentElement.ChildNodes.FindNode('protNFe');
 
  // posiciona no primeiro item (o velho first);
  NodePai.ChildNodes.First;
 
  // repeat....until  (como o velho while condicao)
  // repete enquanto encontrar dados de protocolo no arquivo.
  repeat
     NodeSec := NodePai.ChildNodes.FindNode('infProt');
     chaveacesso := NodeSec.ChildNodes['chNFe'].text;
     protocolo := NodeSec.ChildNodes['nProt'].text;
     datahora := NodeSec.ChildNodes['dhRecbto'].text;
     motivo := NodeSec.ChildNodes['xMotivo'].text;
 
     // inserido aqui apenas para testar mostrando os dados no MEMO.
     //if protocolo  '' then
      Memo4.Lines.Add( chaveacesso+'-> '+protocolo+' ---- '+datahora+' - '+motivo );
 
     // esse seria o Next
     NodePai := NodePai.NextSibling;
 
  until NodePai = nil;
end;

Conferência Delphi 2010

Nesse ultima dia 26 de Outubro aconteceu em São Paulo-SP, mais uma Delphi Conferência; realizada pela Embarcadero; contando com a presença dos seus mais renomados colaboradores (David I, Andreano Lanusse,etc). Estive lá para conferir e, embora tenha participado das conferências on-line, ao vivo é sempre melhor e, o conteúdo é sempre variado; além de poder encontrar alguns amigos. Foram 08-09 horas de muita informação. Palestras interessantes; mostrando várias aplicações para o nosso Delphi.

Muitas novidades com o lançamento do novo  Delphi XE. Veja o vídeo do Andreano Lanusse em destaque aqui no site; entre outros disponíveis também no YouTube. Não vou entrar aqui em detalhes, mas, posso dizer que estou cada vez mais convencido que o Delphi tem se tornado cada vez mais, a melhor IDE de desenvolvimento; tendo como estrela agora, o novo DataSnap. Criar e consumir serviços Web virou brinquedo de criança.

Como definir seu próprio hotkey (Tecla Quente) com Delphi

Como definir seu próprio hotkey (Tecla Quente): 

Primeiro fixe a propriedade KeyPreview do Form para TRUE: 

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if (ssCtrl in Shift) and (chr(Key) in ['A', 'a']) then

ShowMessage('Ctrl-A');

end;

Impedir que o seu programa seja executado mais de uma vez com Delphi

Para impedir que o seu programa seja executado mais de uma vez, use a rotina abaixo. Se o

usuário tentar rodar o programa mais de uma vez, você tem a opção de fechar o programa, e o

programa já aberto será exibido. 

function IsWindowInMemory (WndTitle : String) : Boolean; 

var 

  hSem : THandle; 

  hWndMe : HWnd; 

begin 

  Result := False; 

  hSem := CreateSemaphore (nil, 0, 1, 'NomeDoSemaforo'); 

  if (hSem <> 0) and (GetLastError() = ERROR_ALREADY_EXISTS) then 

    begin 

      CloseHandle (hSem); 

      hWndMe := FindWindow (nil, PChar (WndTitle)); 

      SetWindowText (hWndMe, 'ii7it89lihtf'); 

      hWndMe := FindWindow (nil, PChar (WndTitle)); 

      if hWndMe <> 0 then 

        begin 

          if IsIconic (hWndMe) then 

            ShowWindow (hWndMe, SW_SHOWNORMAL) 

          else 

            SetForegroundWindow (hWndMe); 

        end; 

      Result := True; 

    end; 

end; 

  

E, no evento OnCreate do form principal, coloque as seguintes linhas: 

  

if IsWindowInMemory (Self.Caption) then 

  Halt; 

  

Apagando pastas com tudo dentro com Delphi

Para apagar uma pasta com todas as suas subpastas e arquivos, utilize a rotina abaixo

procedure ProcuraEApaga (Arq, Dir : String); 

var 

  F : TSearchRec; 

  S : String; 

begin 

  if Dir [length (Dir)] <> '\' then 

    Dir := Dir + '\'; 

  S := Dir + '*.*'; 

  if FindFirst (S, faAnyFile, F) = 0 then 

    if (F.Attr = faDirectory) then 

      begin 

        if (F.Name <> '.') and (F.Name <> '..') then 

          Procura (Arq, Dir + F.Name) 

      end 

    else 

      if (F.Name = Arq) then 

        DeleteFile (Dir + Arq); 

end; 

Alterando a Data do windows com Delphi

function SystemDateTime (tDate: TDateTime; tTime: TDateTime): Boolean; 

var 

  tSetDate: TDateTime; 

  vDateBias: Variant; 

  tSetTime: TDateTime; 

  vTimeBias: Variant; 

  tTZI: TTimeZoneInformation; 

  tST: TSystemTime; 

begin 

  GetTimeZoneInformation(tTZI); 

  vDateBias := tTZI.Bias / 1440; 

  tSetDate := tDate + vDateBias; 

  vTimeBias := tTZI.Bias / 1440; 

  tSetTime := tTime + vTimeBias; 

  with tST do 

    begin 

      wYear := StrToInt(FormatDateTime('yyyy', tSetDate)); 

      wMonth := StrToInt(FormatDateTime('mm', tSetDate)); 

      wDay := StrToInt(FormatDateTime('dd', tSetDate)); 

      wHour := StrToInt(FormatDateTime('hh', tSettime)); 

      wMinute := StrToInt(FormatDateTime('nn', tSettime)); 

      wSecond := StrToInt(FormatDateTime('ss', tSettime)); 

      wMilliseconds := 0; 

    end; 

  SystemDateTime := SetSystemTime(tST); 

end; 

Adicionar barra de rolagem horizontal no ListBox com Delphi

Adicionar barra de rolagem horizontal no ListBox

{ - Coloque um ListBox no form;

  - Altere o OnCreate do Form conforme abaixo:

}

procedure TForm1.FormCreate(Sender: TObject);

var

  I, Temp, MaxTextWidth: integer;

begin

  { Adiciona algumas linhas no ListBox }

  Listbox1.Items.Add('Linha 1');

  Listbox1.Items.Add('Linha 2, longa para que seja necessária a barra de rolagem horizontal');

  Listbox1.Items.Add('Linha 3');

  if Listbox1.Items.Count > 1 then begin

    { Obtém o comprimento, em pixels, da linha mais longa }

    MaxTextWidth := 0;

    for I := 0 to Listbox1.Items.Count - 1 do begin

      Temp := ListBox1.Canvas.TextWidth(ListBox1.Items[I]);

      if Temp > MaxTextWidth then

        MaxTextWidth := Temp;

    end;

    { Acrescenta a largura de um "W" }

    MaxTextWidth := MaxTextWidth + Listbox1.Canvas.TextWidth('W');

    { Envia uma mensagem ao ListBox }

    SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxTextWidth, 0);

  end;

end;

{ Para ocultar use a instrução abaixo: }

SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, 0, 0);

Obtendo versão de um .exe com Delphi

Obtendo as informações de versão dos arquivos 

Um dos recursos disponibilizados pelo Delphi é a customização das informações de versão a serem "anexadas" na linkagem.

Pouco utilizado, este recurso é muito interessante, pois possibilita o cadastro de diversas informações sobre o arquivo gerado, como: número de versão, nome do produto, nome interno do arquivo, nome da empresa, etc.

Podemos alterar as informações na página "Version Info", da página "Project Options":

Atenção com o item "Auto-increment build number": ele só será incrementado automaticamente quando for executada a opção "Build All" para compilar o projeto.

Porém, não existem rotinas "prontas" para obtermos estas informações. É necessário fazermos chamadas diretamente a API Win32, mais espeficamente, para as funções como a "GetFileVersionInfo" e a "VerQueryValue".

A função, a "FileVerInfo", que exemplifica o processo de obtenção das informações. Ela irá retornar "True" caso o arquivo informado no parâmetro "FileName" possuir as informações de versão, e devolverá por referência um "TStringList" contendo as informações.

uses

    Windows, Messages, SysUtils, Classes, Graphics, Controls, 

    Forms, Dialogs, StdCtrls;

type

    TForm1 = class(TForm)

      Memo1: TMemo;

      Button1: TButton;

      procedure Button1Click(Sender: TObject);

    end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

function FileVerInfo(const FileName: string;

                      var FileInfo: TStringList): Boolean;

const

     Key: array[1..9] of string =('CompanyName', 'FileDescription',

  'FileVersion',

     'InternalName', 'LegalCopyright',

     'OriginalFilename', 'ProductName',

     'ProductVersion', 'Comments');

  KeyBr: array [1..9] of string = ('Empresa',

    'Descricao', 'Versao do Arquivo',

    'Nome Interno', 'Copyright', 

    'Nome Original do Arquivo', 'Produto', 

    'Versao do Produto', 'Comentarios');

var

  Dummy : THandle;

  BufferSize, Len : Integer;

  Buffer : PChar;

  LoCharSet, HiCharSet : Word;

  Translate, Return : Pointer;

  StrFileInfo, Flags : string;

  TargetOS, TypeArq : string;

  FixedFileInfo : Pointer;

  i : Byte;

begin

  Result := False;

  { Obtemos o tamanho em bytes do "version  information" }

  BufferSize := GetFileVersionInfoSize(PChar(FileName), Dummy);

  if BufferSize <> 0 then

  begin

    GetMem(Buffer, Succ(BufferSize));

    try

      if GetFileVersionInfo(PChar(FileName), 0, BufferSize,

        Buffer) then

      { Executamos a funcao "VerQueryValue" e conseguimos

        informacoes sobre o idioma/character-set }

      if VerQueryValue(Buffer, '\VarFileInfo\Translation',

          Translate, UINT(Len)) then 

      begin

        LoCharSet := LoWord(Longint(Translate^));

        HiCharSet := HiWord(Longint(Translate^));

        for i := 1 to 9 do

        begin

          { Montamos a string de pesquisa }

          StrFileInfo := Format('\StringFileInfo\0%x0%x\%s',

                         [LoCharSet, HiCharSet, Key[i]]);

          { Adicionamos cada key pré-definido }

          if VerQueryValue(Buffer,PChar(StrFileInfo), Return, 

             UINT(Len)) then

          FileInfo.Add(KeyBr[i] + ': ' + PChar(Return));

        end;

        if VerQueryValue(Buffer,'\',FixedFileInfo, UINT(Len))

          then

          with TVSFixedFileInfo(FixedFileInfo^) do

        begin

          Flags := '';

          {Efetuamos um bitmask e obtemos os "flags" do arquivo}

        if (dwFileFlags and VS_FF_DEBUG) = VS_FF_DEBUG then

            Flags := Concat(Flags,'*Debug* ');

        if (dwFileFlags and VS_FF_SPECIALBUILD) =

            VS_FF_SPECIALBUILD then

                 Flags := Concat(Flags, '*Special Build* ');

        if (dwFileFlags and VS_FF_PRIVATEBUILD) =

            VS_FF_PRIVATEBUILD then

                 Flags := Concat(Flags, '*Private Build* ');

        if (dwFileFlags and VS_FF_PRERELEASE) =

            VS_FF_PRERELEASE then

                 Flags := Concat(Flags, '*Pre-Release Build* ');

        if (dwFileFlags and VS_FF_PATCHED) = VS_FF_PATCHED then

                  Flags := Concat(Flags, '*Patched* ');

        if Flags <> '' then FileInfo.Add('Atributos: ' + Flags);

        TargetOS := 'Plataforma (OS): ';

        { Plataforma }

        case dwFileOS of

          VOS_UNKNOWN : 

            TargetOS := Concat(TargetOS, 'Desconhecido');

          VOS_DOS : 

            TargetOS := Concat(TargetOS, 'MS-DOS');

          VOS_OS216 : 

            TargetOS := Concat(TargetOS, '16-bit OS/2');

          VOS_OS232 : 

            TargetOS := Concat(TargetOS, '32-bit OS/2');

          VOS_NT    : 

            TargetOS := Concat(TargetOS, 'Windows NT');

          VOS_NT_WINDOWS32, 4: 

            TargetOS := Concat(TargetOS, 'Win32 API');

          VOS_DOS_WINDOWS16: 

            TargetOS := Concat(TargetOS, '16-bit Windows ',

            'sob MS-DOS');

          else

             TargetOS := Concat(TargetOS, 'Fora do Padrão.

                          Código: ', IntToStr(dwFileOS));

       end;

        FileInfo.Add(TargetOS);

        TypeArq := 'Tipo de Arquivo: ';

        { Tipo de Arquivo }

        case dwFileType of

          VFT_UNKNOWN : 

            TypeArq := Concat(TypeArq,'Desconhecido');

          VFT_APP : TypeArq := Concat(TypeArq,'Aplicacao');

          VFT_DLL : 

TypeArq := Concat(TypeArq,'Dynamic-Link Lib.');

          VFT_DRV : begin

            TypeArq := Concat(TypeArq,'Device driver - Driver ');

            case dwFileSubtype of

              VFT2_UNKNOWN

                : TypeArq := Concat(TypeArq,'Desconhecido');

              VFT2_DRV_PRINTER

                : TypeArq := Concat(TypeArq,'de Impressao');

              VFT2_DRV_KEYBOARD

                : TypeArq := Concat(TypeArq,'de Teclado');

              VFT2_DRV_LANGUAGE

                : TypeArq := Concat(TypeArq,'de Idioma');

              VFT2_DRV_DISPLAY

                : TypeArq := Concat(TypeArq,'de Vídeo');

              VFT2_DRV_MOUSE

                : TypeArq := Concat(TypeArq,'de Mouse');

              VFT2_DRV_NETWORK

                : TypeArq := Concat(TypeArq,'de Rede');

              VFT2_DRV_SYSTEM

                : TypeArq := Concat(TypeArq,'de Sistema');

              VFT2_DRV_INSTALLABLE

                : TypeArq := Concat(TypeArq,'Instalavel');

              VFT2_DRV_SOUND

                : TypeArq := Concat(TypeArq,'Multimida');

            end;

          end;

          VFT_FONT : begin

            TypeArq := Concat(TypeArq,'Fonte - Fonte ');

            case dwFileSubtype of

              VFT2_UNKNOWN

                : TypeArq := Concat(TypeArq, 'Desconhecida');

              VFT2_FONT_RASTER

                : TypeArq := Concat(TypeArq,'Raster');

              VFT2_FONT_VECTOR

                : TypeArq := Concat(TypeArq,'Vetorial');

              VFT2_FONT_TRUETYPE

                : TypeArq := Concat(TypeArq,'TrueType');

            end;

          end;

          VFT_VXD : TypeArq := Concat(TypeArq,'Virtual Device');

          VFT_STATIC_LIB

            : TypeArq := Concat(TypeArq,'Static-Link Lib.');

        end;

        FileInfo.Add(TypeArq);

      end;

    end;

    finally

      FreeMem(Buffer, Succ(BufferSize));

      Result := FileInfo.Text <> '';

    end;

  end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

   StrLst: TStringList;

begin

  StrLst := TStringList.Create;

  try

    FileVerInfo('C:\WINDOWS\SYSTEM\TAPI.DLL', StrLst);

    Memo1.Lines.Assign(StrLst);

  finally

    StrLst.Free;

  end;

end; 

 

Verificar se um diretório existe com Delphi

Verificar se um diretório existe

Inclua na seção uses: FileCtrl, Dialogs

if DirectoryExists('C:\MEUSDOCS') then

  ShowMessage('O diretório existe')

else

  ShowMessage('O diretório não existe'); 

Verificar se um arquivo existe com Delphi

Verificar se um arquivo existe

Inclua na seção uses:  SysUtils, Dialogs

if FileExists('c:\carta.doc') then

  ShowMessage('O arquivo existe')

else

  ShowMessage('O arquivo não existe');

Colocar zero a esquerda em Delphi

function RetZeroEsquerda(ZEROS:string;QUANT: integer):String;

var

   I,Tamanho: integer;

   aux: string;

begin

  aux:=zeros;

  Tamanho:=length(ZEROS);

  ZEROS:='';

    for I:=1 to quant-tamanho do

        ZEROS:=ZEROS+'0';

  aux:=zeros+aux;

  RetZeroEsquerda:=aux;

end;

Função para retirar somente números de uma string em Delphi

Declare na Seção.

  private

     Function SoNumero(Texto : String) : String;

     Function IsDigit(Texto : string) : Boolean;

Depois da directiva de compilação.

{$R *.dfm}

Function TFrmExportacaoContabilidade.SoNumero(Texto : String) : String;

var

Ind    : Integer;

TmpRet : String;

begin

TmpRet := '';

for Ind := 1 to Length(Texto) do

    begin

    if IsDigit(Copy(Texto,Ind,1)) then

       begin

       TmpRet := TmpRet + Copy(Texto, Ind, 1);

       end;

    end;

Result := TmpRet;

end;

function TFrmExportacaoContabilidade.IsDigit(Texto: string): boolean;

begin

 result := true;

 try

    StrToInt(Texto);

 except

    result := false;

 end;

end;

Trocar vírgula por ponto em Delphi

function TrocaVirgPPto(Valor: string): String;

   var i:integer;

begin

    if Valor <> '' then begin

        for i := 0 to Length(Valor) do begin

            if Valor[i]='.' then begin

                Valor[i]:=',';

            end

            else if Valor[i] = ',' then begin

                Valor[i]:='.';

            end;

        end;

     end;

     Result := valor;

end;