programa_cobranca/uFuncoes.pas

{

 Funções

 Versao 2.11 - 13/05/2016

        - Juntar elementos de lista

 Versao 2.10 - 20/04/2010

        - Formatar CEP, CPF e CNPJ

 Versão 2.9 - 08/07/2006

        - Funções para controle de serviços

 Versão 2.8 - 08/03/2006

        - criada GetUserName

        - criada GetComputerName

        - criada GetIdeDiskSerialNumber

 Versão 2.7.1 - 29/08/2005

        - criada a função LerCampoWeb

 Versão 2.7.0 - 24/09/2003

        - function MinToHr(min: integer): String;

                - Acerto no cálculo - formato de saída hhh:mm

        - function DecToMin(dec:real): integer;

                - Acerto no cálculo

        - function HrToMin(hora: String): Integer;

                - Para os formatos hhh:mm e hh:mm

 Versão 2.6.0 - 21/05/2003

 	- Inclusão da função fillspacesl, inserir espaços à esquerda


 Versão 2.5.0 - 06/03/2003

        - Inclusão das funções

                function datetoyyyymmdd

                function datetoddmmyyyy


 Versão 2.4.1 - 22/01/2003

        - Acerto no roundprecise e roundprecise2
          para converter os valores recebidos
          por causa de um erro que não convertia
          3.015 para 3.02, somente quando o valor
          vinha no parâmetro precisamente

 Versão 2.4.0 - 15/01/2003

        - RoundValue corigida para
          arredondar xx,9 para xx+1

 Versão 2.3.0 - 09/01/2003

        - Implementação das funções bancárias

 Versão 2.2.0 - 08/01/2003

        - Implementação das conversões de horas

 Versão 2.1.0 - 02/01/2003

        - DateToDDMMYY corrigido o ano
        - Replace corrigido
        - RoundValue corrigida

 Versão 2.0 - 20/10/2002

        - Implementação das funções básicas

}


unit uFuncoes;

interface

uses SysUtils, Controls, Classes, Windows, Dialogs, Registry,
     ActiveX, ComObj, ShlObj, Winsock, WinSvc, ShellAPI, Variants,
     WinInet, Mapi, Forms;


type
  TShortcut = (scDesktop, scQuickLaunch, scSendTo, scStart, scPrograms);


//
// Internet
//

function ConectadoInternet: Boolean;

function EnviarEmail(Endereco: String; Assunto: String = ''; Texto: String = '';
  stlAnexo: TStringList = nil; AEnviarDireto: boolean = False): Boolean;

//
// Bancárias
//

function fatorvencimento(data: TDateTime): string;

function mod10(valor: string): string;

function mod11(valor: string): string;
function mod11barsantander(valor: string): string;
function mod11santander(valor: string): string;
function mod11bradesco(valor: string): string;

function dacbarcode(tmp: string):string;

function reprnumerica(tmp: string):string;

//
// Valores
//

function StrToCurrency(s: string): real;

function RoundInteger(value: real):integer;

function RoundCurrency(value: currency):currency;

function RoundValue(value: real):real;

function ValToCurr(tmp: string): real;



//
// Strings
//

function LerCampoWeb(msg,campo,default,tipo: string): string;

function PlainText(s: string): string;

function OnlyNumbers(s: string): string;

function replace(tag:string; s1, s2:char):string;

function ReplaceStr(S,Localizar,Substituir : string) : string;

function blockjustify(s: string; tam:integer):string;

function center(s: string; l: integer): string;

function fillspaces(tmp: string; count: integer):string;

function fillspacesl(tmp: string; count: integer):string;

function fillzeros(tmp: string; count: integer):string;

function fillcurrency(tmp: currency; count: integer):string;

function replicate(tmp: string; count: integer): string;

function getword(tmp: string; pos:integer):string;

function RightStr(const str: string; size: word): String;

function MidStr(const str: string; from, size: word): String;

function LeftStr(const str: string; size: word): String;

procedure ParseDelimited(const sl : TStrings; const value : string; const delimiter : string) ;

function HexToInt(const HexStr: string): longint;

function ExtractIP(Path: string): string;

function RemoveIP(Path: string): string;

function FormatarCEP(const CEP: string): string;

function FormatarCPF(const CPF: string): string;

function FormatarCNPJ(const CNPJ: string): string;

//
// Datas
//

function DataUtilAleatoria(dt_inicio, dt_fim: TDateTime): TDateTime;

function DiaSemana(Data: TDateTime): String;

function day(data: TDate): Word;

function month(data: TDate): Word;

function year(data: TDate): Word;

function firstday(month, year: word): TDateTime;

function lastday(month, year: word): TDateTime;

function ddmmyytodate(tmp: string): TDateTime;

function ddmmyyyytodate(tmp: string):TDate;

function datetoddmmyy(tmp: TDateTime):string;

function datetoddmmyyyy(tmp: TDateTime):string;

function datetoyyyymmdd(tmp: TDateTime):string;

//Retorna uma data reduzida de "xMeses" meses, podendo ser corrido ou não
function DiminuiMes (dData : TDateTime; xMeses : Integer; lCorrido : Boolean) : TDateTime;

//Retorna uma data acrescida de "xMeses" meses, podendo ser corrido ou não
function SomaMes (dData : TDateTime; xMeses : Integer; lCorrido : boolean) : TDateTime;

//Retorna o último dia útil caso a data informada caia em um fim de semana
function DiaUtilAnterior (dData : TDateTime) : TDateTime;

//Retorna o próximo dia útil caso a data informada caia em um fim de semana
function ProximoDiaUtil (dData : TDateTime) : TDateTime;

//Verifica se uma data informada cai em um final de semana
function IsWeekEnd (dData : TDateTime) : boolean;

//Retorna data do último dia do mês, ou último dia útil, de uma data informada
function LastDayOfMonth (Data : TDateTime; lSabDom : Boolean) : TDateTime;

//Retorna data do primeiro dia do mês, ou primeiro dia útil, de uma data informada
function FirstDayOfMonth (Data : TDateTime; lSabDom : Boolean) : TDateTime;

//Retorna uma data no Mês seguinte a uma data informada
function NextMonth (Data : TDateTime) : TDateTime;
Function PriorMonth (Data : TDateTime) : TDateTime;

//Retorna a data válida imediatamente posterior a uma data inválida
function ProxDataValida (Ano, Mes, Dia : Word) : TDateTime;

//Retorna a data válida imediatamente anterior a uma data inválida
function UltDataValida (Ano, Mes, Dia : Word) : TDateTime;


//
// Horas
//

function HrToMin(hora: String): Integer;

function MinToHr(min: integer): String;

function MinToDec(min:real): real;

function DecToMin(dec:real): integer;


//
// Verificação
//

function VerificaCPF(Value: string): Boolean;

function VerificaCNPJ(Value: string): Boolean;


//
// Arquivos
//

procedure CopyFile(const sourcefilename, targetfilename: string);

procedure CopyFileType(const sourcefilename, targetfilename, filetype: string);

procedure DeleteDir(hHandle:THandle; Const sPath:String);

procedure Deltree(cPath: string);

function FileInUse(FileName: string): Boolean;


//
// Sistema
//

function GetUserName: string;

function GetComputerName: string;

function GetComputerIP: string;

function GetIdeDiskSerialNumber: string;

function FindVolumeSerial(const Drive : PChar): string;

function GetBiosSerial: string;

function GetBiosInfoAsText: string;

function GetBiosCheckSum: string;

//function GetHashedBiosInfo: string;

function GetFileVersion(const FileName: TFileName; var Major, Minor, Release, Build: word): boolean;

function CreateShortcut(aTarget,startDir,aCaption,aGroup: string; aLoc: TShortcut; silent: Boolean): Boolean;

procedure PostKeyEx32(key: Word; const shift: TShiftState; specialkey: Boolean);

function ServiceStopped(sMachine, sService: string): boolean;

function ServiceRunning(sMachine, sService: string): boolean;

function ServiceGetStatus(sMachine, sService: string): DWord;

function ServiceStart(sMachine, sService: string): boolean;

function ServiceStop(sMachine, sService: string): boolean;

procedure RunOnStartUp(ApTitle, ApPathFile: string; RunOnce: Boolean);

procedure RemoveFromStartUp(ApTitle: string);

function CheckStartUp(ApTitle: string): boolean;

procedure SetRegistryData(RootKey: HKEY; Key, Value: string; RegDataType: TRegDataType; Data: variant);

function GetRegistryData(RootKey: HKEY; Key, Value: string): variant;

procedure AcertarData(data: TDateTime);

// Function GetNetUserName: string;

//
// Arrays
//

function join(const separator: string; const pieces: array of String): string;

//
// Criptografia
//

function Crypt(Opcao: String; Dados: String): String;

function NumAleatorio(Qtd: Integer):string;

implementation


function ConectadoInternet: Boolean;
const
  INTERNET_CONNECTION_MODEM = 1;
  INTERNET_CONNECTION_LAN = 2;
  INTERNET_CONNECTION_PROXY = 4;
  INTERNET_CONNECTION_MODEM_BUSY = 8;
var
  dwConnectionTypes : DWORD;
begin
  dwConnectionTypes := INTERNET_CONNECTION_MODEM + INTERNET_CONNECTION_LAN + INTERNET_CONNECTION_PROXY;
  If InternetGetConnectedState(@dwConnectionTypes,0) then
    Result := True
  else
    Result := False;
end;

function FormatarCEP(const CEP: string): string;
var
  I: integer;
begin
  Result := '';
  for I := 1 to Length(CEP) do
    if CEP[I] in ['0'..'9'] then
      Result := Result + CEP[I];
  if Length(Result) <> 8 then
    result := CEP
  else
    Result :=
      Copy(Result, 1, 5) + '-' +
      Copy(Result, 6, 3);
end;

function FormatarCPF(const CPF: string): string;
var
  I: integer;
begin
  Result := '';
  for I := 1 to Length(CPF) do
    if CPF[I] in ['0'..'9'] then
      Result := Result + CPF[I];
  if Length(Result) <> 11 then
    result := CPF
  else
    Result :=
      Copy(Result, 1, 3) + '.' +
      Copy(Result, 4, 3) + '.' +
      Copy(Result, 7, 3) + '-' +
      Copy(Result, 10, 2);
end;

function FormatarCNPJ(const CNPJ: string): string;
var
  I: integer;
begin
  Result := '';
  for I := 1 to Length(CNPJ) do
    if CNPJ[I] in ['0'..'9'] then
      Result := Result + CNPJ[I];
  if Length(Result) <> 14 then
    result := CNPJ
  else
    Result :=
      Copy(Result, 1, 2) + '.' +
      Copy(Result, 3, 3) + '.' +
      Copy(Result, 6, 3) + '/' +
      Copy(Result, 9, 4) + '-' +
      Copy(Result, 13, 2);
end;


procedure AcertarData(data: TDateTime);
var SystemTime: TSystemTime;
begin

  with SystemTime do
  begin
   // Definindo o dia do sistema
   wYear := StrToInt(FormatDateTime('yyyy', data));
   wMonth := StrToInt(FormatDateTime('mm', data));
   wDay := StrToInt(FormatDateTime('dd', data));
   // Definindo a hora do sistema
   wHour := StrToInt(FormatDateTime('hh', data));
   wMinute := StrToInt(FormatDateTime('nn', data));
   wSecond := StrToInt(FormatDateTime('ss', data));
  end;

  //Colocar a hora e data do sistema
  SetLocalTime(SystemTime);

