ACBR Exibindo o MD5 No campo de Informações Complementares do Danfe

Para Exibir o  MD5 do PAF-ECF no campo de informações complementares do Danfe no componente ACBR é muito simples, basta informar na propriedade InfAdic da Nfe.


ACBrNFe1.NotasFiscais.Items[0].NFe.InfAdic.infAdFisco := MD5; 


Veja no exemplo abaixo:

var

  Nfe: string;

begin

  Nfe := DirNFeXMLs + '\' + 
Numero  + '.xml';



  if not FileExists(Nfe) then

    raise Exception.Create('XML da Nota não encontrado');



  ACBrNFe1.NotasFiscais.Clear;

  ACBrNFe1.NotasFiscais.LoadFromFile(Nfe);

  if ACBrNFe1.NotasFiscais.Items[0].NFe.Ide.tpEmis = teDPEC then

  begin

    ACBrNFe1.WebServices.ConsultaDPEC.NFeChave := ACBrNFe1.NotasFiscais.Items[0].NFe.infNFe.ID;

    ACBrNFe1.WebServices.ConsultaDPEC.Executar;

    ACBrNFe1.DANFE.ProtocoloNFe := ACBrNFe1.WebServices.ConsultaDPEC.nRegDPEC + ' ' + DateTimeToStr(ACBrNFe1.WebServices.ConsultaDPEC.dhRegDPEC);

  end;

  ACBrNFe1.NotasFiscais.Items[0].NFe.InfAdic.infAdFisco := 
MD5 ;

  ACBrNFe1.NotasFiscais.Imprimir;



end;

E a impressão no Danfe:

Criando um tipo de dado Avançado em Delphi - Parte 5

Dando sequência a serie de artigos Criando um tipo de dado Avançado em Delphi (confira aqui a parte1 a parte 2  a parte 3 e a parte 4 ), iremos implementar hoje a unit untTEAMSystem que ira conter um tipo de dado que executa operações do sistema, como  retornar a versão do executável, abrir um diretório com o explorer, abrir um arquivo com o notepad.

Abra o Delphi (neste artigo fora utilizado o Delphi 2007) e adicione uma nova unit e salve-a como untTEAMSystem :

  Adicione os tipos a seguir:

TEAMAplication = record
  private

  public
    function GetVersionInfo: string;
    function FileVersionInfo(Arquivo: string): string;
    procedure AbrirArquivoComNotePad(path: string);
    procedure AbrirExplorer(path: string);
    function DiretorioAplicacao: string;
    function ExecAndWait(const FileName, Params: string; const WindowState:
      Word): boolean;
    function ListarArquivos(Diretorio, Extencao: string; SubDiretorio: Boolean): TStringList;
    function ListarNomesArquivos(Diretorio, Extencao: string; SubDiretorio: Boolean): TStringList;
    function AppIsRunning(ActivateIt: boolean): Boolean;
    function CriaSubDiretorios(const NomeSubDir: string): boolean;
    function GetLocalUserName: string;
    function LastModify: string;
  end;

Como você pode observar não temos nenhum campo value, por que este dado ira agrupar apenas métodos para operações da aplicação.
vamos a implementação:

unit untTEAMSystem;

interface

uses untTEAMString, Windows, SysUtils, dialogs, Forms, Graphics,
  Controls, ShellApi, Classes;

type

{$REGION 'Tipos'}
  SizeInt = Integer;
  TStatusControle = (Editar, Navegar);
{$ENDREGION}

{$REGION 'Aplicação - TEAMAplication'}
  TEAMAplication = record
  private

  public
    function GetVersionInfo: string;
    function FileVersionInfo(Arquivo: string): string;
    procedure AbrirArquivoComNotePad(path: string);
    procedure AbrirExplorer(path: string);
    function DiretorioAplicacao: string;
    function ExecAndWait(const FileName, Params: string; const WindowState:
      Word): boolean;
    function ListarArquivos(Diretorio, Extencao: string; SubDiretorio: Boolean): TStringList;
    function ListarNomesArquivos(Diretorio, Extencao: string; SubDiretorio: Boolean): TStringList;
    function AppIsRunning(ActivateIt: boolean): Boolean;
    function CriaSubDiretorios(const NomeSubDir: string): boolean;
    function GetLocalUserName: string;
    function LastModify: string;
  end;

{$ENDREGION}

const
  strWindowsNotepade: string = 'c:\windows\notepad.exe';
implementation

{ TCSTSystemExecute }

{-------------------------------------------------------------------------------
  Procedure: TEAMAplication.GetLocalUserName
   Arguments: None
  Result:    string
  Objetivo:  Retornar o usuario logado no windows
-------------------------------------------------------------------------------}

function TEAMAplication.GetLocalUserName: string;
  procedure StrResetLength(var S: AnsiString);
  var
    I: SizeInt;
  begin
    for I := 1 to Length(S) do
      if S[I] = #0 then
      begin
        SetLength(S, I);
        Exit;
      end;
  end;
var
  Count: DWORD;

begin
  Count := 256 + 1; // UNLEN + 1
  // set buffer size to 256 + 2 characters
  { TODO : Win2k solution }
  SetLength(Result, Count);
  if GetUserName(PChar(Result), Count) then
    StrResetLength(Result)
  else
    Result := '';
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMAplication.AbrirArquivoComNotePad
    Arguments: path: string
  Result:    None
  Objetivo:  Abrir um arquivo usando o notepad
-------------------------------------------------------------------------------}

procedure TEAMAplication.AbrirArquivoComNotePad(path: string);
begin
  ShellExecute(0, 'open', pchar(Strwindowsnotepade), pchar(path), nil, SW_MAXIMIZE);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMAplication.AbrirExplorer
   Arguments: path: string
  Result:    None
  Objetivo:  Abrir o Explorer mostrando uma pasta
-------------------------------------------------------------------------------}

procedure TEAMAplication.AbrirExplorer(path: string);
begin
  ShellExecute(Application.Handle, PChar('open'), PChar('explorer.exe'),
    PChar(path), nil, SW_NORMAL);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMAplication.AppIsRunning
  Arguments: ActivateIt: boolean
  Result:    Boolean
  Objetivo:  Verificar se há uma instancia da aplicação rodando
-------------------------------------------------------------------------------}

function TEAMAplication.AppIsRunning(ActivateIt: boolean): Boolean;
var
  hSem: THandle;
  hWndMe: HWnd;
  AppTitle: string;
begin
  Result := False;
  AppTitle := Application.Title;
  hSem := CreateSemaphore(nil, 0, 1, pChar(AppTitle));
  if ((hSem <> 0) and (GetLastError() = ERROR_ALREADY_EXISTS)) then
  begin
    CloseHandle(hSem);
    Result := True;
  end;
  if Result and ActivateIt then
  begin
    Application.Title := 'zzzzzzz';
    hWndMe := FindWindow(nil, pChar(AppTitle));
    if (hWndMe <> 0) then
    begin
      if IsIconic(hWndMe) then
      begin
        ShowWindow(hWndMe, SW_SHOWNORMAL);
      end
      else
      begin
        SetForegroundWindow(hWndMe);
      end;
    end;
  end;

end;

{-------------------------------------------------------------------------------
  Procedure: TEAMAplication.CriaSubDir
   Arguments: const NomeSubDir: string
  Result:    boolean
  Objetivo:  Criar um ou vários sub-diretórios
-------------------------------------------------------------------------------}

function TEAMAplication.CriaSubDiretorios(const NomeSubDir: string): boolean;
begin
  if DirectoryExists(NomeSubDir) then
    Result := true
  else
    Result := ForceDirectories(NomeSubDir);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMAplication.DiretorioAplicacao
   Arguments: None
  Result:    string
  Objetivo:  Retornar o diretório da aplicação
-------------------------------------------------------------------------------}

function TEAMAplication.DiretorioAplicacao: string;
begin
  result := ExtractFilePath(Application.ExeName);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMAplication.ExecAndWait
  Arguments: const FileName, Params: string; const WindowState: Word
  Result:    boolean
  Objetivo:  Execultar e esperar o termino da execução de um exe
-------------------------------------------------------------------------------}

function TEAMAplication.ExecAndWait(const FileName, Params: string;
  const WindowState: Word): boolean;
var
  SUInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  CmdLine: string;
begin
  { Coloca o nome do arquivo entre aspas. Isto é necessário devido aos espaços contidos em nomes longos }
  CmdLine := '"' + Filename + '"' + Params;
  FillChar(SUInfo, SizeOf(SUInfo), #0);
  with SUInfo do
  begin
    cb := SizeOf(SUInfo);
    dwFlags := STARTF_USESHOWWINDOW;
    wShowWindow := WindowState;
  end;
  Result := CreateProcess(nil, PChar(CmdLine), nil, nil, false,
    CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,
    PChar(ExtractFilePath(Filename)), SUInfo, ProcInfo);
  { Aguarda até ser finalizado }
  if Result then
  begin
    WaitForSingleObject(ProcInfo.hProcess, INFINITE);
    { Libera os Handles }
    CloseHandle(ProcInfo.hProcess);
    CloseHandle(ProcInfo.hThread);
  end;

end;

function TEAMAplication.FileVersionInfo(Arquivo: string): string;
begin
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMAplication.GetVersionInfo
  Arguments: None
  Result:    string
  Objetivo:  Retornar a versao da aplicação
-------------------------------------------------------------------------------}

function TEAMAplication.GetVersionInfo: string;

type
  PFFI = ^vs_FixedFileInfo;
var
  F: PFFI;
  Handle: Dword;
  Len: Longint;
  Data: Pchar;
  Buffer: Pointer;
  Tamanho: Dword;
  Parquivo: Pchar;
  Arquivo: string;
begin
  Arquivo := Application.ExeName;
  Parquivo := StrAlloc(Length(Arquivo) + 1);
  StrPcopy(Parquivo, Arquivo);
  Len := GetFileVersionInfoSize(Parquivo, Handle);
  Result := '';
  if Len > 0 then
  begin
    Data := StrAlloc(Len + 1);
    if GetFileVersionInfo(Parquivo, Handle, Len, Data) then
    begin
      VerQueryValue(Data, '\', Buffer, Tamanho);
      F := PFFI(Buffer);
      Result := Format('%d.%d.%d.%d',
        [HiWord(F^.dwFileVersionMs),
        LoWord(F^.dwFileVersionMs),
          HiWord(F^.dwFileVersionLs),
          Loword(F^.dwFileVersionLs)]
          );
    end;
    StrDispose(Data);
  end;
  StrDispose(Parquivo);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMAplication.LastModify
  Arguments: None
  Result:    string
  Objetivo:  Retornar a data da ultima modificação do execultavel
-------------------------------------------------------------------------------}

function TEAMAplication.LastModify: string;
var
  FileH: THandle;
  LocalFT: TFileTime;
  DosFT: DWORD;
  LastAccessedTime: TDateTime;
  FindData: TWin32FindData;

begin

  Result := '';

  FileH := FindFirstFile(PChar(Application.ExeName), FindData);

  if FileH <> INVALID_HANDLE_VALUE then
  begin

    //    Windows.FindClose(nil);

    if (FindData.dwFileAttributes and

      FILE_ATTRIBUTE_DIRECTORY) = 0 then

    begin

      FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFT);

      FileTimeToDosDateTime(LocalFT, LongRec(DosFT).Hi, LongRec(DosFT).Lo);

      LastAccessedTime := FileDateToDateTime(DosFT);

      Result := DateTimeToStr(LastAccessedTime);

    end;

  end;
end;

{-------------------------------------------------------------------------------
 Procedure: TEAMAplication.ListarArquivos
 Arguments: Diretorio, Extencao: string; SubDiretorio: Boolean
 Result:    TStringList
 Objetivo:  Listar os arquivo contidos em um diretório e/ou Subdiretório
-------------------------------------------------------------------------------}

function TEAMAplication.ListarArquivos(Diretorio, Extencao: string;
  SubDiretorio: Boolean): TStringList;
  function TemAtributo(Attr, Val: Integer): Boolean;
  begin
    Result := (Attr and Val = Val);
  end;
var
  F: TSearchRec;
  Ret: Integer;
  TempNome: string;
begin

  Result := TStringList.Create;

  Ret := FindFirst(Diretorio + '\*.*', faAnyFile, F);
  try
    while Ret = 0 do
    begin
      if TemAtributo(F.Attr, faDirectory) then
      begin
        if (F.Name <> '.') and (F.Name <> '..') then
          if SubDiretorio then
          begin
            TempNome := Diretorio + '\' + F.Name;
            Result.AddStrings(ListarArquivos(TempNome, Extencao, True));
          end;
      end
      else
      begin
        if Pos(Extencao, LowerCase(f.Name)) > 0 then
          Result.Add(Diretorio + '\' + F.Name);
      end;
      Ret := FindNext(F);
    end;
  finally
    begin
      FindClose(F);
    end;
  end;

end;

{-------------------------------------------------------------------------------
  Procedure: TEAMAplication.ListarNomesArquivos
  Arguments: Diretorio, Extencao: string; SubDiretorio: Boolean
  Result:    TStringList
  Objetivo:  Lista todos os arquivos de um diretório de acordo com a extenção
-------------------------------------------------------------------------------}

function TEAMAplication.ListarNomesArquivos(Diretorio, Extencao: string;
  SubDiretorio: Boolean): TStringList;
var
  I: Integer;
  Arq: TEAMString;
begin
  result := self.ListarArquivos(Diretorio, Extencao, SubDiretorio);

  for I := 0 to result.Count - 1 do
  begin
    Arq.text := Result[i];
    Result[i] := Arq.SubString(arq.SearchRigth('\') + 1, arq.Count + 1);
  end;
end;
{$ENDREGION}


end.

Adicione alguns edits e um TlistBox para o formulário de teste como abaixo:

Adicione o seguinte código no onCLick do botão "ok" :

procedure TForm1.btn1Click(Sender: TObject);
var
  APP : TEAMAplication;
begin
  edtGetVersionInfo.Text := APP.GetVersionInfo;
  edtDiretorioAplicacao.Text := APP.DiretorioAplicacao;
  edtGetLocalUserName.Text := APP.GetLocalUserName;
  lstListarArquivos.Items.Text := APP.ListarArquivos('c:\windows\system32','.dll',False).Text;
end  ;

Execute a aplicação e observe o resultado:

Assim finalizamos está série de posts. Analisamos e apreciamos todo o poder do record em pascal, organizamos mais o nosso código e ganhamos em produtividade. Aprendemos que não precisamos de dezenas de units com várias funções em vários lugares, podemos centralizar tudo em uma unica unit organizada, salva-la em um diretório e apenas adiciona-la ao projeto em que estamos trabalhando e usar.

Agora aproveite para exercitar o seu poder de programador para melhorar alguns métodos e adicionar novos e não deixe de nos enviar o seu código. "Compartilhar atrai amigos. Competir atrai inimigos"

Criando um tipo de dado Avançado em Delphi - Parte 4

Dando sequência a serie de artigos Criando um tipo de dado Avançado em Delphi (confira aqui a parte1 a parte 2  e a parte 3 ), iremos implementar hoje a unit untTEAMDateTime que ira conter os tipos para se trabalhar com Date, Time e DateTime.

Abra o Delphi (neste artigo fora utilizado o Delphi 2007) e adicione uma nova unit e salve-a como untTEAMDateTime:

  Adicione os tipos a seguir:

unit untTEAMDateTime;

interface

uses untTEAMString, untTEAMNumeric, DateUtils, SysUtils, Controls;

type

{$REGION 'TCSTDate '}

TCSTDate = record
  public
    Value: TDateTime;  

  end;

{$ENDREGION}

{$REGION 'TCSTTime'}

  TEAMTime = record
  public
    Value: TDateTime;  
  end;

{$ENDREGION}

implementation

end.

O campo "Value" nos dois records ira armazenar o conteúdo do nosso dado para que possamos aplicar as operações.
Como fizemos na unit untTEAMNumeric, vamos aproveitar aqui também os tipos TEAMString da untTEAMString e o TEAMInteger da untTEAMNumeric em alguns métodos. Vamos a listagem:

$REGION ' TEAMDate'}
  TEAMDate = record
  public
    Value: TDateTime;

    function ToString: TEAMString;
    function ToSqlServerFormat: TEAMString;
    function Date: TDate;
    function Formatar(Formato: string): TEAMString;
    function ToExtenco: TEAMString;
    function MesToExtenco: TEAMString;
    function DiaDaSemanaExtenco: TEAMString;
    function GetDia: TEAMinteger;
    function GetMes: TEAMinteger;
    function GetAno: TEAMinteger;
    function GetDiaSemana: TEAMinteger;
    function GetPrimeiroDiaMes: TEAMinteger;
    function GetUltimoDiaMes: TEAMinteger;
    procedure ADDMes(Meses: Integer);
    function DiasNoMes: TEAMinteger;
    function isAnoBiSexto: Boolean;
    function isFimDeSemana: Boolean;
    function INDates(DataInicial, DataFinal: Tdate): Boolean;
    procedure AddDias(NumDias: Integer);
    procedure SubDias(NumDias: Integer);
    procedure Encode(Dia, mes, ano: Word);
    procedure EncodeFromString(Data: string);
    procedure ReplaceTimer;
    procedure SetDateNow;

  end;
{$ENDREGION}

{$REGION ' TEAMTime'}
  TEAMTime = record
  public
    Value: TDateTime;
    function ToString: TEAMString;
    function DataHoraString: TEAMString;
    function Formatar(Formato: string): TEAMString;
    function GetHora: TEAMString;
    function GetMinutos: TEAMString;
    function GetSegundos: TEAMString;
    function ToExtenco: TEAMString;
    function ToMinutos: Integer;
  end;
{$ENDREGION}

A maioria dos métodos para Data/Hora estão presentes. Alguns muitos úteis como retornar o último dia do mês, adicionar dias a data, verificar se a data é final de semana, etc. Sinta-se a vontade para adicionar outros que achar nescessário. O próximo passo é a implementação dos métodos.
Veja a listagem completa da nossa unit:

unit untTEAMDateTime;

interface

uses untTEAMString, untTEAMNumeric, DateUtils, SysUtils, Controls;

type
{$REGION ' TEAMDate'}
  TEAMDate = record
  public
    Value: TDateTime;

    function ToString: TEAMString;
    function ToSqlServerFormat: TEAMString;
    function Date: TDate;
    function Formatar(Formato: string): TEAMString;
    function ToExtenco: TEAMString;
    function MesToExtenco: TEAMString;
    function DiaDaSemanaExtenco: TEAMString;
    function GetDia: TEAMinteger;
    function GetMes: TEAMinteger;
    function GetAno: TEAMinteger;
    function GetDiaSemana: TEAMinteger;
    function GetPrimeiroDiaMes: TEAMinteger;
    function GetUltimoDiaMes: TEAMinteger;
    procedure ADDMes(Meses: Integer);
    function DiasNoMes: TEAMinteger;
    function isAnoBiSexto: Boolean;
    function isFimDeSemana: Boolean;
    function INDates(DataInicial, DataFinal: Tdate): Boolean;
    procedure AddDias(NumDias: Integer);
    procedure SubDias(NumDias: Integer);
    procedure Encode(Dia, mes, ano: Word);
    procedure EncodeFromString(Data: string);
    procedure ReplaceTimer;
    procedure SetDateNow;

  end;
{$ENDREGION}

{$REGION ' TEAMTime'}
  TEAMTime = record
  public
    Value: TDateTime;
    function ToString: TEAMString;
    function DataHoraString: TEAMString;
    function Formatar(Formato: string): TEAMString;
    function GetHora: TEAMString;
    function GetMinutos: TEAMString;
    function GetSegundos: TEAMString;
    function ToExtenco: TEAMString;
    function ToMinutos: Integer;
  end;
{$ENDREGION}

implementation

{$REGION 'TEAMDate'}
{ TEAMDate }

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.AddDias
   Arguments: NumDias: Integer
  Result:    None
  Objetivo:  Adicionar dias para a data
-------------------------------------------------------------------------------}

procedure TEAMDate.AddDias(NumDias: Integer);
begin
  Self.Value := IncDay(Self.Value, NumDias);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.INDates
  Arguments: DataInicial, DataFinal: Tdate
  Result:    Boolean
  Objetivo:  Testar se uma data está em um intervalo
-------------------------------------------------------------------------------}

function TEAMDate.INDates(DataInicial, DataFinal: Tdate): Boolean;
begin
  Result := ((CompareDate(Self.Value, DataInicial) >= 0)
    and (CompareDate(Self.Value, DataFinal) <= 0));
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.DiaDaSemanaExtenco
  Arguments: None
  Result:    TEAMString
  Objetivo:  Retornar o dia em extenço
-------------------------------------------------------------------------------}

function TEAMDate.DiaDaSemanaExtenco: TEAMString;
const
  semana: array[1..7] of string = ('Domingo', 'Segunda-feira', 'Terça-feira', 'Quarta-feira', 'Quinta-feira', 'Sexta-feira', 'Sábado');
begin
  Result.Text := semana[DayOfWeek(Self.Value)]
end;

function TEAMDate.Date: TDate;
begin
  result := Self.Value;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.DiasNoMes
  Arguments: None
  Result:    Integer
  Objetivo:  Retornar o numero de dias no mes
-------------------------------------------------------------------------------}

function TEAMDate.DiasNoMes: TEAMinteger;
const
  DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
  Result.Value := DaysInMonth[Self.GetMes.Value];
  if (Self.GetMes.Value = 2) and Self.isAnoBiSexto then
    Inc(Result.Value);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.Encode
  Arguments: Ano mes e dia
  Result:    nenhum
  Objetivo:  Transforma o dia,mes e ano em uma data
-------------------------------------------------------------------------------}