end;


function DataUtilAleatoria(dt_inicio, dt_fim: TDateTime): TDateTime;
{Retorna uma data aleatória em dia útil entre 2 datas limites}
var dt_sorteio: TDateTime;
    nr_intervalo, nr_dias: integer;
begin

   Randomize;

   // Calcula os números de dias entre as datas

   nr_intervalo := Trunc(dt_fim - dt_inicio);

   // Pega um intervalo qualquer e calcula a nova data

   nr_dias := Random(nr_intervalo);

   dt_sorteio := dt_inicio + nr_dias;

   // Se for Sábado ou Domingo tira 2

   if (DayOfWeek(dt_sorteio) = 1) or (DayOfWeek(dt_sorteio) = 7) then
     dt_sorteio := dt_sorteio - 2;

   Result := dt_sorteio;

end;


function ExtractIP(Path: string): string;
begin

  result := copy(path, 1, pos(':', path)-1);

end;


function RemoveIP(Path: string): string;
begin

  result := copy(path, pos(':', path)+1, length(path));

end;


function HexToInt(const HexStr: string): longint;
var
iNdx: integer;
cTmp: Char;
begin
result := 0;
for iNdx := 1 to Length(HexStr) do
begin
cTmp := HexStr[iNdx];
case cTmp of
'0'..'9': Result := 16 * Result + (Ord(cTmp) - $30);
'A'..'F': Result := 16 * Result + (Ord(cTmp) - $37);
'a'..'f': Result := 16 * Result + (Ord(cTmp) - $57);
else
raise EConvertError.Create('Illegal character in hex string');
end;
end;
end;

procedure CopyFile(const sourcefilename, targetfilename: string);
var S, T: TFileStream;
begin
  S := TFileStream.Create( sourcefilename, fmOpenRead );
  try
    T := TFileStream.Create( targetfilename, fmOpenWrite or fmCreate );
    try
      T.CopyFrom(S, S.Size ) ;
    finally
      T.Free;
    end;
  finally
    S.Free;
  end;
end;


procedure CopyFileType(const sourcefilename, targetfilename, filetype: string);
var
  intFound: Integer;
  SearchRec: TSearchRec;
begin
 {
  intFound := FindFirst(sourcefilename+filetype, faAnyFile, SearchRec);

  while intFound = 0 do
  begin

    CopyFile(sourcefilename+SearchRec.Name, targetfilename+SearchRec.Name);

    intFound := FindNext(SearchRec);

  end;

  FindClose(SearchRec);
 }
end;

procedure DeleteDir( hHandle : THandle; Const sPath : String );
var
  OpStruc: TSHFileOpStruct;
  FromBuffer, ToBuffer: Array[0..128] of Char;
begin
 fillChar( OpStruc, Sizeof(OpStruc), 0 );
 FillChar( FromBuffer, Sizeof(FromBuffer), 0 );
 FillChar( ToBuffer, Sizeof(ToBuffer), 0 );
 StrPCopy( FromBuffer, sPath);
 With OpStruc Do
 Begin
  Wnd:= hHandle;
  wFunc:=FO_DELETE;
  pFrom:= @FromBuffer;
  pTo:= @ToBuffer;
  fFlags:= FOF_NOCONFIRMATION;
  fAnyOperationsAborted:=False;
  hNameMappings:=nil;
  //lpszProgressTitle:=nil;
 End;
 ShFileOperation(OpStruc);
end;