procedure TEAMDate.Encode(Dia, mes, ano: Word);
begin
  Self.Value := EncodeDate(ano, mes, dia);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.EncodeFromString
  Arguments: Data: string
  Result:    None
  Objetivo:  Conveter uma string para uma data
-------------------------------------------------------------------------------}

procedure TEAMDate.EncodeFromString(Data: string);
begin
  Self.Value := StrToDate(data);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.Formatar
  Arguments: Formato: string
  Result:    TEAMString
  Objetivo:  Retornar a data formatada de acordo com o parametro passado
-------------------------------------------------------------------------------}

function TEAMDate.Formatar(Formato: string): TEAMString;
begin
  Result.Text := FormatDateTime(Formato, Self.Value);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.GetAno
  Arguments: None
  Result:    Integer
  Objetivo:  Retornar o ano
-------------------------------------------------------------------------------}

function TEAMDate.GetAno: TEAMinteger;
var
  ano, mes, dia: Word;
begin
  DecodeDate(Self.Value, ano, mes, dia);
  Result.Value := ano;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.GetDia
  Arguments: None
  Result:    Integer
  Objetivo:  Retornar o dia
-------------------------------------------------------------------------------}

function TEAMDate.GetDia: TEAMinteger;
var
  ano, mes, dia: Word;
begin
  DecodeDate(Self.Value, ano, mes, dia);
  Result.Value := dia;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.GetDiaSemana
  Arguments: None
  Result:    Integer
  Objetivo:  Retornar o dia da semana
-------------------------------------------------------------------------------}

function TEAMDate.GetDiaSemana: TEAMinteger;
begin
  Result.Value := DayOfTheWeek(Self.Value)
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.GetMes
  Arguments: None
  Result:    Integer
  Objetivo:  Retornar o mes da data
-------------------------------------------------------------------------------}

function TEAMDate.GetMes: TEAMinteger;
var
  ano, mes, dia: Word;
begin
  DecodeDate(Self.Value, ano, mes, dia);
  Result.Value := mes;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.GetPrimeiroDiaMes
  Arguments: Nenhum
  Result:    Nenhum
  Objetivo:  Retornar o primeiro dia do mes
-------------------------------------------------------------------------------}

function TEAMDate.GetPrimeiroDiaMes: TEAMinteger;
begin
  Result.Value := 1;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.GetUltimoDiaMes
  Arguments: Nenhum
  Result:    Nenhum
  Objetivo:  Retornar o ultimo dia do mes
-------------------------------------------------------------------------------}

function TEAMDate.GetUltimoDiaMes: TEAMinteger;
var
  ano, mes, dia: word;
  temp: TDate;
begin
  DecodeDate(Self.Value, ano, mes, dia);

  mes := mes + 1;
  if mes = 13 then
  begin
    mes := 1;
    ano := ano + 1;
  end;
  temp := EncodeDate(ano, mes, 1) - 1;

  Result.Value := DayOf(temp);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.ADDMes
  Arguments: Meses: Integer
  Result:    None
  Objetivo:  Adicionar um numero de meses a data
-------------------------------------------------------------------------------}

procedure TEAMDate.ADDMes(Meses: Integer);
begin
  Self.Value := IncMonth(Self.Value, Meses);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.isAnoBiSexto
  Arguments: None
  Result:    Boolean
  Objetivo:  Retornar se o ano é bissexto
-------------------------------------------------------------------------------}

function TEAMDate.isAnoBiSexto: Boolean;
begin
  Result := (Self.GetAno.Value mod 4 = 0) and ((Self.GetAno.Value mod 100 <> 0) or (Self.GetAno.Value mod 400 = 0));
end;

{-------------------------------------------------------------------------------
 Procedure: TEAMDate.isFimDeSemana
  Arguments: None
  Result:    Boolean
  Objetivo:  Retorna se a data é um fim de semana
-------------------------------------------------------------------------------}

function TEAMDate.isFimDeSemana: Boolean;

{Verifica se uma data informada cai em um final de semana}
begin
  if DayOfWeek(Self.Value) in [1, 7] then
    result := true
  else
    result := false;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.MesToExtenco
  Arguments: None
  Result:    TEAMString
  Objetivo:  Retornar o mês por extenco
-------------------------------------------------------------------------------}

function TEAMDate.MesToExtenco: TEAMString;
begin
  case Self.GetMes.Value of
    1: Result.Text := 'Janeiro';
    2: Result.Text := 'Fevereiro';
    3: Result.Text := 'Março';
    4: Result.Text := 'Abril';
    5: Result.Text := 'Maio';
    6: Result.Text := 'Junho';
    7: Result.Text := 'Julho';
    8: Result.Text := 'Agosto';
    9: Result.Text := 'Setembro';
    10: Result.Text := 'Outubro';
    11: Result.Text := 'Novembro';
    12: Result.Text := 'Dezembro';
  else
    Result.Text := '';
  end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.ReplaceTimer
  Arguments: None
  Result:    None
  Objetivo:  Apaga a hora
-------------------------------------------------------------------------------}

procedure TEAMDate.ReplaceTimer;
var
  newTime: TDateTime;
begin
  newTime := EncodeTime(0, 0, 0, 0);
  ReplaceTime(self.Value, newTime);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.SetDateNow
  Arguments: None
  Result:    None
  Objetivo:  seta a dataHora para o horario atual
-------------------------------------------------------------------------------}

procedure TEAMDate.SetDateNow;
begin
  Self.Value := Now;
end;
{-------------------------------------------------------------------------------
 Procedure: TEAMDate.SubDias
 Arguments: NumDias: Integer
 Result:    None
 Objetivo:  Subtrair um numero de dias da data
-------------------------------------------------------------------------------}

procedure TEAMDate.SubDias(NumDias: Integer);
begin
  NumDias := (NumDias * -1);
  Self.AddDias(NumDias);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.ToExtenco
  Arguments: None
  Result:    TEAMString
  Objetivo:  Retornar a data por extenço
-------------------------------------------------------------------------------}

function TEAMDate.ToExtenco: TEAMString;
begin
  Result.Text := FormatDateTime('dddddd', Self.Value);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.ToString
  Arguments: None
  Result:    TEAMString
  Objetivo:  Retornar a data em string
-------------------------------------------------------------------------------}

function TEAMDate.ToString: TEAMString;
begin
  Result.Text := DateToStr(Self.Value);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDate.ToSqlServerFormat
  Arguments: None
  Result:    TEAMString
  Objetivo:  Converter para o formato de data do sqlServer
-------------------------------------------------------------------------------}

function TEAMDate.ToSqlServerFormat: TEAMString;
begin
  Result.Text := FormatDateTime('YYYY-MM-DD', Self.Value);
end;

{$ENDREGION}

{$REGION 'TEAMTime'}
{ TEAMTime }

{-------------------------------------------------------------------------------
  Procedure: TEAMTime.DataHoraString
  Arguments: None
  Result:    TEAMString
  Objetivo:  Retorna a data e a hora em uma string
-------------------------------------------------------------------------------}

function TEAMTime.DataHoraString: TEAMString;
begin
  Result.Text := DateTimeToStr(Self.Value);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMTime.Formatar
  Arguments: Formato: string
  Result:    TEAMString
  Objetivo:  Formata a hora de acordo com o formato passado
-------------------------------------------------------------------------------}

function TEAMTime.Formatar(Formato: string): TEAMString;
begin
  Result.Text := FormatDateTime(Formato, Self.Value);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMTime.GetHora
  Arguments: None
  Result:    TEAMString
  Objetivo:  Retorna a hora
-------------------------------------------------------------------------------}

function TEAMTime.GetHora: TEAMString;
var
  hora, minutos, segundos, mcsegundos: Word;
begin
  Decodetime(Self.Value, hora, minutos, segundos, mcsegundos);
  Result.Text := intToStr(hora);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMTime.GetMinutos
  Arguments: None
  Result:    TEAMString
  Objetivo:  Retorna os minutos
-------------------------------------------------------------------------------}

function TEAMTime.GetMinutos: TEAMString;
var
  hora, minutos, segundos, mcsegundos: Word;
begin
  Decodetime(Self.Value, hora, minutos, segundos, mcsegundos);
  Result.Text := intToStr(minutos);

end;

{-------------------------------------------------------------------------------
  Procedure: TEAMTime.GetSegundos
  Arguments: None
  Result:    TEAMString
  Objetivo:  Retorna os segundos
-------------------------------------------------------------------------------}

function TEAMTime.GetSegundos: TEAMString;
var
  hora, minutos, segundos, mcsegundos: Word;
begin
  Decodetime(Self.Value, hora, minutos, segundos, mcsegundos);
  Result.Text := intToStr(segundos);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMTime.ToString
  Arguments: None
  Result:    TEAMString
  Objetivo:  Converte para string
-------------------------------------------------------------------------------}

function TEAMTime.ToString: TEAMString;
begin
  Result.Text := TimeToStr(Self.Value);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMTime.ToExtenco
  Arguments: None
  Result:    TEAMString
  Objetivo:  Retorna a hora em extenço
-------------------------------------------------------------------------------}

function TEAMTime.ToExtenco: TEAMString;
var
  Hora, Minuto, Segundo: TEAMinteger;

begin
  Hora.Value := self.GetHora.ToInt;
  Minuto.Value := self.GetMinutos.Toint;
  Segundo.Value := self.GetSegundos.Toint;

  Result.Text := Hora.ToExtenco.Text + ' hora';
  if Hora.Value > 1 then
    Result.Text := Result.Text + 's';
  if Minuto.Value > 0 then
  begin
    Result.Text := Result.Text + ', ' + Minuto.ToExtenco.Text + ' minuto';
    if Minuto.Value > 1 then
      Result.Text := Result.Text + 's'
  end;

  if Segundo.Value > 0 then
  begin
    Result.Text := Result.Text + ' e ' + Segundo.ToExtenco.Text + ' segundo';
    if Segundo.Value > 1 then
      Result.Text := Result.Text + 's'
  end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMTime.ToMinutos
  Arguments: None
  Result:    Integer
  Objetivo:  Converte Para Minutos
-------------------------------------------------------------------------------}

function TEAMTime.ToMinutos: Integer;
begin
  Result := (StrToInt(Copy(Self.ToString.Text, 1, 2)) * 60) + StrToInt(Copy(Self.ToString.Text, 4, 2));
end;

{$ENDREGION}

end.

Agora podemos iniciar o testes. Adione a unit untTEAMDateTime ao formulário:

unit untTEAMDateTime;  

Adicione alguns edits e um botão como abaixo:

No ovento onClick do botão escreva o seguinte código:

procedure TForm1.btn1Click(Sender: TObject);
var
  EAMDateTime: TEAMDate;
  EAMTime: TEAMTime;
begin
  EAMDateTime.SetDateNow;

  edtValue.Text := EAMDateTime.ToString.Text;
  edtToExtenco.Text := EAMDateTime.ToExtenco.Text;
  edtGetDia.Text := EAMDateTime.GetDia.ToString.Text;
  edtGetMes.Text := EAMDateTime.GetMes.ToString.Text;
  edtGetAno.Text := EAMDateTime.GetAno.ToString.Text;
  edtGetUltimoDiaMes.Text := EAMDateTime.GetUltimoDiaMes.ToString.Text;
  edtHashDateTime.Text := EAMDateTime.ToString.Hash;


  EAMTime.Value := Now;

  edtTimeValue.Text := EAMTime.Formatar('HH:MM:SS').Text;
  edtTimeToExtenco.Text := EAMTime.ToExtenco.Text;
  edtGetSegundos.Text := EAMTime.GetSegundos.Text;
  edtGetHora.Text := EAMTime.GetHora.Text;
  edtGetMinutos.Text := EAMTime.GetMinutos.Text;
   edtHashTime.Text := EAMTime.ToString.Hash;
end     

Execute e confira o resultado:

Todos os métodos da listagem foram documentados para facilitar o entendimento da sua finalidade. Fique a vontade para adicionar novos métodos e procedures. :)

Confira aqui  o próximo post

Observação: Algumas das procedure e functions usadas neste artigo são uma compilação de códigos encontrados na internet. se você encontrar aqui algum código de sua autoria, entre em contato para que possamos dar-lhe o devido crédito.

Criando um tipo de dado Avançado em Delphi - Parte 3

Dando sequência a serie de artigos Criando um tipo de dado Avançado em Delphi (confira aqui a parte1 e a parte 2 ), vamos implementar dois tipos numéricos: o TEAMDouble e o TEAMInteger (o nome é sugestivo) . Estes tipos vão nos ajudar  a trabalhar com os tipos inteiro e Double.

Abra o Delphi (neste artigo fora utilizado o Delphi 2007) e adicione uma nova unit e salve-a como untTEAMNumeric:

  Adicione os dois tipos a seguir:

unit untTEAMNumeric;

interface

uses SysUtils, Math, Graphics, Classes, UniTEAMString, WinTypes;

type

  TEAMDouble = record
    Value: Double;
  end;

  TEAMInteger = record
    Value: Integer;
  end;

implementation

end.

O campo "Value" nos dois records ira armazenar o conteúdo do nosso dado para que possamos aplicar as operações. Repare no uses a unit untTEAMNumeric, iremos usar o tipo TEAMString em alguns campos. veja a listagem:

 

TEAMDouble = record
    Value: Double;
    function Arredonda(inCasas: Integer): Double;
    function Trunca(inCasas: Integer): Double;
    function CalcularPercentual(Percent: Real): real;
    function CalculaProporcao(Valor: Real): Real;
    procedure CodigoBarras(Imagem: TCanvas);
    function ToString: TEAMString;
    function ToSqlServerFormat: TEAMString;
    function ToExtenco: TEAMString;
    function ToExtencoReais: TEAMString;
    function ToReias: TEAMString;
    procedure ADD(valor: Double);
    procedure inc;
    procedure Dec;
    procedure Clear;
    procedure Eval(Num: string);
  end;

  TEAMInteger = record
    Value: Integer;
    function ToString: TEAMString;
    function ToExtenco: TEAMString;
    procedure inc;
    procedure ADD(valor: integer);
    function NextValue: integer;
    function PriorValue: integer;
    procedure Dec;
    procedure Clear;
  end;

Retornar um TCSTString nos dara mais flexibilidade como veremos mais adiante. O próximo passo é a implementação dos métodos.
Veja a listagem completa da nossa unit:

unit untTEAMNumeric;

interface

uses SysUtils, Math, Graphics, Classes, untTEAMString, WinTypes;

type

  TEAMDouble = record
    Value: Double;
    function Arredonda(inCasas: Integer): Double;
    function Trunca(inCasas: Integer): Double;
    function CalcularPercentual(Percent: Real): real;
    function CalculaProporcao(Valor: Real): Real;
    procedure CodigoBarras(Imagem: TCanvas);
    function ToString: TEAMString;
    function ToSqlServerFormat: TEAMString;
    function ToExtenco: TEAMString;
    function ToExtencoReais: TEAMString;
    function ToReias: TEAMString;
    procedure ADD(valor: Double);
    procedure inc;
    procedure Dec;
    procedure Clear;
    procedure Eval(Num: string);
  end;

  TEAMInteger = record
    Value: Integer;
    function ToString: TEAMString;
    function ToExtenco: TEAMString;
    procedure inc;
    procedure ADD(valor: integer);
    function NextValue: integer;
    function PriorValue: integer;
    procedure Dec;
    procedure Clear;
  end;
implementation

resourcestring
  strNumeroForaIntervalo = 'TEAMDouble: O valor está fora do intervalo' +
    ' permitido.';

const
  Unidades: array[1..9] of string = ('Um', 'Dois', 'Tres', 'Quatro', 'Cinco', 'Seis', 'Sete', 'Oito', 'Nove');
  Dez: array[1..9] of string = ('Onze', 'Doze', 'Treze', 'Quatorze', 'Quinze', 'Dezesseis', 'Dezessete', 'Dezoito', 'Dezenove');
  Dezenas: array[1..9] of string = ('Dez', 'Vinte', 'Trinta', 'Quarenta', 'Cinquenta', 'Sessenta', 'Setenta', 'Oitenta', 'Noventa');
  Centenas: array[1..9] of string = ('Cento', 'Duzentos', 'Trezentos', 'Quatrocentos', 'Quinhentos', 'Seiscentos', 'Setecentos', 'Oitocentos', 'Novecentos');
  MoedaSigular = 'Real';
  MoedaPlural = 'Reais';
  CentSingular = 'Centavo';
  CentPlural = 'Centavos';
  Zero = 'Zero';

  { TEAMDouble }

{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.ADD
  Arguments: valor: Double
  Result:    None
  Objetivo:  Adicioonar um valor
-------------------------------------------------------------------------------}

procedure TEAMDouble.ADD(valor: Double);
begin
  Self.Value := Self.Value + valor;
end;
{-------------------------------------------------------------------------------
    Procedure: TEAMDouble.Arredonda
    Arguments: inCasas: Integer
    Result:    Double
    Objetivo:  Arrendondar o valor de accordo com o numero de casas decimais
  -------------------------------------------------------------------------------}

function TEAMDouble.Arredonda(inCasas: Integer): Double;
var
  stValor: string;
  dlValor: Double;
begin
  dlValor := Value + (5 * Power(10, -(inCasas + 1)));
  stValor := Floattostr(dlValor);
  if pos(',', stvalor) = 0 then
    stValor := stValor + ',';
  stvalor := stvalor + '0000';
  stValor := Copy(stValor, 1, pos(',', stValor) + inCasas);
  Result := StrToFloat(stValor);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.CalculaProporcao
  Arguments: Valor: Real
  Result:    Real
  Objetivo:  Calcular a proporção do valor no numero passado
-------------------------------------------------------------------------------}

function TEAMDouble.CalculaProporcao(Valor: Real): Real;
begin
  Result := ((Self.Value * 100) / Valor);
end;

{-------------------------------------------------------------------------------
 Procedure: TEAMDouble.CalcularPercentual
 Arguments: Percent: Real
 Result:    real
 Objetivo:  Calcular o percent do
-------------------------------------------------------------------------------}

function TEAMDouble.CalcularPercentual(Percent: Real): real;
begin
  percent := percent / 100;
  result := value * Percent;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.Clear
  Arguments: None
  Result:    None
  Objetivo:  inicializa  valor
-------------------------------------------------------------------------------}

procedure TEAMDouble.Clear;
begin
  Self.Value := 0;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.CodigoBarras
  Arguments: var Imagem: TCanvas
  Result:    None
  Objetivo:  Gerar o código de Barras do valor passado
-------------------------------------------------------------------------------}

procedure TEAMDouble.CodigoBarras(Imagem: TCanvas);
const
  digitos: array['0'..'9'] of string[5] = ('00110', '10001', '01001', '11000',
    '00101', '10100', '01100', '00011', '10010', '01010');
var
  s, codigo: string;
  i, j, x, t: Integer;
begin
  codigo := Self.ToString.Text;
  // Gerar o valor para desenhar o código de barras
  // Caracter de início
  s := '0000';
  for i := 1 to length(codigo) div 2 do
    for j := 1 to 5 do
      s := s + Copy(Digitos[codigo[i * 2 - 1]], j, 1) + Copy(Digitos[codigo[i * 2]], j, 1);
  // Caracter de fim
  s := s + '100';
  // Desenhar em um objeto canvas
  // Configurar os parâmetros iniciais
  x := 0;
  // Pintar o fundo do código de branco
  Imagem.Brush.Color := clWhite;
  Imagem.Pen.Color := clWhite;
  Imagem.Rectangle(0, 0, 2000, 79);
  // Definir as cores da caneta
  Imagem.Brush.Color := clBlack;
  Imagem.Pen.Color := clBlack;
  // Escrever o código de barras no canvas
  for i := 1 to length(s) do
  begin
    // Definir a espessura da barra
    t := strToInt(s[i]) * 2 + 1;
    // Imprimir apenas barra sim barra não (preto/branco - intercalado);
    if i mod 2 = 1 then
      Imagem.Rectangle(x, 0, x + t, 79);
    // Passar para a próxima barra
    x := x + t;
  end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.Dec
  Arguments: None
  Result:    None
  Objetivo:  Decementa o valor em 1
-------------------------------------------------------------------------------}

procedure TEAMDouble.Dec;
begin
  self.Value := Self.Value - 1;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.Eval
  Arguments: Num: string
  Result:    None
  Objetivo:  Converte uma string para um double
-------------------------------------------------------------------------------}

procedure TEAMDouble.Eval(Num: string);
begin
  if Trim(num) <> '' then
    Self.Value := StrToFloat(Num)
  else
    self.value := 0;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.inc
  Arguments: None
  Result:    None
  Objetivo:  Incrementa o valor
-------------------------------------------------------------------------------}

procedure TEAMDouble.inc;
begin
  self.Value := Self.Value + 1;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.ToExtenco
  Arguments: None
  Result:    TEAMString
  Objetivo:  Converte o valor para extenço
-------------------------------------------------------------------------------}

function TEAMDouble.ToExtenco: TEAMString;
var
  Texto, Milhar, Centena, Centavos: string;

  function ifs(Expressao: Boolean; CasoVerdadeiro, CasoFalso: string): string;
  begin
    if Expressao then
      Result := CasoVerdadeiro
    else
      Result := CasoFalso;
  end;

  function MiniExtenso(trio: string): string;
  var
    Unidade, Dezena, Centena: string;
  begin
    Unidade := '';
    Dezena := '';
    Centena := '';
    if (trio[2] = '1') and (trio[3] <> '0') then
    begin
      Unidade := Dez[strtoint(trio[3])];
      Dezena := '';
    end
    else
    begin
      if trio[2] <> '0' then
        Dezena := Dezenas[strtoint(trio[2])];
      if trio[3] <> '0' then
        Unidade := Unidades[strtoint(trio[3])];
    end;
    if (trio[1] = '1') and (Unidade = '') and (Dezena = '') then
      Centena := 'Cem'
    else if trio[1] <> '0' then
      Centena := Centenas[strtoint(trio[1])]
    else
      Centena := '';
    Result := Centena + ifs((Centena <> '') and ((Dezena <> '') or (Unidade <> '')), ' e ', '')
      + Dezena + ifs((Dezena <> '') and (Unidade <> ''), ' e ', '') + Unidade;
  end;