procedure Deltree(cPath: string);
//
// Remove um diretorio
//
var
search: TSearchRec;
nFiles: integer;
begin
nFiles:=FindFirst( cPath + '\*.*', faAnyFile,  search );
while nFiles=0 do
      begin
      if Search.Attr = faDirectory then
         begin
         if (Search.Name<>'.') and (Search.Name<>'..') then
             begin
             Deltree( cPath + '\' + Search.Name );
             RMDir( cPath + '\' + Search.Name );
             end;
         end
      else
         begin
         SysUtils.DeleteFile(cPath + '\' + Search.Name);
         end;
      nFiles:=FindNext( Search );
      end;
SysUtils.FindClose(Search);
RMDir(cPath);
end;

function LerCampoWeb(msg,campo,default,tipo: string): string;
var i: integer;
    msglist: TStringList;
    s: string;
begin

 // Delimita o campo

 campo := campo + ':';

 msglist := TStringList.Create;

 msglist.Text := msg;

 result := '';

 // Percorre as linhas procurando a variável

 for i := 0 to msglist.Count-1 do
 begin

   if copy(msglist.strings[i], 1, length(campo)) = campo then
   begin

     result := copy(msglist.strings[i], length(campo)+2, length(msglist.strings[i])-length(campo)+1);

   end;

 end;

 if trim(result) = '' then result := default;


 // Se o campo for tarifa, troca os pontos '.' por vírgulas ','

 if tipo = 'tarifa' then
 begin
  Replace(result, '.', ',');
 end;

 // Verifica se o campo é numérico e tira os pontos '.'

 if default = '0' then
 begin
  s := result;
  while Pos('.', s) > 0 do Delete(s,Pos('.', s),1);
  result := s;
 end;

end;


//
// Bancárias
//

function fatorvencimento(data: TDateTime): string;
{O fator de vencimento é a quantidade de dias entre 07/Nov/1997 e a data de vencimento do título}
begin

   if data >= EncodeDate(1997,10,07) then

      result := IntToStr(Trunc(data - EncodeDate(1997,10,07)))

   else

      result := '0000';

end;

function mod10(valor: String) : string;
{
   Rotina usada para cálculo de alguns dígitos verificadores
   Pega-se cada um dos dígitos contidos no parâmetro VALOR, da direita para a
   esquerda e multiplica-se por 2121212...
   Soma-se cada um dos subprodutos. Caso algum dos subprodutos tenha mais de um
   dígito, deve-se somar cada um dos dígitos. (Exemplo: 7*2 = 14 >> 1+4 = 5)
   Divide-se a soma por 10.
   Faz-se a operação 10-Resto da divisão e devolve-se o resultado dessa operação
   como resultado da função Modulo10.
   Obs.: Caso o resultado seja maior que 9, deverá ser substituído por 0 (ZERO).
}
var
   Auxiliar : string;
   Contador, Peso : integer;
   Digito : integer;
begin
   Auxiliar := '';
   Peso := 2;
   for Contador := Length(Valor) downto 1 do
   begin
      Auxiliar := IntToStr(StrToInt(Valor[Contador]) * Peso) + Auxiliar;
      if Peso = 1 then
         Peso := 2
      else
         Peso := 1;
   end;

   Digito := 0;
   for Contador := 1 to Length(Auxiliar) do
   begin
      Digito := Digito + StrToInt(Auxiliar[Contador]);
   end;
   Digito := 10 - (Digito mod 10);
   if (Digito > 9) then
      Digito := 0;
   Result := IntToStr(Digito);
end;


function mod11(Valor: string): string;
{
   Rotina muito usada para calcular dígitos verificadores
   Pega-se cada um dos dígitos contidos no parâmetro VALOR, da direita para a
   esquerda e multiplica-se pela seqüência de pesos 2, 3, 4 ... até BASE.
   Por exemplo: se a base for 9, os pesos serão 2,3,4,5,6,7,8,9,2,3,4,5...
   Se a base for 7, os pesos serão 2,3,4,5,6,7,2,3,4...
   Soma-se cada um dos subprodutos.
   Divide-se a soma por 11.
   Faz-se a operação 11-Resto da divisão e devolve-se o resultado dessa operação
   como resultado da função Modulo11.
   Obs.: Caso o resultado seja maior que 9, deverá ser substituído por 0 (ZERO).
}
var
   Soma : integer;
   Contador, Peso, Digito, resto : integer;
begin

   // Bancos
   //
   // Real
   // Itau
   // Caixa Econômica
   // Unibanco - Para COD BARRAS se dig - 0/1/10 entao dig = 1
   //            para NOSSO NUMERO  se dig - 0/1/10 entao dig = 0

   Soma := 0;
   Peso := 2;
   for Contador := Length(Valor) downto 1 do
   begin
      Soma := Soma + (StrToInt(Valor[Contador]) * Peso);
      if Peso < 9 then
         Peso := Peso + 1
      else
         Peso := 2;
   end;

   resto := (soma mod 11);

   digito := 11 - resto;

   if (digito = 0) then digito := 1;
   if (digito = 1) then digito := 1;
   if (digito > 9) then digito := 1;

   result := IntToStr(digito);

end;

function mod11santander(valor: string): string;
{
   Rotina muito usada para calcular dígitos verificadores
   Pega-se cada um dos dígitos contidos no parâmetro VALOR, da direita para a
   esquerda e multiplica-se pela seqüência de pesos 2, 3, 4 ... até BASE.
   Por exemplo: se a base for 9, os pesos serão 2,3,4,5,6,7,8,9,2,3,4,5...
   Se a base for 7, os pesos serão 2,3,4,5,6,7,2,3,4...
   Soma-se cada um dos subprodutos.
   Divide-se a soma por 11.
   Faz-se a operação 11-Resto da divisão e devolve-se o resultado dessa operação
   como resultado da função Modulo11.
   Obs.: Caso o resultado seja maior que 9, deverá ser substituído por 0 (ZERO).
}
var soma : integer;
    contador, peso, digito, resto : integer;
begin

   Soma := 0;
   Peso := 2;

   for Contador := Length(Valor) downto 1 do
   begin
      Soma := Soma + (StrToInt(Valor[Contador]) * Peso);
      if Peso < 9 then
         Peso := Peso + 1
      else
         Peso := 2;
   end;

   resto := (soma mod 11);

   digito := 11 - resto;

   if (resto = 0) then digito := 0;
   if (resto = 1) then digito := 0;
   if (resto > 9) then digito := 1;

   result := IntToStr(digito);

end;


function mod11barsantander(valor: string): string;
{
   Rotina muito usada para calcular dígitos verificadores
   Pega-se cada um dos dígitos contidos no parâmetro VALOR, da direita para a
   esquerda e multiplica-se pela seqüência de pesos 2, 3, 4 ... até BASE.
   Por exemplo: se a base for 9, os pesos serão 2,3,4,5,6,7,8,9,2,3,4,5...
   Se a base for 7, os pesos serão 2,3,4,5,6,7,2,3,4...
   Soma-se cada um dos subprodutos.
   Divide-se a soma por 11.
   Faz-se a operação 11-Resto da divisão e devolve-se o resultado dessa operação
   como resultado da função Modulo11.
   Obs.: Caso o resultado seja maior que 9, deverá ser substituído por 0 (ZERO).
}
var soma : integer;
    contador, peso, digito, resto : integer;
begin

   Soma := 0;
   Peso := 2;

   for Contador := Length(Valor) downto 1 do
   begin
      Soma := Soma + (StrToInt(Valor[Contador]) * Peso);
      if Peso < 9 then
         Peso := Peso + 1
      else
         Peso := 2;
   end;

   resto := (soma mod 11);

   digito := 11 - resto;

   if (resto = 0) then digito := 1;
   if (resto = 1) then digito := 1;
   if (resto > 9) then digito := 1;

   result := IntToStr(digito);

end;

function mod11bradesco(valor: string): string;

{
   Rotina muito usada para calcular dígitos verificadores
   Pega-se cada um dos dígitos contidos no parâmetro VALOR, da direita para a
   esquerda e multiplica-se pela seqüência de pesos 2, 3, 4 ... até BASE.
   Por exemplo: se a base for 9, os pesos serao 2,3,4,5,6,7,8,9,2,3,4,5...
   Se a base for 7, os pesos serao 2,3,4,5,6,7,2,3,4...
   Soma-se cada um dos subprodutos.
   Divide-se a soma por 11.
   Faz-se a operaçao 11-Resto da divisao e devolve-se o resultado dessa operaçao
   como resultado da funçao Modulo11.
   Obs.: Caso o resultado seja maior que 9, deverá ser substituído por 0 (ZERO).

}

var Soma : integer;
    Contador, Peso, Digito : integer;

begin

    Soma := 0;
    Peso := 2;

    for Contador := Length(valor) downto 1 do
    begin

     Soma := Soma + (StrToInt(Copy(valor,Contador,1)) * Peso);

     if (Peso < 7) and (Peso >= 2) then
      Peso := Peso + 1
     else
      Peso := 2;

    end;  // for

    Digito := (Soma * 10) mod 11;

    if (Digito > 9) then
     result:='P'
    else
     result := IntToStr(Digito);

end;


function reprnumerica(tmp:string): string;
var campo1, campo2, campo3, campo4, campo5: string;
begin

  campo1 := copy(tmp,1,9);
  campo2 := copy(tmp,10,10);
  campo3 := copy(tmp,20,10);
  campo4 := copy(tmp,30,1);
  campo5 := copy(tmp,31,14);

  campo1 := campo1 + mod10(campo1);
  campo2 := campo2 + mod10(campo2);
  campo3 := campo3 + mod10(campo3);

  result := copy(campo1,1,5)+'.'+copy(campo1,6,5)+' '+
            copy(campo2,1,5)+'.'+copy(campo2,6,6)+' '+
            copy(campo3,1,5)+'.'+copy(campo3,6,6)+' '+
            campo4+' '+campo5;
end;


function dacbarcode(tmp: string):string;
begin

   result :=  copy(tmp,1,4) + mod11(tmp) + copy(tmp,5,39);

end;

//
// Valores
//

function RoundInteger(value: real):integer;
// Arredonda para cima se for >= 0.5 e arredonda para baixo se for <= 0.4
begin

 result := trunc(value+0.5);

end;


function RoundCurrency(value: currency):currency;
// Arredonda para cima se for >= 0.5 e arredonda para baixo se for <= 0.4
begin

 // value := strtofloat(floattostr(value));

 result := trunc((value*100)+0.5)/100;

end;


function fillspaces(tmp: string; count: integer):string;
begin

   result := copy(trim(tmp)+StringOfChar(' ',count),1,count);

end;

function fillspacesl(tmp: string; count: integer):string;
begin

   tmp := trim(tmp);

   result := StringOfChar(' ',count-length(tmp)) + tmp;

end;

function fillzeros(tmp: string; count: integer):string;
begin

   fillzeros := copy(StringOfChar('0',count)+tmp,length(tmp)+1,count);

end;


function fillcurrency(tmp: currency; count: integer):string;
var s, inteiro, decimal: string;
begin

   s := formatfloat('0.00',tmp);
   inteiro := copy(s,1,length(s)-3);
   decimal := copy(s,length(s)-1,2);

   fillcurrency := fillzeros(inteiro,count-2)+decimal;

end;

function datetoddmmyy(tmp: TDateTime):string;
begin
  result := FormatDateTime('ddmmyy', tmp);
  // result := copy(DateToStr(tmp),1,2)+copy(DateToStr(tmp),4,2)+copy(DateToStr(tmp),length(DateToStr(tmp))-1,2);
end;

function datetoddmmyyyy(tmp: TDateTime):string;
begin
  result := FormatDateTime('ddmmyyyy', tmp);
end;

function datetoyyyymmdd(tmp: TDateTime):string;
begin
  result := FormatDateTime('yyyymmdd', tmp);
end;

function ddmmyytodate(tmp: string):TDateTime;
var Year, Month, Day: word;
begin
  if (length(trim(tmp)) = 0) or (tmp = '000000') then
  begin
    result := 0;
  end
  else begin
   Year := StrToInt(copy(tmp,5,2));
   Month := StrToint(copy(tmp,3,2));
   Day := StrToInt(copy(tmp,1,2));
   // Y2K
   if year > 50 then
    Year := Year + 1900
   else
    Year := Year + 2000;
   result := EncodeDate(Year, Month, Day);
  end;
end;

function ddmmyyyytodate(tmp: string):TDate;
var Year, Month, Day: word;
begin
  if (length(trim(tmp)) = 0) or (tmp = '00000000') then
  begin
    result := 0;
  end
  else begin
   Day := StrToInt(copy(tmp,1,2));
   Month := StrToint(copy(tmp,3,2));
   Year := StrToInt(copy(tmp,5,4));
   result := EncodeDate(Year, Month, Day);
  end;
end;


function valtocurr(tmp: string): real;
begin

  ValToCurr := StrToInt(copy(tmp,1,11)) + (StrToInt(copy(tmp,12,2))/100);

end;


function PlainText(s: string): string;
var i: integer;
begin

     for i := 1 to length(s) do
     begin

       case s[i] of

         'á','à','â','ä','ã': s[i] := 'a';
         'é','è','ê','ë'    : s[i] := 'e';
         'í','ì','î','ï'    : s[i] := 'i';
         'ó','ò','ô','ö','õ': s[i] := 'o';
         'ú','ù','û','ü'    : s[i] := 'u';
         'ç'                : s[i] := 'c';

         'Á','À','Â','Ä','Ã': s[i] := 'A';
         'É','È','Ê','Ë'    : s[i] := 'E';
         'Í','Ì','Î','Ï'    : s[i] := 'I';
         'Ó','Ò','Ô','Ö','Õ': s[i] := 'O';
         'Ú','Ù','Û','Ü'    : s[i] := 'U';
         'Ç'                : s[i] := 'C';

       end;

     end;

     PlainText := s;

end;


function StrToCurrency(s: string): real;
begin

//  ShowMessage(onlynumbers(s));

//  ShowMessage(replace(onlynumbers(s),'.',','));

  result := StrToFloatDef(replace(onlynumbers(s),'.',','),0);

end;


function OnlyNumbers(s: string): string;
var i: byte;
begin

  result := '';
  for i := 1 To Length(s) do
    if s[i] in ['0'..'9'] then
      result := result + s[i];

    {
    while pos('</vNF>', s) > 0 do delete(s, pos('</vNF>', s), 6);

    while pos('.', s) > 0 do delete(s, pos('.', s), 1);

    while pos('-', s) > 0 do delete(s, pos('-', s), 1);

    while pos('/', s) > 0 do delete(s, pos('/', s), 1);

    while pos('(', s) > 0 do delete(s, pos('(', s), 1);

    while pos(')', s) > 0 do delete(s, pos(')', s), 1);

    while pos(' ', s) > 0 do delete(s, pos(' ', s), 1);

    while pos('<', s) > 0 do delete(s, pos('<', s), 1);

    while pos('>', s) > 0 do delete(s, pos('>', s), 1);

    while pos('R$', s) > 0 do delete(s, pos('R$', s), 2);
    }

    //result := s;

end;


function firstday(month, year: word): TDateTime;
begin

   result := EncodeDate(year, month, 1);

end;


function lastday(month, year: word): TDateTime;
var ndia, nmes, nano: word;
    data: TDate;
begin

   data := EncodeDate(year, month, 28);

   while TRUE do
   begin

     data := data + 1;
     DecodeDate(data, nano, nmes, ndia);
     if (nmes <> month) then break;

   end;

   lastday := data - 1;

end;


function replace(tag:string; s1, s2:char):string;
var i: integer;
begin

  for i := 1 to length(tag) do
  begin

   if tag[i] = s1 then tag[i] := s2;

  end;

  replace := tag;

end;


function ReplaceStr (S,Localizar,Substituir : string) : string;
var
   Retorno: String;
   Posicao: Integer;
begin
   Retorno := S;
   //Obtendo a posição inicial da substring Localizar na string Localizar.
   Posicao := Pos (Localizar, Retorno);
   if Posicao <> 0 then // Verificando se a substring Localizar existe.
   begin
      // Excluindo a Localizar.
      Delete(Retorno, Posicao, Length (Localizar));
      // Inserindo a string do parâmetro Substituir
      Insert(Substituir, Retorno , Posicao);
   end;
Result := Retorno;
end;

function getword(tmp: string; pos:integer):string;
var c,i : integer;
    s: string;
begin

   c := 0;

   s := '';

   i := 1;

   while i <= length(tmp) do
   begin

     if tmp[i] <> ' ' then
     begin

        while (tmp[i] <> ' ') and (i <= length(tmp)) do
        begin

           s := s + tmp[i];

           i := i + 1;

        end;

        c := c + 1;

        if (c = pos) or (i = length(tmp)) then
        begin

          result := s;

          exit;

        end;

        s := '';

     end;

     i := i + 1;

   end;

   result := '';

end;


function DiaSemana(Data: TDateTime): String;
{Retorna o dia da semana em Extenso de uma determinada data}
const
  Dias : Array[1..7] of String[07] = ('dom', 'seg', 'ter','qua','qui', 'sex', 'sab');
begin
  Result := Dias[DayOfWeek(Data)];
end;


function blockjustify(s: string; tam:integer):string;
var i: integer;
begin

   i := length(s);

   while length(s) < tam do
   begin

     if (s[i] = ' ') then insert(' ',s,i);
     i := i - 1;

   end;

   blockjustify := s;

end;

//
// arredonda valor no formato 0.0123
//

function roundvalue(value: real):real;
var svalor: string;
    v: integer;
    c: string;
    i: integer;
begin

  if value = round(value) then
  begin
    result := value;
    exit;
  end;

  //
  //  Verifica se a casa depois da virgula
  //  é nove e torna o número inteiro mais um
  //

  svalor := FloatToStr(value)+'0000';

  if copy(svalor, pos(',', svalor)+1, 1) = '9' then
  begin
   result := trunc(value)+1;
   exit;
  end;

  //
  // Faz o arredondamento desde o final
  //

  for i := 5 downto 5 do
  begin

    if StrToInt(svalor[i]) >= 5 then
    begin

      if StrToInt(svalor[i-1]) < 9 then
      begin
        v := StrToInt(svalor[i-1])+1;
        c := IntToStr(v);
        svalor[i-1] := c[1];
      end
      else
      begin
        v := StrToInt(copy(svalor,i-2,2))+1;
        c := IntToStr(v);
        svalor[i-1] := c[2];
        svalor[i-2] := c[1];
      end;

    end;

  end;

  result := StrToFloat(copy(svalor,1,4));

end;

function day(data: TDate): Word;
var dia, mes, ano: word;
begin

   Decodedate(data, ano, mes, dia);

   result := dia;

end;


function month(data: TDate): Word;
var dia, mes, ano: word;
begin

   DecodeDate( data, ano, mes, dia);

   result := mes;

end;


function year(data: TDate): Word;
var dia, mes, ano: word;
begin

   Decodedate(data, ano, mes, dia);

   result := ano;

end;


function center(s: string; l: integer): string;
var spc: integer;
begin

 if length(s) > l then s := copy(s,1,l);

 spc := (l-length(s)) div 2;

 center := StringOfChar(' ',spc)+s;

end;


//
// Horas
//


function HrToMin(hora: String): Integer;
var p: integer;
begin

  p := pos(':', hora);

  if p > 0 then
   result := (StrToInt(copy(hora,1,p-1))*60) + StrToInt(copy(hora,p+1,2))
  else
   result := 0;

end;


function MinToHr(min: integer): String;
var m: integer;
begin

  m := DecToMin((min/60)-int(min/60));

  result := fillspacesl(inttostr(trunc(min/60)),3)+':'+fillzeros(inttostr(m),2);

  if length(trim(result)) = 4 then result := ' 0'+trim(result);

end;


function MinToDec(min:real): real;
begin

  result := min / 60;

end;


function DecToMin(dec:real): integer;
begin

  result := trunc((dec/1.666666) * 100);

end;

function VerificaCPF(Value: string): Boolean;
var
  localCPF       : string;
  localResult    : boolean;
  digit1, digit2 : integer;
  ii,soma        : integer;

begin

  localCPF := '';
  localResult := False;

  {analisa CPF no formato 999.999.999-00}
  if Length(Value) = 14 then
    if (Copy(Value,4,1)+Copy(Value,8,1)+Copy(Value,12,1) = '..-') then
      begin
      localCPF := Copy(Value,1,3) + Copy(Value,5,3) + Copy(Value,9,3) +
                   Copy(Value,13,2);
      localResult := True;
      end;

  {analisa CPF no formato 99999999900}
  if Length(Value) = 11 then
    begin
    localCPF := Value;
    localResult := True;
    end;

  {comeca a verificacao do digito}
  if localResult then
    try
      {1° digito}
      soma := 0;
      for ii := 1 to 9 do Inc(soma, StrToInt(Copy(localCPF, 10-ii, 1))*(ii+1));
      digit1 := 11 - (soma mod 11);
      if digit1 > 9 then digit1 := 0;

      {2° digito}
      soma := 0;
      for ii := 1 to 10 do Inc(soma, StrToInt(Copy(localCPF, 11-ii, 1))*(ii+1));
      digit2 := 11 - (soma mod 11);
      if digit2 > 9 then digit2 := 0;

      {Checa os dois dígitos}
      if (Digit1 = StrToInt(Copy(localCPF, 10, 1))) and
         (Digit2 = StrToInt(Copy(localCPF, 11, 1))) then
         localResult := True
      else
         localResult := False;
    except
      localResult := False;
    end;

  result := localResult;

end;

function VerificaCNPJ(Value: string): Boolean;

var
  localCGC       : string;
  localResult    : boolean;
  digit1, digit2 : integer;
  ii,soma        : integer;

begin

  localCGC := '';
  localResult := False;

  {analisa CNPJ no formato 99.999.999/9999-00}
  if Length(Value) = 18 then
    if (Copy(Value,3,1)+Copy(Value,7,1)+Copy(Value,11,1)+Copy(Value,16,1) = '../-') then
      begin
      localCGC := Copy(Value,1,2) + Copy(Value,4,3) + Copy(Value,8,3) +
                  Copy(Value,12,4) + Copy(Value,17,2);
      localResult := True;
      end;

  {analisa CGC no formato 99999999999900}
  if Length(Value) = 14 then
    begin
    localCGC := Value;
    localResult := True;
    end;

  {comeca a verificacao do digito}
  if localResult then
    try
      {1° digito}
      soma := 0;
      for ii := 1 to 12 do
      begin
        if ii < 5 then
          Inc(soma, StrToInt(Copy(localCGC, ii, 1))*(6-ii))
        else
          Inc(soma, StrToInt(Copy(localCGC, ii, 1))*(14-ii))
      end;
      digit1 := 11 - (soma mod 11);
      if digit1 > 9 then digit1 := 0;

      {2° digito}
      soma := 0;
      for ii := 1 to 13 do
      begin
        if ii < 6 then
          Inc(soma, StrToInt(Copy(localCGC, ii, 1))*(7-ii))
        else
          Inc(soma, StrToInt(Copy(localCGC, ii, 1))*(15-ii))
      end;
      digit2 := 11 - (soma mod 11);
      if digit2 > 9 then digit2 := 0;

      {Checa os dois dígitos}
      if (Digit1 = StrToInt(Copy(localCGC, 13, 1))) and
         (Digit2 = StrToInt(Copy(localCGC, 14, 1))) then
         localResult := True
      else
         localResult := False;
    except
      localResult := False;
    end;

  result := localResult;

end;



function replicate(tmp: string; count: integer): string;
var i: integer;
    str: string;
begin

  str := '';

  for i:= 1 to count do str:= str + tmp;

  result := Str;

end;

function GetFileVersion(const FileName: TFileName;
     var Major, Minor, Release, Build: word): boolean;
  // Returns True on success and False on failure.
  var
    size, len: longword;
    handle: THandle;
    buffer: pchar;
    pinfo: ^VS_FIXEDFILEINFO;

begin

    Result := False;
    size := GetFileVersionInfoSize(Pointer(FileName), handle);
    if size > 0 then begin
      GetMem(buffer, size);
      if GetFileVersionInfo(Pointer(FileName), 0, size, buffer)
      then
        if VerQueryValue(buffer, '\', pointer(pinfo), len) then begin
          Major   := HiWord(pinfo.dwFileVersionMS);
          Minor   := LoWord(pinfo.dwFileVersionMS);
          Release := HiWord(pinfo.dwFileVersionLS);
          Build   := LoWord(pinfo.dwFileVersionLS);
          Result  := True;
        end;
      FreeMem(buffer);
    end;

end;


function GetComputerName: string;
var pcComputer: PChar;
    dwCSize: DWORD;
begin

  dwCSize := MAX_COMPUTERNAME_LENGTH + 1;

  GetMem(pcComputer, dwCSize );

  try

    if Windows.GetComputerName(pcComputer, dwCSize ) then

       Result := pcComputer;

    finally

       FreeMem(pcComputer);

    end;

end;


function GetIdeDiskSerialNumber: String;
type
    TSrbIoControl = packed record
      HeaderLength : ULONG;
      Signature    : Array[0..7] of Char;
      Timeout      : ULONG;
      ControlCode  : ULONG;
      ReturnCode   : ULONG;
      Length       : ULONG;
    end;
    SRB_IO_CONTROL = TSrbIoControl;
    PSrbIoControl = ^TSrbIoControl;

    TIDERegs = packed record
      bFeaturesReg     : Byte; // especificar "comandos" SMART
      bSectorCountReg  : Byte; // registro de contador de setor
      bSectorNumberReg : Byte; // registro de número de setores
      bCylLowReg       : Byte; // valor de cilindro (byte mais baixo)
      bCylHighReg      : Byte; // valor de cilindro (byte mais alto)
      bDriveHeadReg    : Byte; // registro de drive/cabeça
      bCommandReg      : Byte; // comando IDE
      bReserved        : Byte; // reservado- tem que ser zero
    end;
    IDEREGS   = TIDERegs;
    PIDERegs  = ^TIDERegs;

    TSendCmdInParams = packed record
      cBufferSize  : DWORD;
      irDriveRegs  : TIDERegs;
      bDriveNumber : Byte;
      bReserved    : Array[0..2] of Byte;
      dwReserved   : Array[0..3] of DWORD;
      bBuffer      : Array[0..0] of Byte;
    end;
    SENDCMDINPARAMS   = TSendCmdInParams;
    PSendCmdInParams  = ^TSendCmdInParams;

    TIdSector = packed record
      wGenConfig                 : Word;
      wNumCyls                   : Word;
      wReserved                  : Word;
      wNumHeads                  : Word;
      wBytesPerTrack             : Word;
      wBytesPerSector            : Word;
      wSectorsPerTrack           : Word;
      wVendorUnique              : Array[0..2] of Word;
      sSerialNumber              : Array[0..19] of Char;
      wBufferType                : Word;
      wBufferSize                : Word;
      wECCSize                   : Word;
      sFirmwareRev               : Array[0..7] of Char;
      sModelNumber               : Array[0..39] of Char;
      wMoreVendorUnique          : Word;
      wDoubleWordIO              : Word;
      wCapabilities              : Word;
      wReserved1                 : Word;
      wPIOTiming                 : Word;
      wDMATiming                 : Word;
      wBS                        : Word;
      wNumCurrentCyls            : Word;
      wNumCurrentHeads           : Word;
      wNumCurrentSectorsPerTrack : Word;
      ulCurrentSectorCapacity    : ULONG;
      wMultSectorStuff           : Word;
      ulTotalAddressableSectors  : ULONG;
      wSingleWordDMA             : Word;
      wMultiWordDMA              : Word;
      bReserved                  : Array[0..127] of Byte;
    end;
    PIdSector = ^TIdSector;

  const
    IDE_ID_FUNCTION               = $EC;
    IDENTIFY_BUFFER_SIZE          = 512;
    DFP_RECEIVE_DRIVE_DATA        = $0007c088;
    IOCTL_SCSI_MINIPORT           = $0004d008;
    IOCTL_SCSI_MINIPORT_IDENTIFY  = $001b0501;
    DataSize = sizeof(TSendCmdInParams)-1+IDENTIFY_BUFFER_SIZE;
    BufferSize = SizeOf(SRB_IO_CONTROL)+DataSize;
    W9xBufferSize = IDENTIFY_BUFFER_SIZE+16;
  var
    hDevice : THandle;
    cbBytesReturned : DWORD;
    pInData : PSendCmdInParams;
    pOutData : Pointer; // PSendCmdOutParams
    Buffer : Array[0..BufferSize-1] of Byte;
    srbControl : TSrbIoControl absolute Buffer;

    procedure ChangeByteOrder( var Data; Size : Integer );
    var ptr : PChar;
        i : Integer;
        c : Char;
    begin
      ptr := @Data;
      for i := 0 to (Size shr 1)-1 do
      begin
        c := ptr^;
        ptr^ := (ptr+1)^;
        (ptr+1)^ := c;
        Inc(ptr,2);
      end;
    end;

  begin
    Result := '';
    FillChar(Buffer,BufferSize,#0);
    if Win32Platform=VER_PLATFORM_WIN32_NT then
       // Windows NT, Windows 2000, Windows XP
       begin
         // recuperar handle da porta SCSI
         hDevice := CreateFile('\\.\Scsi0:',
          // Nota: '\\.\C:' precisa de privilégios administrativos
          GENERIC_READ or GENERIC_WRITE,
          FILE_SHARE_READ or FILE_SHARE_WRITE,
          nil, OPEN_EXISTING, 0, 0);
        if hDevice=INVALID_HANDLE_VALUE then Exit;
        try
          srbControl.HeaderLength := SizeOf(SRB_IO_CONTROL);
          System.Move('SCSIDISK',srbControl.Signature,8);
          srbControl.Timeout      := 2;
          srbControl.Length       := DataSize;
          srbControl.ControlCode  := IOCTL_SCSI_MINIPORT_IDENTIFY;
          pInData := PSendCmdInParams(PChar(@Buffer)
                     +SizeOf(SRB_IO_CONTROL));
          pOutData := pInData;
          with pInData^ do
          begin
            cBufferSize  := IDENTIFY_BUFFER_SIZE;
            bDriveNumber := 0;
            with irDriveRegs do
            begin
              bFeaturesReg     := 0;
              bSectorCountReg  := 1;
              bSectorNumberReg := 1;
              bCylLowReg       := 0;
              bCylHighReg      := 0;
              bDriveHeadReg    := $A0;
              bCommandReg      := IDE_ID_FUNCTION;
            end;
          end;
          if not DeviceIoControl( hDevice, IOCTL_SCSI_MINIPORT,
            @Buffer, BufferSize, @Buffer, BufferSize,
            cbBytesReturned, nil ) then Exit;
        finally
          CloseHandle(hDevice);
        end;
      end
    else
       begin
        // Windows 95 OSR2, Windows 98, Windows ME
        hDevice := CreateFile( '\\.\SMARTVSD', 0, 0, nil,
          CREATE_NEW, 0, 0 );
        if hDevice=INVALID_HANDLE_VALUE then Exit;
        try
          pInData := PSendCmdInParams(@Buffer);
          pOutData := @pInData^.bBuffer;
          with pInData^ do
          begin
            cBufferSize  := IDENTIFY_BUFFER_SIZE;
            bDriveNumber := 0;
            with irDriveRegs do
            begin
              bFeaturesReg     := 0;
              bSectorCountReg  := 1;
              bSectorNumberReg := 1;
              bCylLowReg       := 0;
              bCylHighReg      := 0;
              bDriveHeadReg    := $A0;
              bCommandReg      := IDE_ID_FUNCTION;
            end;
          end;
          if not DeviceIoControl( hDevice, DFP_RECEIVE_DRIVE_DATA,
            pInData, SizeOf(TSendCmdInParams)-1, pOutData,
            W9xBufferSize, cbBytesReturned, nil ) then Exit;
        finally
          CloseHandle(hDevice);
        end;
      end;
      with PIdSector(PChar(pOutData)+16)^ do
      begin
        ChangeByteOrder(sSerialNumber,SizeOf(sSerialNumber));
        SetString(Result,sSerialNumber,SizeOf(sSerialNumber));
      end;

end;

function GetUserName(): string;
var vErrorCode: Variant;
    pcNetworkName: PChar;
    cBufferSize: Cardinal;
    me: Array [0..256] of Char;
begin

  cBufferSize := 127;     // size of the buffer for the name

  pcNetworkName := '';    // pchar of the network name

  vErrorCode := WNetGetUser(pcNetworkName, me, cBufferSize);  // i holds

  // error messages, me is assigned loginnamr

  result := string(me);

end;


function GetBiosSerial: string;
var
 sMainBoardBiosCopyright,
 sMainBoardBiosDate,
 sMainBoardBiosName,
 sMainBoardBiosSerialNo: string;
begin

  try
    sMainBoardBiosName := string(PChar(Ptr($FE061))); // Bios name
    sMainBoardBiosCopyright := string(PChar(Ptr($FE091))); // Bios copyright
    sMainBoardBiosDate := string(PChar(Ptr($FFFF5))); // Bios date
    sMainBoardBiosSerialNo := string(PChar(Ptr($FEC71)));  // Bios serial number
  except
    sMainBoardBiosName := 'Unsupported';
    sMainBoardBiosCopyright := 'Unsupported';
    sMainBoardBiosDate := 'Unsupported';
    sMainBoardBiosSerialNo := 'Unsupported';
  end;

  result := sMainBoardBiosSerialNo;

end;

function GetBiosCheckSum: string;
var
  s: int64;
  i: longword;
  p: PChar;
begin
  i := 0;
  s := 0;
  p := PChar($F0000);
  repeat
    inc(s, Int64(Ord(p^)) shl i);
    if i < 64 then inc(i) else i := 0;
    inc(p);
  until p > PChar($FFFFF);
  Result := IntToHex(s,16);
end;


function GetBiosInfoAsText: string;
var
  p, q: pchar;
begin
  q := nil;
  p := PChar(Ptr($FE000));
  repeat
    if q <> nil then begin
      if not (p^ in [#10, #13, #32..#126, #169, #184]) then begin
        if (p^ = #0) and (p - q >= 8) then begin
          Result := Result + TrimRight(String(q)) + #13#10;
        end;
        q := nil;
      end;
    end else
      if p^ in [#33..#126, #169, #184] then
        q := p;
    inc(p);
  until p > PChar(Ptr($FFFFF));
  Result := TrimRight(Result);
end;


function FindVolumeSerial(const Drive : PChar) : string;
var
   VolumeSerialNumber : DWORD;
   MaximumComponentLength : DWORD;
   FileSystemFlags : DWORD;
   SerialNumber : string;
begin
   Result:='';

   GetVolumeInformation(
        Drive,
        nil,
        0,
        @VolumeSerialNumber,
        MaximumComponentLength,
        FileSystemFlags,
        nil,
        0) ;
   SerialNumber :=
         IntToHex(HiWord(VolumeSerialNumber), 4) +
         '-' +
         IntToHex(LoWord(VolumeSerialNumber), 4) ;

   Result := SerialNumber;

end; (*FindVolumeSerial*)



//--------------------------------------------------
//Funções para manipulação de datas
//

//Retorna a data válida imediatamente anterior a uma data inválida
Function UltDataValida (Ano, Mes, Dia : Word) : TDateTime;
Var Continua : Boolean;
DataAux : TDateTime;
begin
Continua := True;
DataAux := date;
while Continua do
Try
DataAux := EncodeDate (Ano, Mes, Dia);
Continua := False;
Except
Dec (Dia);
End;
UltDataValida := DataAux;
end;

//Retorna a data válida imediatamente posterior a uma data inválida
Function ProxDataValida (Ano, Mes, Dia : Word) : TDateTime;
Var Continua : Boolean;
DataAux : TDateTime;
begin
Continua := True;
DataAux := date;
while Continua do
Try
DataAux := EncodeDate (Ano, Mes, Dia);
Continua := False;
Except
Inc(Dia);
End;
ProxDataValida := DataAux;
end;

//Retorna uma data no Mês seguinte a uma data informada
Function NextMonth (Data : TDateTime) : TDateTime;
var Ano, Mes, Dia : word;
begin
DecodeDate(Data, Ano, Mes, Dia);
if Mes = 12 Then begin
Mes := 1;
Inc (Ano);
end else
Inc (Mes);
NextMonth := UltDataValida (Ano, Mes, Dia);
end;

//Retorna uma data no Mês anterior a uma data informada
function PriorMonth (Data : TDateTime) : TDateTime;
var
  Ano, Mes, Dia : word;
begin
  DecodeDate(Data, Ano, Mes, Dia);

  if Mes = 1 then
  begin
    Mes := 12;
    Dec(Ano);
  end else
    Dec(Mes);

  PriorMonth := UltDataValida (Ano, Mes, Dia);
end;

//Retorna data do primeiro dia do mês, ou primeiro dia útil, de uma data informada
function FirstDayOfMonth(Data : TDateTime; lSabDom : Boolean): TDateTime;
var
  Ano, Mes, Dia : word;
  DiaDaSemana : Integer;
begin
  DecodeDate (Data, Ano, Mes, Dia);
  Dia := 1;
  if lSabDom then
  begin
    DiaDaSemana := DayOfWeek (Data);

    if DiaDaSemana = 1 then
      Dia := 2
    else if DiaDaSemana = 7 then
      Dia := 3;
  end;

  FirstDayOfMonth := EncodeDate (Ano, Mes, Dia);

end;

//Retorna data do último dia do mês, ou último dia útil, de uma data informada
Function LastDayOfMonth (Data : TDateTime; lSabDom : Boolean) : TDateTime;
var Ano, Mes, Dia : word;
AuxData : TDateTime;
DiaDaSemana : Integer;
begin
AuxData := FirstDayOfMonth (NextMonth (Data), False) - 1;
if lSabDom Then begin
DecodeDate (Auxdata, Ano, Mes, Dia);
DiaDaSemana := DayOfWeek (AuxData);
if DiaDaSemana = 1 Then
Dia := Dia - 2
else
if DiaDaSemana = 7 Then
Dec (Dia);
AuxData := EnCodeDate (Ano, Mes, Dia);
end;
LastDayOfMonth := AuxData;
end;

//Verifica se uma data informada cai em um final de semana
Function IsWeekEnd (dData : TDateTime) : boolean;
begin
result := false;
if (DayOfWeek(dData) = 1) or (DayOfWeek(dData) = 7) Then
result := true;
end;

//Retorna o próximo dia útil caso a data informada caia em um fim de semana
Function ProximoDiaUtil (dData : TDateTime) : TDateTime;
begin
if DayOfWeek(dData) = 7 then
dData := dData + 2
else if DayOfWeek(dData) = 1 then
dData := dData + 1;
ProximoDiaUtil := dData;
end;

//Retorna o último dia útil caso a data informada caia em um fim de semana
Function DiaUtilAnterior (dData : TDateTime) : TDateTime;
begin
if DayOfWeek(dData) = 7 then
dData := dData - 1
else if DayOfWeek(dData) = 1 then
dData := dData - 2;
DiaUtilAnterior := dData;
end;

//Retorna uma data acrescida de "xMeses" meses, podendo ser corrido ou não
Function SomaMes (dData : TDateTime; xMeses : Integer; lCorrido : boolean) : TDateTime;
var Ano, Mes, Dia : word;
DataAux : TDateTime;
begin
DecodeDate(dData, Ano, Mes, Dia);
Mes := Mes + xMeses;
Ano := Ano + (Mes DIV 12);
Mes := Mes mod 12;
DataAux := UltDataValida (Ano, Mes, Dia);
if not lCorrido Then
DataAux := DataAux - 1;
SomaMes := DataAux;
end;

//Retorna uma data reduzida de "xMeses" meses, podendo ser corrido ou não
Function DiminuiMes (dData : TDateTime; xMeses : Integer; lCorrido : Boolean) : TDateTime;
var Ano, Mes, Dia : word;
DataAux : TDateTime;
xMes : SmallInt;
begin
DecodeDate(dData, Ano, Mes, Dia);
Ano := Ano - (xMeses DIV 12);
xMeses := xMeses mod 12;
xMes := Mes - xMeses;
if xMes > 0 Then
Mes := xMes
else begin
Ano := Ano -1;
Mes := xMes + 12;
end;
DataAux := UltDataValida (Ano, Mes, Dia);
if not lCorrido then
DataAux := DataAux + 1;
DiminuiMes := DataAux;
end;

{
//--------------------------------------------------

function CreateShortcut(SourceFileName: string; // the file the shortcut points to
                        Location: ShortcutType; // shortcut location
                        SubFolder,  // subfolder of location
                        WorkingDir, // working directory property of the shortcut
                        Parameters,
                        Description: string): //  description property of the shortcut
                        string;
const
  SHELL_FOLDERS_ROOT = 'Software\MicroSoft\Windows\CurrentVersion\Explorer';
  QUICK_LAUNCH_ROOT = 'Software\MicroSoft\Windows\CurrentVersion\GrpConv';
var
  MyObject: IUnknown;
  MySLink: IShellLink;
  MyPFile: IPersistFile;
  Directory, LinkName: string;
  WFileName: WideString;
  Reg: TRegIniFile;
begin

  MyObject := CreateComObject(CLSID_ShellLink);
  MySLink := MyObject as IShellLink;
  MyPFile := MyObject as IPersistFile;

  MySLink.SetPath(PChar(SourceFileName));
  MySLink.SetArguments(PChar(Parameters));
  MySLink.SetDescription(PChar(Description));

  LinkName := ChangeFileExt(SourceFileName, '.lnk');
  LinkName := ExtractFileName(LinkName);

  // Quicklauch
  if Location = scQUICKLAUNCH then
  begin
    Reg := TRegIniFile.Create(QUICK_LAUNCH_ROOT);
    try
      Directory := Reg.ReadString('MapGroups', 'Quick Launch', '');
    finally
      Reg.Free;
    end;
  end
  else
  // Other locations
  begin
    Reg := TRegIniFile.Create(SHELL_FOLDERS_ROOT);
    try
    case Location of
      scOTHERFOLDER : Directory := SubFolder;
      scDESKTOP     : Directory := Reg.ReadString('Shell Folders', 'Desktop', '');
      scSTARTMENU   : Directory := Reg.ReadString('Shell Folders', 'Start Menu', '');
      scSENDTO      : Directory := Reg.ReadString('Shell Folders', 'SendTo', '');
    end;
    finally
      Reg.Free;
    end;
  end;

  if Directory <> '' then
  begin

    if (SubFolder <> '') and (Location <> scOTHERFOLDER) then
      WFileName := Directory + '\' + SubFolder + '\' + LinkName
    else
      WFileName := Directory + '\' + LinkName;


    if WorkingDir = '' then
      MySLink.SetWorkingDirectory(PChar(ExtractFilePath(SourceFileName)))
    else
      MySLink.SetWorkingDirectory(PChar(WorkingDir));

    MyPFile.Save(PWChar(WFileName), False);

    Result := WFileName;

  end;

end;

function GetProgramDir: string;
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_CURRENT_USER;
    reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False);
    Result := reg.ReadString('Programs');
    reg.CloseKey;
  finally
    reg.Free;
  end;
end;
 }

{
 function CreateAShortcut(aTarget,startDir,aCaption,aGroup: string;
   aLoc: TShortcut; silent: Boolean): Boolean;

 HISTORY:  Original version by
 ========  - Jon E. Scott
      web: http://members.xoom.com/jescott  ("Delphi Code Tips")
      email: jescott@xoommail.com

     Some improvements and comments 1999-06-18 by
     Bjorn Mossberg: mossberg@mindspring.com

 PURPOSE:  To create a shortcut on the desktop, start menu,
 ========  in a program group, in the SendTo folder,
     or in the SysTray region.

 REQUIRES:
 =========
 uses ShlObj, ComObj, Registry, ActiveX; // and others

 type
  TShortcut = (sc_Desktop, sc_QuickLaunch, sc_SendTo,
      sc_Start, sc_Programs);

 PARAMETERS:
 ===========

 aTarget:  The full path to the executable file
     for which a shortcut is to be created.

 startDir: String specifying the folder that is to be made
     current before aTarget executes. May be blank.

 aCaption: String specifying the "legend" to be written
     under the icon. May be left blank, in which
     case the name of the executable file minus
     its extension is used.
     Caution: Use only legal file characters!

 aGroup:  Meaningful only when aLoc=sc_Programs,
     sc_Desktop, or sc_SendTo.
     Specifies the name of the subfolder to
     which the shortcut is to be added.
     Should already exist.

 aLoc:   One of the values of type ShortcutType:

}

function CreateShortcut(aTarget,startDir,aCaption,aGroup: string;
   aLoc: TShortcut; silent: Boolean): Boolean;
var
 anObject: IUnknown;

 function MergedPath(rootDir,subDir: String): String;
 var
  n: Integer;
 begin
  n := Length(rootDir);
  if n=0 then Result := subDir
  else begin
   if rootDir[n]='\' then Delete(rootDir,n,1);
   n := Length(subDir);
   if n=0 then Result := rootDir
   else begin
    if subDir[1]='\' then Delete(subDir,1,1);
    Result := rootDir + '\' + subDir;
   end;
  end;
 end;

 function SaveLinkFile(aCap,aFldr: String): Boolean;
 var
  aPFile: IPersistFile;
  s,fName: String;
  wName: WideString;
  i:   Integer;
 begin
  {Save a copy of the object as a link file.
  Try up to 3 times, using tails " (2)" and " (3)".}
  Result := False;
  aPFile := anObject as IPersistFile;
  s   := EmptyStr;
  for i:=1 to 3 do begin
   fName  := aCap + s + '.lnk';
   wName  := MergedPath(aFldr,fName);
   Result := S_OK=aPFile.Save(PWChar(wName), False);
   if Result then Break;
   s := Format(' (%d)',[i]);
  end;
 end;


const
 BaseKey   = 'Software\MicroSoft\Windows\CurrentVersion';
 Shell_Folders = 'Shell Folders';
 VDesktop   = 'Desktop';
 ProgramMenu  = '"Start | Programs" menu';
var
 aDir,aVar: String;
 aDesc:  String;
 dskTop:  String;
 s,msg:  String;
begin
 Result := False;
 if NOT (CoInitialize(nil) in [S_OK,S_FALSE]) then begin
  //ShowMessage('Could not initialize OLE COM Library');
  Exit;
 end;

 {Create an object that can be used as a shortcut
 and later saved as a customized ???.lnk file.}
 anObject := CreateComObject(CLSID_ShellLink);
 try
  with anObject as IShellLink do begin
   {Write in "Target" in the link file:
    The full path of the executable file}
   SetPath(PChar(aTarget));

   {If supplied, write in "Start In" in the link file:
    The folder to be made current before executing "Target".}
   if (Length(startDir)>0) AND DirectoryExists(startDir) then
    SetWorkingDirectory(PChar(startDir));
  end;

  {If aCaption is supplied we use that as the caption
  under the icon representing the shortcut.
  Otherwise we simply strip the extension
  from the name of the target file.
  NOTE: The name of the link file is "aCaption.lnk". }
  if Length(aCaption)=0 then
   aCaption := ExtractFileName(aTarget);
  //aCaption := ReplaceAll(aCaption,'/','-'); {May need other fixing.}
  aCaption := ChangeFileExt(aCaption, EmptyStr);

  aVar := EmptyStr;
  aDesc := EmptyStr;
  case aLoc of
   scStart:  aVar := 'Start Menu';
   scPrograms: begin
         aVar := 'Programs';
         aDesc := ProgramMenu;
        end;
   scSendTo:  begin
         aVar := 'SendTo';
         aDesc := aVar + ' menu';
        end;
   scQuickLaunch:
    with TRegIniFile.Create(BaseKey+'\GrpConv') do try
     aVar := 'Quick Launch'; {Need aVar for msg later}
     aDir := ReadString('MapGroups',aVar,EmptyStr);
     aDesc := aVar +  ' (SysTray) area';
    finally
     Free;
    end;
  else
   aVar := VDesktop; {Default}
  end;
  if Length(aDesc)=0 then
   aDesc := aVar;

  with TRegIniFile.Create(BaseKey+'\Explorer') do try
   {Always get the path to the Desktop as a fallback.}
   dskTop := ReadString(Shell_Folders,VDesktop,EmptyStr);
   if Length(aDir)=0 then begin
    {Here for all cases except _QUICKLAUNCH}
    if Length(aVar)>0 then {Paranoid check}
     aDir := ReadString(Shell_Folders,aVar,EmptyStr);
    if Length(aDir)=0 then {Should never happen, but ...}
     aDir := dskTop;
   end;
  finally
   Free;
  end;

  if Length(aDir)=0 then
   {Hard to imagine that we'll ever be here.}
   //ShowMessage('Could not determine where to create new shortcut!')
  else begin
   msg := Format('Added shortcut "%s" to the %s',[aCaption,aDesc]);
   {Subfolders do not make sense for the SysTray or StartMenu.}
   if (Length(aGroup)>0) AND
    (aLoc in [scDesktop,scSendTo,scPrograms]) then
   begin
    {The caller is suggesting a subfolder which
    we hope exists. Use it only if it does!}
    s := MergedPath(aDir,aGroup);
    if DirectoryExists(s) then begin
     aDir := s;
     AppendStr(msg,Format(' in the subfolder "%s"',[aGroup]));
    end else
     msg := Format('"%s" is not a subfolder of the %s.'
      +' Added the shortcut directly instead.',[aGroup,aDesc]);
   end;

   {Save a copy of the object as a link file.
   Try up to 3 times, using tails " (2)" and " (3)".}
   Result := SaveLinkFile(aCaption,aDir);

   if NOT Result then
    msg := 'Could not create shortcut to ' + aTarget;
   if NOT Result OR NOT silent then
    ShowMessage(msg);

   if (Length(dskTop)>0) AND (aDir<>dskTop) AND
    {Since the dskTop folder is well defined, and not the
    one we just added the shortcut to, we offer to add a
    copy of the shortcut to the Desktop as well.
    We do this whether we failed above or not.}
    (mrYes=MessageDlg('Would you like to add a copy'+
      ' of the shortcut to the desktop?',
      mtConfirmation,[mbYes,mbNo],0)) then
   begin
    {Don't reset Result unless we are successful!}
    msg := 'esktop shortcut to '+aTarget;
    if SaveLinkFile(aCaption,dskTop) then begin
     Result := True;
     msg  := 'D'+msg+' successfully created!';
    end else
     msg := 'Could not create d'+msg;
    if NOT Result OR NOT silent then
     ShowMessage(msg);
   end;
  end;
 finally
//  TComObject(anObject).Free; {Cannot do this! Memory leak???}
  CoUninitialize;
 end;
end;

function GetComputerIP: String;
var
 WSAData: TWSAData;
 HostEnt: PHostEnt;
 Name,IP:string;
begin

 WSAStartup(2, WSAData);
 SetLength(Name, 255);
 Gethostname(PChar(Name), 255);
 SetLength(Name, StrLen(PChar(Name)));
 HostEnt := gethostbyname(PChar(Name));

 with HostEnt^ do
 begin
  IP := Format('%d.%d.%d.%d',
  [Byte(h_addr^[0]),Byte(h_addr^[1]),
  Byte(h_addr^[2]),Byte(h_addr^[3])]);
 end;

 result := IP;

 WSACleanup;

end;


procedure PostKeyEx32(key: Word; const shift: TShiftState; specialkey: Boolean);
{************************************************************
* Procedure PostKeyEx32
*
* Parameters:
*  key    : virtual keycode of the key to send. For printable
*           keys this is simply the ANSI code (Ord(character)).
*  shift  : state of the modifier keys. This is a set, so you
*           can set several of these keys (shift, control, alt,
*           mouse buttons) in tandem. The TShiftState type is
*           declared in the Classes Unit.
*  specialkey: normally this should be False. Set it to True to
*           specify a key on the numeric keypad, for example.
* Description:
*  Uses keybd_event to manufacture a series of key events matching
*  the passed parameters. The events go to the control with focus.
*  Note that for characters key is always the upper-case version of
*  the character. Sending without any modifier keys will result in
*  a lower-case character, sending it with [ssShift] will result
*  in an upper-case character!
// Code by P. Below
************************************************************}
type
  TShiftKeyInfo = record
    shift: Byte;
    vkey: Byte;
  end;
  byteset = set of 0..7;
const
  shiftkeys: array [1..3] of TShiftKeyInfo =
    ((shift: Ord(ssCtrl); vkey: VK_CONTROL),
    (shift: Ord(ssShift); vkey: VK_SHIFT),
    (shift: Ord(ssAlt); vkey: VK_MENU));
var
  flag: DWORD;
  bShift: ByteSet absolute shift;
  i: Integer;
begin
  for i := 1 to 3 do
  begin
    if shiftkeys[i].shift in bShift then
      keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0), 0, 0);
  end; { For }
  if specialkey then
    flag := KEYEVENTF_EXTENDEDKEY
  else
    flag := 0;

  keybd_event(key, MapvirtualKey(key, 0), flag, 0);
  flag := flag or KEYEVENTF_KEYUP;
  keybd_event(key, MapvirtualKey(key, 0), flag, 0);

  for i := 3 downto 1 do
  begin
    if shiftkeys[i].shift in bShift then
      keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0),
        KEYEVENTF_KEYUP, 0);
  end; { For }
end; { PostKeyEx32 }




//-------------------------------------
// return TRUE if the specified
// service is running, defined by
// the status code SERVICE_RUNNING.
// return FALSE if the service
// is in any other state, including
// any pending states
//
function ServiceRunning(
  sMachine,
  sService : string ) : boolean;
begin
  Result := SERVICE_RUNNING =
    ServiceGetStatus(
      sMachine, sService );
end;


//-------------------------------------
// return TRUE if the specified
// service was stopped, defined by
// the status code SERVICE_STOPPED.
//
function ServiceStopped(
  sMachine,
  sService : string ) : boolean;
begin
  Result := SERVICE_STOPPED =
    ServiceGetStatus(
      sMachine, sService );
end;


//-------------------------------------
// get service status
//
// return status code if successful
// -1 if not
//
// return codes:
//   SERVICE_STOPPED
//   SERVICE_RUNNING
//   SERVICE_PAUSED
//
// following return codes
// are used to indicate that
// the service is in the
// middle of getting to one
// of the above states:
//   SERVICE_START_PENDING
//   SERVICE_STOP_PENDING
//   SERVICE_CONTINUE_PENDING
//   SERVICE_PAUSE_PENDING
//
// sMachine:
//   machine name, ie: \SERVER
//   empty = local machine
//
// sService
//   service name, ie: Alerter
//
function ServiceGetStatus(sMachine, sService: string): DWord;
var
  //
  // service control
  // manager handle
  schm,
  //
  // service handle
  schs   : SC_Handle;
  //
  // service status
  ss     : TServiceStatus;
  //
  // current service status
  dwStat : integer;

begin

  dwStat := -1;

  // connect to the service
  // control manager
  schm := OpenSCManager(
    PChar(sMachine),
    Nil,
    SC_MANAGER_CONNECT);

  // if successful...
  if(schm > 0)then
  begin
    // open a handle to
    // the specified service
    schs := OpenService(
      schm,
      PChar(sService),
      // we want to
      // query service status
      SERVICE_QUERY_STATUS);

    // if successful...
    if(schs > 0)then
    begin
      // retrieve the current status
      // of the specified service
      if(QueryServiceStatus(
           schs,
           ss))then
      begin
        dwStat := ss.dwCurrentState;
      end;

      // close service handle
      CloseServiceHandle(schs);
    end;

    // close service control
    // manager handle
    CloseServiceHandle(schm);
  end;

  Result := dwStat;
end;


//
// start service
//
// return TRUE if successful
//
// sMachine:
//   machine name, ie: \SERVER
//   empty = local machine
//
// sService
//   service name, ie: Alerter
//
function ServiceStart(sMachine, sService: string ): boolean;
var
  //
  // service control
  // manager handle
  schm,
  //
  // service handle
  schs   : SC_Handle;
  //
  // service status
  ss     : TServiceStatus;
  //
  // temp char pointer
  psTemp : PChar;
  //
  // check point
  dwChkP : DWord;

begin

  ss.dwCurrentState := 0;

  // connect to the service
  // control manager
  schm := OpenSCManager(
    PChar(sMachine),
    Nil,
    SC_MANAGER_CONNECT);

  // if successful...
  if(schm > 0)then
  begin
    // open a handle to
    // the specified service
    schs := OpenService(
      schm,
      PChar(sService),
      // we want to
      // start the service and
      SERVICE_START or
      // query service status
      SERVICE_QUERY_STATUS);

    // if successful...
    if(schs > 0)then
    begin
      psTemp := Nil;
      if(StartService(
           schs,
           0,
           psTemp))then
      begin
        // check status
        if(QueryServiceStatus(
             schs,
             ss))then
        begin
          while(SERVICE_RUNNING
            <> ss.dwCurrentState)do
          begin
            //
            // dwCheckPoint contains a
            // value that the service
            // increments periodically
            // to report its progress
            // during a lengthy
            // operation.
            //
            // save current value
            //
            dwChkP := ss.dwCheckPoint;

            //
            // wait a bit before
            // checking status again
            //
            // dwWaitHint is the
            // estimated amount of time
            // the calling program
            // should wait before calling
            // QueryServiceStatus() again
            //
            // idle events should be
            // handled here...
            //
            Sleep(ss.dwWaitHint);

            if(not QueryServiceStatus(
                 schs,
                 ss))then
            begin
              // couldn't check status
              // break from the loop
              break;
            end;

            if(ss.dwCheckPoint <
              dwChkP)then
            begin
              // QueryServiceStatus
              // didn't increment
              // dwCheckPoint as it
              // should have.
              // avoid an infinite
              // loop by breaking
              break;
            end;
          end;
        end;
      end;

      // close service handle
      CloseServiceHandle(schs);
    end;

    // close service control
    // manager handle
    CloseServiceHandle(schm);
  end;

  // return TRUE if
  // the service status is running
  Result :=
    SERVICE_RUNNING =
      ss.dwCurrentState;
end;


//
// stop service
//
// return TRUE if successful
//
// sMachine:
//   machine name, ie: \SERVER
//   empty = local machine
//
// sService
//   service name, ie: Alerter
//
function ServiceStop(
  sMachine,
  sService : string ) : boolean;
var
  //
  // service control
  // manager handle
  schm,
  //
  // service handle
  schs   : SC_Handle;
  //
  // service status
  ss     : TServiceStatus;
  //
  // check point
  dwChkP : DWord;
begin
  // connect to the service
  // control manager
  schm := OpenSCManager(
    PChar(sMachine),
    Nil,
    SC_MANAGER_CONNECT);

  // if successful...
  if(schm > 0)then
  begin
    // open a handle to
    // the specified service
    schs := OpenService(
      schm,
      PChar(sService),
      // we want to
      // stop the service and
      SERVICE_STOP or
      // query service status
      SERVICE_QUERY_STATUS);

    // if successful...
    if(schs > 0)then
    begin
      if(ControlService(
           schs,
           SERVICE_CONTROL_STOP,
           ss))then
      begin
        // check status
        if(QueryServiceStatus(
             schs,
             ss))then
        begin
          while(SERVICE_STOPPED
            <> ss.dwCurrentState)do
          begin
            //
            // dwCheckPoint contains a
            // value that the service
            // increments periodically
            // to report its progress
            // during a lengthy
            // operation.
            //
            // save current value
            //
            dwChkP := ss.dwCheckPoint;

            //
            // wait a bit before
            // checking status again
            //
            // dwWaitHint is the
            // estimated amount of time
            // the calling program
            // should wait before calling
            // QueryServiceStatus() again
            //
            // idle events should be
            // handled here...
            //
            Sleep(ss.dwWaitHint);

            if(not QueryServiceStatus(
                 schs,
                 ss))then
            begin
              // couldn't check status
              // break from the loop
              break;
            end;

            if(ss.dwCheckPoint <
              dwChkP)then
            begin
              // QueryServiceStatus
              // didn't increment
              // dwCheckPoint as it
              // should have.
              // avoid an infinite
              // loop by breaking
              break;
            end;
          end;
        end;
      end;

      // close service handle
      CloseServiceHandle(schs);
    end;

    // close service control
    // manager handle
    CloseServiceHandle(schm);
  end;

  // return TRUE if
  // the service status is stopped
  Result :=
    SERVICE_STOPPED =
      ss.dwCurrentState;
end;

function FileInUse(FileName: string): Boolean;
var hFileRes: HFILE;
begin
  Result := False;
  if not FileExists(FileName) then exit;
  hFileRes := CreateFile(PChar(FileName),
                                    GENERIC_READ or GENERIC_WRITE,
                                    0,
                                    nil,
                                    OPEN_EXISTING,
                                    FILE_ATTRIBUTE_NORMAL,
                                    0);
  Result := (hFileRes = INVALID_HANDLE_VALUE);
  if not Result then
    CloseHandle(hFileRes);
end;

{

You can write a value to one of two keys in the Windows Registry
under the HKEY_LOCAL_MACHINE root key:

Software\Microsoft\Windows\CurrentVersion\RunOnce:
the application will start just ONCE, on the next startup of Windows.
Afterwards, the new registry key is deleted automatically.

Software\Microsoft\Windows\CurrentVersion\Run:
in this case, the application will start on EVERY Windows startup.
The registry key that was created will stay in the registry, until you delete it.

}

procedure RunOnStartUp(ApTitle, ApPathFile: string; RunOnce: Boolean);
var
  Reg: TRegistry;
  TheKey: string;
begin
  Reg := TRegistry.Create;
  Reg.RootKey := HKEY_LOCAL_MACHINE;
  TheKey := 'Software\Microsoft\Windows\CurrentVersion\Run';
  if RunOnce then TheKey := TheKey + 'Once';
  // Open key, or create it if it doesn't exist
  Reg.OpenKey(TheKey, True);
  Reg.WriteString(ApTitle, ApPathFile);
  Reg.CloseKey;
  Reg.Free;
end;

{

Here's the Delphi source code for deleting an
entry from the Software\Microsoft\Windows\CurrentVersion\Run key,
located in the HKEY_LOCAL_MACHINE root key:

}

procedure RemoveFromStartUp(ApTitle: string);
var
  Reg: TRegistry;
  TheKey: string;
  ListOfEntries: TStringList;
  i: integer;
begin
  Reg := TRegistry.Create;
  Reg.RootKey := HKEY_LOCAL_MACHINE;
  TheKey := 'Software\Microsoft\Windows\CurrentVersion\Run';
  // Check if key exist...
  // ...if yes, try to delete the entry for ApTitle
  if not Reg.OpenKey(TheKey, False) then
    ShowMessage('Key not found')
  else begin
    if Reg.DeleteValue(ApTitle) then
     // ShowMessage('Removed: ' + ApTitle)
    else
     // ShowMessage('Not found: ' + ApTitle);
  end;
  Reg.CloseKey;
  Reg.Free;
end;


function CheckStartUp(ApTitle: string): boolean;
var
  Reg: TRegistry;
  TheKey: string;
  value: string;
  ListOfEntries: TStringList;
  i: integer;
begin

  Reg := TRegistry.Create;
  Reg.RootKey := HKEY_LOCAL_MACHINE;
  TheKey := 'Software\Microsoft\Windows\CurrentVersion\Run';

  // Check if key exist...

  if Reg.OpenKey(TheKey, False) then
  begin

  value := Reg.ReadString(ApTitle);

  if value = '' then
    result := False
  else
    result := True;

  end
  else
  begin

   result := False

  end;

  Reg.CloseKey;
  Reg.Free;

end;


//
// SetRegistryData(HKEY_LOCAL_MACHINE,
//  '\Software\Microsoft\Windows\CurrentVersion',
//  'RegisteredOrganization', rdString, 'Latium Software');
//

procedure SetRegistryData(RootKey: HKEY; Key, Value: string;
  RegDataType: TRegDataType; Data: variant);
var
  Reg: TRegistry;
  s: string;
begin
  Reg := TRegistry.Create(KEY_WRITE);
  try
    Reg.RootKey := RootKey;
    if Reg.OpenKey(Key, True) then begin
      try
        if RegDataType = rdUnknown then
          RegDataType := Reg.GetDataType(Value);
        if RegDataType = rdString then
          Reg.WriteString(Value, Data)
        else if RegDataType = rdExpandString then
          Reg.WriteExpandString(Value, Data)
        else if RegDataType = rdInteger then
          Reg.WriteInteger(Value, Data)
        else if RegDataType = rdBinary then begin
          s := Data;
          Reg.WriteBinaryData(Value, PChar(s)^, Length(s));
        end else
          raise Exception.Create(SysErrorMessage(ERROR_CANTWRITE));
      except
        Reg.CloseKey;
        raise;
      end;
      Reg.CloseKey;
    end else
      raise Exception.Create(SysErrorMessage(GetLastError));
  finally
    Reg.Free;
  end;
end;

function GetRegistryData(RootKey: HKEY; Key, Value: string): variant;
var
  Reg: TRegistry;
  RegDataType: TRegDataType;
  DataSize, Len: integer;
  s: string;
label cantread;
begin
  Reg := nil;
  try
    Reg := TRegistry.Create(KEY_QUERY_VALUE);
    Reg.RootKey := RootKey;
    if Reg.OpenKeyReadOnly(Key) then begin
      try
        RegDataType := Reg.GetDataType(Value);
        if (RegDataType = rdString) or
           (RegDataType = rdExpandString) then
          Result := Reg.ReadString(Value)
        else if RegDataType = rdInteger then
          Result := Reg.ReadInteger(Value)
        else if RegDataType = rdBinary then begin
          DataSize := Reg.GetDataSize(Value);
          if DataSize = -1 then goto cantread;
          SetLength(s, DataSize);
          Len := Reg.ReadBinaryData(Value, PChar(s)^, DataSize);
          if Len <> DataSize then goto cantread;
          Result := s;
        end else
cantread:
          raise Exception.Create(SysErrorMessage(ERROR_CANTREAD));
      except
        s := ''; // Deallocates memory if allocated
        Reg.CloseKey;
        raise;
      end;
      Reg.CloseKey;
    end else
      raise Exception.Create(SysErrorMessage(GetLastError));
  except
    Reg.Free;
    raise;
  end;
  Reg.Free;
end;


function RightStr(Const Str: String; Size: Word): String;
begin
  if Size > Length(Str) then Size := Length(Str) ;
  RightStr := Copy(Str, Length(Str)-Size+1, Size)
end;

function MidStr(Const Str: String; From, Size: Word): String;
begin
  MidStr := Copy(Str, From, Size)
end;

function LeftStr(Const Str: String; Size: Word): String;
begin
  LeftStr := Copy(Str, 1, Size)
end;

//
// Usage (fills in Memo1) :
// ParseDelimited(Memo1.lines,'Zarko;Gajic;;DelphiGuide',';')
//

procedure ParseDelimited(const sl : TStrings; const value : string; const delimiter : string) ;
var
   dx : integer;
   ns : string;
   txt : string;
   delta : integer;
begin
   delta := Length(delimiter) ;
   txt := value + delimiter;
   sl.BeginUpdate;
   sl.Clear;
   try
     while Length(txt) > 0 do
     begin
       dx := Pos(delimiter, txt) ;
       ns := Copy(txt,0,dx-1) ;
       sl.Add(ns) ;
       txt := Copy(txt,dx+delta,MaxInt) ;
     end;
   finally
     sl.EndUpdate;
   end;
end;


//
// Enviar Email Pelo Outlook
//

function EnviarEmail(Endereco: String; Assunto: String = ''; Texto: String = '';
  stlAnexo: TStringList = nil; AEnviarDireto: boolean = False): Boolean;
type
  TAttachAccessArray = array [0..0] of TMapiFileDesc;
  PAttachAccessArray = ^TAttachAccessArray;
var
  MapiMessage: TMapiMessage;
  MError: Cardinal;
  Sender: TMapiRecipDesc;
  PRecip, Recipients: PMapiRecipDesc;

  Attachments: PAttachAccessArray;
  x: integer;
begin

  Result := False;
  MapiMessage.nRecipCount := 1;
  GetMem( Recipients, MapiMessage.nRecipCount * Sizeof(TMapiRecipDesc) );
  Attachments := nil;

  try
    with MapiMessage do
    begin
      { Assunto e Texto }
      ulReserved := 0;
      lpszSubject :=  PAnsichar(PChar( Assunto ));
      lpszNoteText := PAnsichar(PChar( Texto ));

      lpszMessageType := nil;
      lpszDateReceived := nil;
      lpszConversationID := nil;
      flFlags := 0;
      Sender.ulReserved := 0;
      Sender.ulRecipClass := MAPI_ORIG;
      Sender.lpszName := PAnsichar(PChar( '' ));
      Sender.lpszAddress := PAnsichar(PChar( '' ));
      Sender.ulEIDSize := 0;
      Sender.lpEntryID := nil;
      lpOriginator := @Sender;

      { Endereço }
      PRecip := Recipients;
      PRecip^.ulReserved := 0;
      PRecip^.ulRecipClass := MAPI_TO;

      PRecip^.lpszName := PAnsichar(PChar( Endereco ));
      PRecip^.lpszAddress := StrNew( PAnsichar(PChar('SMTP:' + Endereco ) ));

      PRecip^.ulEIDSize := 0;
      PRecip^.lpEntryID := nil;
      //Inc( PRecip );
      lpRecips := Recipients;

      { Anexa os arquivos }
      if stlAnexo = nil then
      begin
        stlAnexo := TStringList.Create;
        stlAnexo.Clear;
      end;

      { Deleta do stlAnexo os arquivos que não existem }
      for x := 0 to stlAnexo.Count - 1 do
        if not FileExists( stlAnexo.Strings[x] ) then
          stlAnexo.Delete(x);

      { Anexa os arquivos }
      if stlAnexo.Count > 0 then
      begin
        GetMem(Attachments, SizeOf(TMapiFileDesc) * stlAnexo.Count);
        for x := 0 to stlAnexo.Count - 1 do
        begin
          Attachments[x].ulReserved := 0;
          Attachments[x].flFlags := 0;
          Attachments[x].nPosition := ULONG($FFFFFFFF);
          Attachments[x].lpszPathName := StrNew( PAnsichar(PChar(stlAnexo.Strings[x]) ));
          Attachments[x].lpszFileName :=
          StrNew( PAnsichar(PChar( ExtractFileName(stlAnexo.Strings[x]) ) ));
          Attachments[x].lpFileType := nil;
        end;
      end
      {endif};
      nFileCount := stlAnexo.Count;
      lpFiles := @Attachments^;
    end;

    { Enviando o e-mail }
    if not AEnviarDireto then
      MError := MapiSendMail(0, Application.Handle, MapiMessage, MAPI_DIALOG or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0)
    else
      MError := MapiSendMail(0, Application.Handle, MapiMessage, MAPI_LOGON_UI or MAPI_NEW_SESSION or MAPI_SENT, 0);

    case MError of
      MAPI_E_USER_ABORT: ;
      { Mostra mensagem que o envio do e-mail foi abortado pelo usuário.
      Portanto, não será mostrado nada }

      SUCCESS_SUCCESS:
      Result := True;
    else
      MessageDlg( 'Ocorreu um erro inesperado!'#13'Código: ' +
      IntToStr(MError), mtError, [mbOk], 0);
    end;
  finally
    PRecip := Recipients;
    StrDispose( PRecip^.lpszAddress );
    //Inc( PRecip );

    FreeMem( Recipients, MapiMessage.nRecipCount * Sizeof(TMapiRecipDesc) );
    for x := 0 to stlAnexo.Count - 1 do
    begin
      StrDispose( Attachments[x].lpszPathName );
      StrDispose( Attachments[x].lpszFileName );
    end;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
// Procedure - join                                                           //
// Author    - Ronald Buster                                                  //
// Added by  - Felipe Ramos                                                   //
// Added at  - 05/2016                                                        //
//                                                                            //
// Returns a string containing a string representation of all the array       //
// elements in the same order, with the separator string between each element.//
////////////////////////////////////////////////////////////////////////////////

function join(const separator: string; const pieces: array of String): string;
var
  I: Integer;
begin
  Result := '';
  for I := 0 to High(Pieces) do
    if Pieces[i] <> '' then
      Result := Result + separator + Pieces[I];
  Delete(Result, 1, Length(separator));
end;

{Função para criptografar e descriptografar uma string}
function Crypt(Opcao : String; Dados : String): String;
var
  I : Integer;
  Key : Word;
  Res : String;
const
  C1    = 33598;
  C2    = 24219;
  Chave = 16854;
begin
  Key := Chave;
  for I := 1 to length(Dados) do
    begin
      Res := Res + Char(Byte(Dados[I]) xor (Key shr 8));
      if Opcao = 'CRYPT' then
        Key := (Byte(Res[I]) + Chave) * C1 + C2;
      if Opcao = 'DECRYPT' then
        Key := (Byte(Dados[I]) + Chave) * C1 + C2;
    end;
  Result := Res;
end;

function NumAleatorio(Qtd: Integer):string;
var
  I, A, P : Integer;
  Num: array of Integer;
begin
  Result := '';
  
  SetLength(Num,Qtd);// Recebe a quantidade de suportes

  Randomize;

  for I := 0 to Qtd - 1 do
    Num[I] := I+1;
  for I := Qtd - 1 downto 0 do
  begin
    P := Random(I+1);
    A := Num[I];
    Num[I] := Num[P];
    Num[P] := A;
  end;

  for I := 0 to Qtd - 1 do
    Result := Result + IntToStr(Num[I]);
end;
{
//Para Capturar o usuário Logado no Windows
function GetNetUserName: string;
var
  NetUserNameLength: DWord;
begin
  NetUserNameLength:=50;
  SetLength(Result, NetUserNameLength);
  GetUserName(pChar(Result),NetUserNameLength);
  SetLength(Result, StrLen(pChar(Result)));
end;
 }
end.


{

EXEMPLOS


if( ServiceStart(
  '\ComputerName',
  'alerter' ) )then
begin
  // "alerter" service on \ComputerName
  // was started
  // take appropriate action here
end;

// stop "alerter" service
// running on the local
// computer
if( ServiceStop(
  '',
  'alerter' ) )then
begin
end;


----------------

if( ServiceRunning(
  '\ComputerName',
  'alerter' ) )then
begin
  // "alerter" service on \ComputerName
  // is running
  // take appropriate action here
end;

if( ServiceRunning(
  '',
  'alerter' ) )then
begin
  // "alerter" service on the
  // local computer is running
end;

if( ServiceStopped(
  '',
  'alerter' ) )then
begin
  // "alerter" service on the
  // local computer is in the
  // "stopped" state (not running)
end;


}