begin
  if (self.value > 999999.99) or (self.value < 0) then
  begin
    raise Exception.Create(strNumeroForaIntervalo);
  end;
  if self.value = 0 then
  begin
    Result.Text := '';
    Exit;
  end;
  Texto := formatfloat('000000.00', self.value);
  Milhar := MiniExtenso(Copy(Texto, 1, 3));
  Centena := MiniExtenso(Copy(Texto, 4, 3));
  Centavos := MiniExtenso('0' + Copy(Texto, 8, 2));
  Result.Text := Milhar;
  if Milhar <> '' then
  begin
    Result.Text := Result.Text + ' Mil ';
  end;
  if (((copy(texto, 4, 2) = '00') and (Milhar <> '') and (copy(texto, 6, 1) <> '0'))) or (centavos = '') and (milhar <> '') then
    Result.Text := Result.Text + ' e ';
  if (Milhar + Centena <> '') then
    Result.Text := Result.Text + Centena;

  if Centavos = '' then
  begin
    Exit;
  end
  else
  begin
    if Milhar + Centena = '' then
      Result.Text := Centavos
    else
      Result.Text := Result.Text + ' e ' + Centavos;
  end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.ToExtencoReais
  Arguments: None
  Result:    TEAMString
  Objetivo:  Converte o valor para extenço em reais
-------------------------------------------------------------------------------}

function TEAMDouble.ToExtencoReais: TEAMString;
var
  Texto, Milhar, Centena, Centavos: string;
  ////////////////////////////////fucao auxiliar extenso////////////////////////////////
  function ifs(Expressao: Boolean; CasoVerdadeiro, CasoFalso: string): string;
  begin
    if Expressao then
      Result := CasoVerdadeiro
    else
      Result := CasoFalso;
  end;
  ////////////////////////////funcao auxiliar extenso/////////////////////////
  function MiniExtenso(trio: string): string;
  var
    Unidade, Dezena, Centena: string;
  begin
    Unidade := '';
    Dezena := '';
    Centena := '';
    if (trio[2] = '1') and (trio[3] <> '0') then
    begin
      Unidade := Dez[strtoint(trio[3])];
      Dezena := '';
    end
    else
    begin
      if trio[2] <> '0' then
        Dezena := Dezenas[strtoint(trio[2])];
      if trio[3] <> '0' then
        Unidade := Unidades[strtoint(trio[3])];
    end;
    if (trio[1] = '1') and (Unidade = '') and (Dezena = '') then
      Centena := 'Cem'
    else if trio[1] <> '0' then
      Centena := Centenas[strtoint(trio[1])]
    else
      Centena := '';
    Result := Centena + ifs((Centena <> '') and ((Dezena <> '') or (Unidade <> '')), ' e ', '')
      + Dezena + ifs((Dezena <> '') and (Unidade <> ''), ' e ', '') + Unidade;
  end;

begin
  if (self.value > 999999.99) or (self.value < 0) then
  begin
    raise Exception.Create(strNumeroForaIntervalo);
  end;
  if self.value = 0 then
  begin
    Result.Text := '';
    Exit;
  end;
  Texto := formatfloat('000000.00', self.value);
  Milhar := MiniExtenso(Copy(Texto, 1, 3));
  Centena := MiniExtenso(Copy(Texto, 4, 3));
  Centavos := MiniExtenso('0' + Copy(Texto, 8, 2));
  Result.Text := Milhar;
  if Milhar <> '' then
  begin
    if copy(texto, 4, 3) = '000' then
      Result.Text := Result.Text + ' Mil Reais'
    else
      Result.Text := Result.Text + ' Mil ';
  end;
  if (((copy(texto, 4, 2) = '00') and (Milhar <> '') and (copy(texto, 6, 1) <> '0'))) or (centavos = '') and (milhar <> '') then
    Result.Text := Result.Text + ' e ';
  if (Milhar + Centena <> '') then
    Result.Text := Result.Text + Centena;
  if (Milhar = '') and (copy(texto, 4, 3) = '001') then
    Result.Text := Result.Text + ' Real'
  else if (copy(texto, 4, 3) <> '000') then
    Result.Text := Result.Text + ' Reais';
  if Centavos = '' then
  begin
    Result.Text := Result.Text + '.';
    Exit;
  end
  else
  begin
    if Milhar + Centena = '' then
      Result.Text := Centavos
    else
      Result.Text := Result.Text + ' e ' + Centavos;
  end;
  if (copy(texto, 8, 2) = '01') and (Centavos <> '') then
    Result.Text := Result.Text + ' Centavo.'
  else
    Result.Text := Result.Text + ' Centavos.';

end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.ToReias
  Arguments: None
  Result:    TEAMString
  Objetivo:  Formata o valor para dinheiro
-------------------------------------------------------------------------------}

function TEAMDouble.ToReias: TEAMString;
begin
  Result.Text := FormatFloat('R$ 0.,00', Self.Value);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.ToString
  Arguments: None
  Result:    string
  Objetivo:  Converter para no formato para ser garvado no  sqlsrever
-------------------------------------------------------------------------------}

function TEAMDouble.ToSqlServerFormat: TEAMString;
var
  Aux: TEAMString;
begin
  Aux.Text := FloatToStr(Self.Value);
  Result.Text := Aux.ReplaceChar(',', '.');
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.ToString
  Arguments: None
  Result:    TEAMString
  Objetivo:  Converte o Valor para uma string
-------------------------------------------------------------------------------}

function TEAMDouble.ToString: TEAMString;
begin
  Result.Text := FloatToStr(Self.Value);
end;
{-------------------------------------------------------------------------------
  Procedure: TEAMDouble.Trunca
  Arguments: inCasas: Integer
  Result:    Double
  Objetivo:  Truncar o valor com determinado numero de casas decimais
-------------------------------------------------------------------------------}

function TEAMDouble.Trunca(inCasas: Integer): Double;
var
  stValor: string;
begin
  stValor := Floattostr(Value);
  if pos(',', stvalor) = 0 then
    stValor := stValor + ',';
  stvalor := stvalor + '0000';
  stValor := Copy(stValor, 1, pos(',', stValor) + inCasas);
  Result := StrToFloat(stValor);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMInteger.ADD
  Arguments: valor: integer
  Result:    None
  Objetivo:  Incrementa o valor  em 1
-------------------------------------------------------------------------------}

procedure TEAMInteger.ADD(valor: integer);
begin
  Self.Value := self.Value + valor;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMInteger.Clear
  Arguments: None
  Result:    None
  Objetivo:  Apaga o conteudo
-------------------------------------------------------------------------------}

procedure TEAMInteger.Clear;
begin
  Self.Value := 0;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMInteger.Dec
  Arguments: None
  Result:    None
  Objetivo:  Decrementa o valor em 1
-------------------------------------------------------------------------------}

procedure TEAMInteger.Dec;
begin
  Self.Value := Self.Value - 1;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMInteger.inc
  Arguments: None
  Result:    None
  Objetivo:  incrementa o valor em 1
-------------------------------------------------------------------------------}

procedure TEAMInteger.inc;
begin
  Self.Value := Self.Value + 1;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMInteger.NextValue
  Arguments: None
  Result:    integer
  Objetivo:  Retorna qual será o próximo valor
-------------------------------------------------------------------------------}

function TEAMInteger.NextValue: integer;
begin
  Result := self.Value + 1;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMInteger.PriorValue
  Arguments: None
  Result:    integer
  Objetivo:  Retorna qual será o valor anterior
-------------------------------------------------------------------------------}

function TEAMInteger.PriorValue: integer;
begin
  result := self.value - 1;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMInteger.ToExtenco
  Arguments: None
  Result:    TEAMString
  Objetivo:  Converte o valor para extenço
-------------------------------------------------------------------------------}

function TEAMInteger.ToExtenco: TEAMString;
var
  Num: TEAMDouble;
begin
  Num.Value := Self.Value;
  Result := Num.ToExtenco;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMInteger.ToString
  Arguments: None
  Result:    TEAMString
  Objetivo:  Converte o valor para string
-------------------------------------------------------------------------------}

function TEAMInteger.ToString: TEAMString;
begin
  Result.Text := IntToStr(Self.Value);
end;

end.

Vamos aos teste: adicione alguns edits e um botão como abaixo

Adicione a unit untTEAMNumeric ao formulário:

unit untTEAMNumeric;

No ovento onClick do botão escreva o seguinte código:

procedure TForm1.btn1Click(Sender: TObject);
var
  EAMDouble:TEAMDouble;
  EAMInteger:TEAMInteger;
begin
 EAMDouble.Value := 99.989;
 EAMInteger.Value := 88;

  edtValorDouble.Text := EAMDouble.ToString.Text;
  edtArredonda.Text := FloatToStr(EAMDouble.Arredonda(1));
  edtTrunca.Text := FloatToStr(EAMDouble.Trunca(2));
  edtSqlServerFormat.Text := EAMDouble.ToSqlServerFormat.Text;
  edtExtencoReias.Text := EAMDouble.ToExtencoReais.Text;
  edtCalculaPercentual.Text := FloatToStr(EAMDouble.CalcularPercentual(50));

  edtValorInteger.Text := EAMInteger.ToString.Text;
  edtToString.Text := EAMInteger.ToString.Text;
  edtPriorValue.Text := IntToStr(EAMInteger.PriorValue);
  edtNextValue.Text := IntToStr(EAMInteger.NextValue);
  edtToExtencoInteger.Text := EAMInteger.ToExtenco.Text;


end;

Execute e confira o resultado:

Adicionar o tipo TEAMString nos novos tipos que criamos, nos fez poupar algum tempo nas conversões dos dados, isso sem mencionar que poderíamos realizar outras operações como realizar um hash.
Como exemplo adicone mais 2 edits no formulário de teste e o seguinte código no evento onClick do botão :

edtHashInteger.Text := EAMInteger.ToString.Hash;
 edtHashDouble.Text := EAMDouble.ToString.Hash;

Execute e confira o resultado:

Todos os métodos da listagem foram documentados para facilitar o entendimento da sua finalidade. Fique a vontade para adicionar novos métodos e procedures. :)

Observação: Algumas das procedure e functions usadas neste artigo são uma compilação de códigos encontrados na internet. se você econtrar aqui algum código de sua autoria, entre em contato para que possamos dar-lhe o devido crédito.

Confira aqui o próximo post

Criando um tipo de dado Avançado em Delphi - Parte 2

No post anterior você conferiu como podemos usar o record do pascal apartir do Delphi 2006 para criar um tipo de dado mais avançado, que nos permitia agrupar as principais operações com string em um único tipo.
Agora vamos dar sequência ao artigo adicionando novas operações para o nosso dado:

TEAMString = record
    Text: string;

     { Substituição}
    function ReplaceChar(Caracter, Subst: char): string;

    {Remove os Espaços em branco }
    function Alltrim: string;
    function LTrim: string;
    function RTrim: string;

    {Conversão}
    function Lower: string;
    function Upper: string;
    function CaixaMista: string;

    {Pesquisa um caractere }
    function SearchLeft(Caracter: string): integer;
    function SearchRigth(Caracter: string): integer;

    {Variaveis}
    function Count: integer;
    function IsEmpty: Boolean;
    function Wordcount: integer;

    {Operações}
    function QuebraString(APosicao: Integer; ASeparador: string): string;
    function ReverseStr: string;
    function ToFloat: Double;
    function ToDateTime: TDateTime;
    function ToPChar: PChar;
    function ToFloatExtended: Extended;
    function ToCurrency: Currency;
    function ToCurrencyString: string;
    function ToInt: Integer;
    function ToCNPJCpf: string;
    function ToAspas: string;
    function ToCustomFormat(Mask: string): string;
    function Empty: string;

    function RemoveAcento: string;
    function RemoveChar(Caracter: char): string;
    function ReplicaChar(const Ch: Char; const Len: integer): string;
    function StrIntComZero(const Value, Len: integer): string;
    function Explode(const Ch: Char): TStringList;
    function ExplodeTrim(const Ch: Char): TStringList;
    function ExisteInt: Boolean;
    procedure StrResetLength(var S: AnsiString);
    function SubString(PosInicial, PosFinal: Integer): string;
    procedure Concate(Separador, Valor: string);
    procedure DeleteFinalText(Tam: Integer);
    function HashMD5: string;
    procedure ADD(s: string);
    procedure Clear;
    function ContemString(s: string): Boolean;
    procedure SetTextLength(Tam: integer);
    procedure ADDQuote(Separador, valor,Quote : string);

    function IsNumeric: Boolean;
    function IsFloat: Boolean;
    function IsInteger: Boolean;
    function IsDateTime: Boolean;

    { Operações PAD}
    function PadC(const Len: integer; const Ch: Char): string;
    function PadL(const Len: integer; const Ch: Char): string;
    function PadR(const Len: integer; const Ch: Char): string;

  end;

Repare que na nossa listagem temos funções para os mais variados fins, deste funções simples como apagar o conteúdo da string até uma função hash MD5 pronta pra ser usada.  Dessa forma agrupamos as operações com string em um só lugar, organizando melhor o nosso código e deixando-o muito mais legível!

Vamos a implementação dos métodos:

unit untTEAMString;

unit untTEAMString;

interface
   uses Classes,SysUtils, IdGlobal, IdHash, IdHashMessageDigest;
type
  TEAMString = record
    Text: string;

     { Substituição}
    function ReplaceChar(Caracter, Subst: char): string;

    {Remove os Espaços em branco }
    function Alltrim: string;
    function LTrim: string;
    function RTrim: string;

    {Conversão}
    function Lower: string;
    function Upper: string;
    function CaixaMista: string;

    {Pesquisa um caractere }
    function SearchLeft(Caracter: string): integer;
    function SearchRigth(Caracter: string): integer;

    {Variaveis}
    function Count: integer;
    function IsEmpty: Boolean;
    function Wordcount: integer;

    {Operações}
    function QuebraString(APosicao: Integer; ASeparador: string): string;
    function ReverseStr: string;
    function ToFloat: Double;
    function ToDateTime: TDateTime;
    function ToPChar: PChar;
    function ToFloatExtended: Extended;
    function ToCurrency: Currency;
    function ToCurrencyString: string;
    function ToInt: Integer;
    function ToCNPJCpf: string;
    function ToAspas: string;
    function ToCustomFormat(Mask: string): string;
    function Empty: string;

    function RemoveAcento: string;
    function RemoveChar(Caracter: char): string;
    function ReplicaChar(const Ch: Char; const Len: integer): string;
    function StrIntComZero(const Value, Len: integer): string;
    function Explode(const Ch: Char): TStringList;
    function ExplodeTrim(const Ch: Char): TStringList;
    function ExisteInt: Boolean;
    function SubString(PosInicial, PosFinal: Integer): string;
    procedure Concate(Separador, Valor: string);
    procedure DeleteFinalText(Tam: Integer);
    function HashMD5: string;
    procedure ADD(s: string);
    procedure Clear;
    function ContemString(s: string): Boolean;
    procedure SetTextLength(Tam: integer);
    procedure ADDQuote(Separador, valor,Quote : string);

    function IsNumeric: Boolean;
    function IsFloat: Boolean;
    function IsInteger: Boolean;
    function IsDateTime: Boolean;

    { Operações PAD}
    function PadC(const Len: integer; const Ch: Char): string;
    function PadL(const Len: integer; const Ch: Char): string;
    function PadR(const Len: integer; const Ch: Char): string;
  end;


{ TEAMString }

{$ENDREGION}


implementation



{$REGION 'TEAMString'}

{ TEAMString }


function TEAMString.SubString(PosInicial, PosFinal: Integer): string;
begin
  Result := Copy(Self.Text, PosInicial, PosFinal - PosInicial);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.Concate
  Arguments: Separador, Valor: string
  Result:    None
  Objetivo:  Concatenar uma valor passado a string separado por um caracter
-------------------------------------------------------------------------------}

procedure TEAMString.Concate(Separador, Valor: string);
begin
  if Self.Text = '' then
    Self.Text := Self.Text + Valor
  else
    Self.Text := Self.Text + Separador + Valor;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.ContemString
  Arguments: s: string
  Result:    Boolean
  Objetivo:  verifica se existe uma substring
-------------------------------------------------------------------------------}

function TEAMString.ContemString(s: string): Boolean;
begin
  Result := (Pos(s, Self.Text) > 0);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.Count
  Arguments: None
  Result:    integer
  Objetivo:  Retornar o tamanho da string
-------------------------------------------------------------------------------}

function TEAMString.Count: integer;
begin
  Result := Length(Self.Text);
end;


{-------------------------------------------------------------------------------
  Procedure: TEAMString.DeleteFinalText
  Arguments: Tam: Integer
  Result:    None
  Objetivo:  Apagar a ultima posicao da string
-------------------------------------------------------------------------------}
procedure TEAMString.DeleteFinalText(Tam: Integer);
begin
  Delete(Self.Text, (self.Count - Tam) + 1, Tam);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.CaixaMista
  Arguments: None
  Result:    None
  Objetivo:  Transforma a primeira letra dos nomes em Maiúscula
-------------------------------------------------------------------------------}

function TEAMString.CaixaMista: string;
var
  tam, pos1, pos2: integer;
  stPal, stTmp, stAux: string;
begin
  stAux := Self.Text;
  tam := Length(stAux);
  stAux := TrimRight(stAux) + ' ';
  stAux := AnsiUpperCase(stAux);
  while True do
  begin
    pos1 := POS(' ', stAux);
    if pos1 = 0 then
      break;
    stPal := Copy(stAux, 1, pos1);
    pos2 := pos(stPal, ' DA - DAS - DE - DO - DOS ');
    if pos2 > 0 then
      stPal := AnsiLowerCase(stPal)
    else
      stPal := Copy(stPal, 1, 1) + AnsiLowerCase(Copy(stPal, 2, tam));
    stTmp := stTmp + stPal;
    stAux := copy(stAux, pos1 + 1, tam)
  end;
  Result := stTmp;
end;


{-------------------------------------------------------------------------------
  Procedure: TEAMString.Clear
  Arguments: None
  Result:    None
  Objetivo:  Apagar o conteudo da string
-------------------------------------------------------------------------------}
procedure TEAMString.Clear;
begin
  Self.Text := '';
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.ToCNPJ
  Arguments: None
  Result:    string
  Objetivo:  formata Cpf/Cnpj sem q o usuario tenha q digitar os pontos, traços e barra
-------------------------------------------------------------------------------}

function TEAMString.ToCNPJCpf: string;
var
  vTam, xx: Integer;
  vDoc: string;
begin
  vTam := Length(Self.Text);
  for xx := 1 to vTam do
    if (Copy(Self.Text, xx, 1) <> '.') and (Copy(Self.Text, xx, 1) <> '-') and (Copy(Self.Text, xx, 1) <> '/') then
      vDoc := vDoc + Copy(Self.Text, xx, 1);
  Self.Text := vDoc;
  vTam := Length(Self.Text);
  vDoc := '';
  vDoc := '';
  for xx := 1 to vTam do
  begin
    vDoc := vDoc + Copy(Self.Text, xx, 1);
    if vTam = 11 then
    begin
      if (xx in [3, 6]) then
        vDoc := vDoc + '.';
      if xx = 9 then
        vDoc := vDoc + '-';
    end;
    if vTam = 14 then
    begin
      if (xx in [2, 5]) then
        vDoc := vDoc + '.';
      if xx = 8 then
        vDoc := vDoc + '/';
      if xx = 12 then
        vDoc := vDoc + '-';
    end;
  end;
  Result := vDoc;
end;


{-------------------------------------------------------------------------------
  Procedure: TEAMString.Empty
  Arguments: None
  Result:    string
  Objetivo:  Retornar uma string Vazia
-------------------------------------------------------------------------------}
function TEAMString.Empty: string;
begin
  result := '';
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.ExisteInt
  Arguments: None
  Result:    Boolean
  Objetivo:  Testar se na string existe um numero inteiro valido ou não
-------------------------------------------------------------------------------}

function TEAMString.ExisteInt: Boolean;
begin
  try
    StrToInt(Text);
    Result := True;
  except
    Result := False;
  end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.Explode
  Arguments: const Ch: Char
  Result:    TStringList
  Objetivo:   Explodir a string em uma TStringList de acordo com o carater separador
-------------------------------------------------------------------------------}

function TEAMString.Explode(const Ch: Char): TStringList;
var
  c: word;
  Source: string;
begin
  Result := TStringList.Create;
  c := 0;

  Source := Self.Text;
  while source <> '' do
  begin
    if Pos(CH, source) > 0 then
    begin
      Result.Add(Copy(Source, 1, Pos(CH, source) - 1));
      Delete(Source, 1, Length(Result[c]) + Length(CH));
    end
    else
    begin
      Result.Add(Source);
      Source := '';
    end;
    inc(c);
  end;
end;
 {-------------------------------------------------------------------------------
  Procedure: TEAMString.Explode
  Arguments: const Ch: Char
  Result:    TStringList
  Objetivo:  Explodir a string em uma TStringList de acordo com o carater separador
  removendo os espaços em branco
-------------------------------------------------------------------------------}

function TEAMString.ExplodeTrim(const Ch: Char): TStringList;
var
  I: Integer;
begin
  Result := Self.Explode(ch);

  for I := 0 to Result.Count - 1 do
  begin
    Result.Strings[i] := Trim(Result.Strings[i]);
  end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.IsDateTime
  Arguments: self.value: string
  Result:    Boolean
  Objetivo:  Verificar se a string é do tipo DateTime
-------------------------------------------------------------------------------}

function TEAMString.IsDateTime: Boolean;
var
  i: Integer;
begin
  if (self.Text = '') then
  begin
    Result := False;
    Exit;
  end;

  Result := True;

  for i := 1 to Length(self.Text) do
    if not (self.Text[i] in ['0'..'9', DateSeparator]) then
    begin
      Result := False;
      Break;
    end;

end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.IsEmpty
  Arguments: inString: string
  Result:    Boolean
  Objetivo:  Verificar se a string está vazia
-------------------------------------------------------------------------------}

function TEAMString.IsEmpty: Boolean;
begin
  Result := (self.Text = '');
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.IsFloat
  Arguments: None
  Result:    Boolean
  Objetivo:  Verificar se a string é um float
-------------------------------------------------------------------------------}

function TEAMString.IsFloat: Boolean;
var
  Value: Extended;
begin
  Result := TextToFloat(Self.ToPChar, Value, fvExtended);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.IsInteger
  Arguments:
  Result:    Boolean
  Objetivo:  Verificar se a string é um inteiro
-------------------------------------------------------------------------------}

function TEAMString.IsInteger(): Boolean;
begin
  if (Pos('.', Self.Text) > 0) or not IsNumeric then
  begin
    Result := False;
    Exit;
  end;

  try
    StrToInt(Self.Text);
    Result := True;
  except
    Result := False;
  end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.IsNumeric
  Arguments: None
  Result:    Boolean
  Objetivo:  Verificar se a string contem caracteres numericos
-------------------------------------------------------------------------------}

function TEAMString.IsNumeric: Boolean;
var
  i: Integer;
begin
  if (Self.Text = '') then
  begin
    Result := False;
    Exit;
  end;

  Result := True;

  for i := 1 to Length(Self.Text) do
    if not (self.Text[i] in ['0'..'9', '.', ',']) then
    begin
      Result := False;
      Break;
    end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.Lowercase_S
  Arguments: None
  Result:    None
  Objetivo:  Converter a string para minusculo
-------------------------------------------------------------------------------}

function TEAMString.Lower: string;
begin
  Result := LowerCase(self.Text);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.LTrim
  Arguments: None
  Result:    None
  Objetivo:  Remove os Espaços em branco à esquerda da string
-------------------------------------------------------------------------------}

function TEAMString.LTrim: string;
var
  I: Integer;
begin
  I := 0;
  while True do
  begin
    inc(I);
    if I > length(self.Text) then
      break;
    if self.Text[I] <> #32 then
      break;
  end;
  Result := Copy(self.Text, I, length(self.Text));
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.MD5
 11/2/2011
  Arguments: None
  Result:    string
  Objetivo:  Retorna o Md5 da string
-------------------------------------------------------------------------------}

function TEAMString.HashMD5: string;
begin
  with TIdHashMessageDigest5.Create do
    try
      Result := TIdHash128.AsHex(HashValue(Self.Text));
    finally
      Free;
    end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.QuebraString
  Arguments: APosicao: Integer; ASeparador: string
  Result:    string
  Objetivo:  Retornar o que está após o separador
-------------------------------------------------------------------------------}

function TEAMString.QuebraString(APosicao: Integer; ASeparador: string): string;
var
  i, cont: integer;
begin
  cont := 0;
  if (APosicao <= 0) then
    exit;
  for i := 0 to length(self.Text) do
  begin
    if self.Text[i] = ASeparador then
    begin
      inc(cont);
    end;
    if cont = APosicao then
    begin
      Result := self.Text[i];
    end;
  end;

end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.RemoveAcento
  Arguments: None
  Result:    None
  Objetivo:  Remover os acentos da string
-------------------------------------------------------------------------------}

function TEAMString.RemoveAcento: string;
const
  ComAcento = 'àâêôûãõáéíóúçüÀÂÊÔÛÃÕÁÉÍÓÚÇÜ';
  SemAcento = 'aaeouaoaeioucuAAEOUAOAEIOUCU';
var
  x: Integer;
begin

  Result := Self.Text;
  for x := 1 to Length(Self.Text) do
  begin
    if Pos(Self.Text[x], ComAcento) <> 0 then
      Result[x] := SemAcento[Pos(Text[x], ComAcento)]
  end;
end;


{-------------------------------------------------------------------------------
  Procedure: TEAMString.RemoveChar
  Arguments: Caracter: char
  Result:    string
  Objetivo:  Remove o caracter passado da string
-------------------------------------------------------------------------------}
function TEAMString.RemoveChar(Caracter: char): string;
var
  i: integer;
begin
  Result := '';
  for i := 1 to length(self.Text) do
  begin
    if self.Text[i] <> Caracter then
    begin
      Result := Result + Self.Text[i];
    end;
  end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.ReplaceChar
  Arguments: Caracter, Subst: char
  Result:    None
  Objetivo:  Substiuir um caracter  dentro da string
-------------------------------------------------------------------------------}

function TEAMString.ReplaceChar(Caracter, Subst: char): string;
var
  i: integer;
begin
  Result := Self.Text;
  for i := 0 to length(self.Text) do
  begin
    if self.Text[i] = Caracter then
    begin
      Result[i] := Subst;
    end;
  end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.ReplChar
  Arguments: const Ch: Char; const Len: integer
  Result:    string
  Objetivo:  Replica um caractere n vezes formando uma string
-------------------------------------------------------------------------------}

function TEAMString.ReplicaChar(const Ch: Char; const Len: integer): string;
var
  I: integer;
begin
  SetLength(Result, Len);
  for I := 1 to Len do
    Result[I] := Ch;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.ReverseStr
  Arguments: None
  Result:    string
  Objetivo:  Retornar o inverso da string
-------------------------------------------------------------------------------}

function TEAMString.ReverseStr: string;
var
  I: Integer;
begin
  Result := '';
  for I := Length(self.Text) downto 1 do
    Result := Result + self.Text[I];
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.RTrim
  Arguments: None
  Result:    None
  Objetivo:  Remover os espaços em branco a direita da string
-------------------------------------------------------------------------------}

function TEAMString.RTrim: string;
var
  I: Integer;
begin
  I := length(self.Text) + 1;
  while True do
  begin
    Dec(I);
    if I <= 0 then
      break;
    if self.Text[I] <> #32 then
      break;
  end;
  Result := Copy(self.Text, 1, I);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.SearchLeft
  Arguments: Caracter: string; PosInicial: integer
  Result:    integer
  Objetivo:  Pesquisa um caractere à esquerda da string, retornando sua posição
-------------------------------------------------------------------------------}

function TEAMString.SearchLeft(Caracter: string): integer;
var
  i: integer;
begin
  result := -1;
  for i := 0 to length(self.Text) do
  begin
    if self.Text[i] = Caracter then
    begin
      Result := i;
      exit;
    end;
  end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.SearchRigth
  Arguments: Caracter: string; PosInicial: integer
  Result:    integer
  Objetivo:  Pesquisa um caractere à direita da string, retornando sua posição
-------------------------------------------------------------------------------}

function TEAMString.SearchRigth(Caracter: string): integer;
var
  i: integer;
begin
  result := -1;
  for i := length(self.Text) downto 0 do
  begin
    if self.Text[i] = Caracter then
    begin
      Result := i;
      exit;
    end;
  end;
end;

procedure TEAMString.SetTextLength(Tam: integer);
begin
  Self.Text := StringOfChar(' ', Tam);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.StrIntComZero
  Arguments: const Value, Len: integer
  Result:    string
  Objetivo:  Forma um número inteiro com zeros à esquerda
-------------------------------------------------------------------------------}

function TEAMString.StrIntComZero(const Value, Len: integer): string;
var
  I: integer;
begin
  Result := IntToStr(Value);
  I := Length(Result);
  if I < Len then
    Result := Self.ReplicaChar('0', Len - I) + Result
  else if I > Len then
    Result := ReplicaChar('*', Len);

end;


{-------------------------------------------------------------------------------
  Procedure: TEAMString.ToAspas
  Author:    Evaldo
  DateTime:  04/08/2011
  Arguments: None
  Result:    string
  Objetivo:  Retornar uma string com aspas
-------------------------------------------------------------------------------}
function TEAMString.ToAspas: string;
begin
  Result := QuotedStr(Self.Text);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.ToCurrency

  DateTime:  10/6/2010
  Arguments: None
  Result:    Currency
  Objetivo:  Converter para Currency
-------------------------------------------------------------------------------}

function TEAMString.ToCurrency: Currency;
begin
  Result := StrToCurr(Self.Text);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.ToCurrencyString
  Arguments: None
  Result:    string
  Objetivo:  Formatar um valor double em monetário
-------------------------------------------------------------------------------}

function TEAMString.ToCurrencyString: string;
begin
  Result := 'R$ ' + FormatCurr('0.,00', Self.ToCurrency);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.ToCustomFormat
  Author:    Evaldo
  DateTime:  04/08/2011
  Arguments: Mask: string
  Result:    string
  Objetivo:  Mascara customizada
-------------------------------------------------------------------------------}
function TEAMString.ToCustomFormat(Mask: string): string;
begin
  result := Format(Mask, [Self.Text])
end;


{-------------------------------------------------------------------------------
  Procedure: TEAMString.ToDateTime
  Author:    Evaldo
  DateTime:  04/08/2011
  Arguments: None
  Result:    TDateTime
  Objetivo:  Converte para DataHora
-------------------------------------------------------------------------------}
function TEAMString.ToDateTime: TDateTime;
begin
  Result := StrToDateTime(Self.Text);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.ToFloat
  Arguments: None
  Result:    Extended
  Objetivo:  Filtra uma string qualquer, convertendo as suas partes
  numéricas para sua representação decimal, por exemplo:
  'R$ 1.200,00' para 1200,00 '1AB34TZ' para 134
-------------------------------------------------------------------------------}

function TEAMString.ToFloat: Double;
var
  Aux: string;
begin
  Aux := self.ReplaceChar('.', ',');

  Result := StrToFloat(aux);
end;

function TEAMString.ToFloatExtended: Extended;
var
  i: Integer;
  stAux: string;
  blSeenDecimal, blSeenSgn: Boolean;
begin
  stAux := '';
  blSeenDecimal := False;
  blSeenSgn := False;
  {Percorre os caracteres da string:}
  for i := Length(Self.Text) downto 0 do
    {Filtra a string, aceitando somente números e separador decimal:}
    if (Self.Text[i] in ['0'..'9', '-', '+', DecimalSeparator]) then
    begin
      if (Self.Text[i] = DecimalSeparator) and (not blSeenDecimal) then
      begin
        stAux := Self.Text[i] + stAux;
        blSeenDecimal := True;
      end
      else if (Self.Text[i] in ['+', '-']) and (not blSeenSgn) and (i = 1) then
      begin
        stAux := Self.Text[i] + stAux;
        blSeenSgn := True;
      end
      else if Self.Text[i] in ['0'..'9'] then
      begin
        stAux := Self.Text[i] + stAux;
      end;
    end;
  Result := StrToFloat(stAux);

end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.ToInt

  DateTime:  7/6/2010
  Arguments: None
  Result:    Integer
  Objetivo:  Converter para inteiro
-------------------------------------------------------------------------------}

function TEAMString.ToInt: Integer;
begin
  Result := StrToInt(Self.Text);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.ToPChar


  Arguments: None
  Result:    PChar
  Objetivo:  Retornar um ponteiro para char
-------------------------------------------------------------------------------}

function TEAMString.ToPChar: PChar;
{Converte String em Pchar}
type
  TRingIndex = 0..7;
var
  Ring: array[TRingIndex] of PChar;
  RingIndex: TRingIndex;
  Ptr: PChar;
begin
  Ptr := @self.Text[Length(self.Text)];
  Inc(Ptr);
  if Ptr^ = #0 then
  begin
    Result := @self.Text[1];
  end
  else
  begin
    Result := StrAlloc(Length(self.Text) + 1);
    RingIndex := (RingIndex + 1) mod (High(TRingIndex) + 1);
    StrPCopy(Result, self.Text);
    StrDispose(Ring[RingIndex]);
    Ring[RingIndex] := Result;
  end;

end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.Alltrim


  Arguments: None
  Result:    None
  Objetivo:  Remover os espaços em branco a direita e a esquerda da string
-------------------------------------------------------------------------------}

procedure TEAMString.ADD(s: string);
begin
  Self.Text := Self.Text + s;
end;


{-------------------------------------------------------------------------------
  Procedure: TEAMString.ADDQuote
  Author:    Evaldo
  DateTime:  04/08/2011
  Arguments: Separador, valor,Quote:string
  Result:    None
  Objetivo:  Retorna uma string com um separador e um Quote
-------------------------------------------------------------------------------}
procedure TEAMString.ADDQuote(Separador,  valor,Quote:string);
begin
  if Self.IsEmpty then
    Self.Text := Self.Text + Quote + valor + Quote
  else
    Self.Text := Self.Text + Separador + Quote + valor + Quote;
end;
{-------------------------------------------------------------------------------
  Procedure: TEAMString.Alltrim
  Arguments: None
  Result:    string
  Objetivo:  Remove os espaços em Branco de uma string
-------------------------------------------------------------------------------}
function TEAMString.Alltrim: string;
begin
  Result := Trim(Text);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.UpperCase_s
  Arguments: None
  Result:    None
  Objetivo:  Converter a string para maiúsculo
-------------------------------------------------------------------------------}

function TEAMString.Upper: string;
begin
  Result := UpperCase(self.Text);
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.wordcount
  Arguments: None
  Result:    integer
  Objetivo:  Retorna o número de palavras que contem em uma string
-------------------------------------------------------------------------------}

function TEAMString.Wordcount: integer;
var
  i: integer;
  len: integer;
begin
  len := length(Self.Text);
  Result := 0;
  i := 1;
  while i <= len do
  begin
    while ((i <= len) and ((Self.Text[i] = #32) or (Self.Text[i] = #9) or
      (Self.Text[i] = ';'))) do
      inc(i);
    if i <= len then
      inc(Result);
    while ((i <= len) and ((Self.Text[i] <> #32) and (Self.Text[i] <> #9) and
      (Self.Text[i] <>
      ';'))) do
      inc(i);
  end;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.PadC
  Arguments: const Len: integer; const Ch: Char
  Result:    string
  Objetivo:  Completa a string com caracter passado a esquerda e a direita da string
  de acordo com o tamanho indicado
-------------------------------------------------------------------------------}

function TEAMString.PadC(const Len: integer; const Ch: Char): string;
var
  I, J: integer;
  Pad: string;
  Impar: boolean;
begin
  I := Length(self.Text);
  if I < Len then
  begin
    J := Len - I;
    Impar := J mod 2 = 1;
    J := J div 2;
    Pad := self.ReplicaChar(Ch, J);
    Result := Pad + Self.Text + Pad;
    if Impar then
      Result := Result + Ch;
  end
  else if I > Len then
  begin
    J := I - Len;
    Impar := J mod 2 = 1;
    J := J div 2;
    Result := Self.Text;
    Delete(Result, I - J + 1, J);
    Delete(Result, 1, J);
    if Impar then
    begin
      Dec(I, J * 2);
      Delete(Result, I, 1);
    end;
  end
  else
    Result := Self.Text;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.PadL
  Arguments: const Len: integer; const Ch: Char
  Result:    string
  Objetivo:  Completa a string com caracter passado a esquerda da string de acordo com o tamanho indicado
-------------------------------------------------------------------------------}

function TEAMString.PadL(const Len: integer; const Ch: Char): string;
var
  LenS: integer;
begin
  LenS := Length(Self.Text);
  if LenS < Len then
    Result := self.ReplicaChar(Ch, Len - LenS) + self.Text
  else if LenS > Len then
    Result := Copy(self.Text, LenS - Len + 1, Len)
  else
    Result := self.Text;
end;

{-------------------------------------------------------------------------------
  Procedure: TEAMString.PadR
  Arguments: const Len: integer; const Ch: Char
  Result:    string
  Objetivo:  Completa a string com caracter passado a direita da string de acordo com o tamanho indicado
-------------------------------------------------------------------------------}

function TEAMString.PadR(const Len: integer; const Ch: Char): string;
var
  LenS: integer;
begin
  LenS := Length(self.Text);
  if LenS < Len then
    Result := self.Text + self.ReplicaChar(Ch, Len - LenS)
  else if LenS > Len then
    Result := Copy(self.Text, 1, Len)
  else
    Result := self.Text;
end;

{$ENDREGION}

end. 

Adicione alguns edits para o formulário de teste como abaixo:

 Adicione o seguinte código no onCLick do botão "ok" :

procedure TForm1.btn1Click(Sender: TObject);
var
  EAMString:TEAMString;
begin
  EAMString.Text := ' Teste ';

  edtTexto.Text := EAMString.Text;
  edtTrimALL.Text := EAMString.Alltrim;
  edtTrimL.Text := EAMString.LTrim;
  edtTrimR.Text := EAMString.RTrim;
  edtHash.Text := EAMString.HashMD5;
  edtPADL.Text := EAMString.PadL(10,'0');
  edtReverseStr.Text := EAMString.ReverseStr;
  edtToAspas.Text := EAMString.ToAspas;
end;

Execute a aplicação e observe o resultado:

Todos os métodos da listagem foram documentados para facilitar o entendimento da sua finalidade. Fique a vontade para adicionar novos métodos e procedures. :)

Confira aqui o próximo post

Observação: Algumas das procedure e functions usadas neste artigo são uma compilação de códigos encontrados na internet. se você econtrar aqui algum código de sua autoria, entre em contato para que possamos dar-lhe o devido crédito.

Criando um tipo de dado Avançado em Delphi - Parte 1

Criando um tipo de dado Avançado em Delphi:

Talvez você não saiba, mas o tipo record em pascal pode conter em sua estrutura functions e procedures desde o Delphi 2006, Sendo assim nos podemos tirar proveito disso para criar um tipo de dado mais avançado.
Vamos tomar como exemplo o tipo string. O que você consegue fazer com um dado do tipo string? Nada, apenas usar para guardar o seu conteúdo. Qualquer operação que você precise realizar nesse dado terá que usar alguma função externa.
Para contornar isso, podemos usar o record para criar um tipo de dado mais avançado e como exemplo vamos criar um tipo TEAMString (o nome é sugestivo) :

Abra o delphi (neste artigo fora utilizado o Delphi 2007) e crie um novo projeto para aplicação:

Agora adicione uma nova unit e salve-a como untTEAMString:

Agora estamos pronto para começar! Vamos criar o record:

unit untTEAMString;

interface
 uses Classes,SysUtils;
type
  TEAMString = record
    Text: string;
  end;

implementation

end. 

Repare que o nosso Tipo TEAMString possui um campo "Text" esse campo nós vamos usar para guardar  uma string e posteriormente aplicar operações nesse dado.

Agora vamos adicionar algumas operações mais comuns com strings para deixar esse nosso tipo mais parrudo. Para começar vamos utilizar as  operações para remover espaços em branco no inicio, no final e no inicio e no final de uma string. Então vamos adiciona-las:

TEAMString = record
    Text: string;

    {Remove os Espaços em branco }
    function Alltrim: string;
    function LTrim: string;
    function RTrim: string;

  end;

Agora a implementação:

uses Classes,SysUtils;

type
  
TEAMString = record
    Text: string;

    {Remove os Espaços em branco }
    function Alltrim: string;
    function LTrim: string;
    function RTrim: string;

  end;

implementation

{ TEAMString }

// Objetivo:  Remove os Espaços em branco
function TEAMString.Alltrim: string;
begin
  Result := Trim(Text);
end;

// Objetivo:  Remove os Espaços em branco à esquerda da string
function TEAMString.LTrim: string;
var
  I: Integer;
begin
  I := 0;
  while True do
  begin
    inc(I);
    if I > length(self.Text) then
      break;
    if self.Text[I] <> #32 then
      break;
  end;
  Result := Copy(self.Text, I, length(self.Text));
end;

//Objetivo:  Remover os espaços em branco a direita da string
function TEAMString.RTrim: string;
var
  I: Integer;
begin
  I := length(self.Text) + 1;
  while True do
  begin
    Dec(I);
    if I <= 0 then
      break;
    if self.Text[I] <> #32 then
      break;
  end;
  Result := Copy(self.Text, 1, I);
end;

end.

Agora já temos alguma funcionalidade para esse nosso tipo. Vamos Fazer um pequeno teste.
No formulário da aplicação adicione um botão e 4 edits. Também não se esqueça de adcionar
a untTEAMString no USES do formulário:

uses Classes,SysUtils;

Codificando o botão:
Declare uma variável do tipo TEAMString e atribua a ela o valor do Edit texto. Em seguida, atribua os aos outros edits o resultado das operações:

procedure TForm1.btn1Click(Sender: TObject);
var
  EAMString:TEAMString;
begin
  EAMString.Text := edtTexto.Text;
  edtTrimALL.Text := EAMString.Alltrim;
  edtTrimL.Text := EAMString.LTrim;
  edtTrimR.Text := EAMString.RTrim;
end; 

Rode a aplicação insira um texto com espaços a esquerda e a direita e clique no botão Ok:

Se você selecionar o texto com o mouse podera observar que o espaço em branco foi removido no Edit "Trim ALL" e removido a esquerda no Edit "Trim Left" e a direita no "Edit Trim Right".
Repare que realizamos algumas operações no dado sem ter o seu conteúdo alterado e sem precisar usar funções externas, deixando o nosso código muito mais limpo e legível! Isso sem  falar na produtividade que aumentara consideravelmente.
Já imaginou no que da para fazer? Nos próximos posts vamos adicionar novas funcionalidades e criar novos tipos avançados.

Confira aqui a segunda parte desse Artigo