Fórum Numero por extenso... #186087

Tenho um componente que faz isso, me mande um e-mail e envio em anexo.

Tem uma funcao de Extenso aqui q faz o q vc quer...
Mas to mandando outras tb.

Um Abraço
Werlon Goulart


unit Ugeral;
interface
Uses
SysUtils, Wintypes, Winprocs, Messages,
Classes, Graphics, Controls,Forms, DB, Menus;

Function LetraDrive : String;
function AnoBis:Boolean;
function Extenso( pValor:Extended ):String;
function ExtCem( pCem:String ):String;
function StripDouble( pString:String ):String;
function StrZero(xValue:Extended; xWidth:Integer; xDecimals:Integer):String;
function Replicate( pString:String; xWidth:Integer ):String;
function Space( iLength:Integer ):String;
function PadL( sString:String; iLength:Integer; cChar:Char ):String;
function PadR( sString:String; iLength:Integer; cChar:Char ):String;
function PadC( sString:String; iLength:Integer; cChar:Char ):String;
function _Left( sString:String; iLength:Integer ):String;
function Right( pString:String; xWidth:Integer ):String;
function Cgc( xCGC:String ):Boolean;
function Cpf( xCPF:String ):Boolean;
function Encrypt( Senha:String ): String;
function iif(Condicao:Boolean; retornaTrue, retornaFalse:Variant):Variant;
function SeparaCasas(Texto: String):String;

//Declara Funcao de Formatar Disquetes da Shell32.dll.
function SHFormatDrive(Handle: HWND; Drive, ID, Options:Word):
LongInt; stdcall; external ´shell32.dll´ name ´SHFormatDrive´

Function FormataDisquete(Drive: String; FormatarRapido: Boolean; FormatarCompleto: Boolean; CopiaSistema: Boolean): Integer;


implementation

//Formata o texto separando de 3 em 3 com o Ponto(.) .
Function SeparaCasas(Texto: String):String;
Var Ind : Integer;
Aux : String;
Sair :Boolean;
begin
Sair:=False;
Aux:=´´;
Ind:=Length(Texto);
While Sair<>True do begin
Aux:=Copy(Texto,Ind-2,3)+Aux;
Delete(Texto,Length(Texto)-2,3);
Ind:=Ind-3;
if Ind<=0 then
Sair:=True
else
Aux:=´.´+Aux;
end;
Result:=Aux;
end;

Function LetraDrive : String;
begin
Result:=Copy(ExtractFilePath(Application.ExeName),1,2);
end;

Function FormataDisquete(Drive: String; FormatarRapido: Boolean; FormatarCompleto: Boolean; CopiaSistema: Boolean): Integer;
Var Handle: HWND;
MSG: STRING;
Drv: Integer; //Indica o Drive;
TipoFormatacao: Integer; //Word;
Const
Drives = ´ABCDEFGHIJKLMNOPQRSTUVWZYZ´;
SHFMT_ID_DEFAULT = $FFFF;
begin
Handle:=Application.Handle;
Drv:=Pos(UpperCase(Drive),Drives)-1;
//Seta o Tipo de Formatacao.
if FormatarRapido then
TipoFormatacao:=0
else
if FormatarCompleto then
TipoFormatacao:=1
else
if CopiaSistema then
TipoFormatacao:=2;
Result:=SHFormatDrive(Handle, Drv, SHFMT_ID_DEFAULT, TipoFormatacao);
end;


//***************************************//
//** Função para calcular ANO BISEXTO **//
//**************************************//

function AnoBis: Boolean;
Var
ANO : INTEGER;
begin
{computa anos bissextos, considerando ´exceções´}
ANO := STRTOINT(COPY(Fmmenu.DtEmissao,7,4));

//*************************************************************///
//** Fmmenu.FmNome Variavel **///
//** declarada na unit menu para pegar nome do formulario **///
//** FmMeu.DtEmissao Varial **///
//** declarada na unit menu para pegar data emissa nota **///
//*************************************************************///

if (Ano mod 4 <> 0) then
AnoBis := False
else
if (Ano mod 100 <> 0) then
AnoBis := True
else
if (Ano mod 400 <> 0) then
AnoBis := False
else
AnoBis := True;
end;

function Extenso( pValor:Extended ):String;
Const
aCifra : Array[1..6,1..2] of String = ((´TRILHÃO,´,´TRILHOES,´),
(´BILHAO,´ ,´BILHÕES,´ ),
(´MILHAO,´ ,´MILHÕES,´ ),
(´MIL,´ ,´MIL,´ ),
(´ ´ ,´ ´ ),
(´CENTAVO´ ,´CENTAVOS´));
Var
tStr,tExtenso,tSubs:String;
tX,tCentavos:Integer;
begin
tSubs := ´ ´;
tExtenso := ´ ´;
tStr := StrZero(pValor,18,2);
tCentavos := StrToInt( Copy(tStr,17,2) );
if pValor > 0 then
begin
if tCentavos > 0 then
tExtenso := ExtCem( StrZero( tCentavos,3,0 )) + aCifra[6,Trunc(iif(tCentavos = 1,1,2))];
if trunc( pValor ) > 0 then
tExtenso := iif(trunc( pValor ) = 1,´REAL´,´ REAIS´)+iif(tCentavos > 0, ´ E ´,´´)+tExtenso;
for tX := 5 Downto 1 do
begin
tSubs := Copy(tStr,(tX*3)-2,3);
if StrToInt( tSubs ) > 0 then
tExtenso := ExtCem( tSubs ) + aCifra[tX,Trunc(iif(StrToInt( tSubs )=1,1,2))]+´ ´+tExtenso;
end;
end;
Result := StripDouble( tExtenso );
end;

function ExtCem( pCem:String ):String;
Const
aCent:Array[1..9] of string = (´CENTO´,´DUZENTOS´,´TREZENTOS´,´QUATROCENTOS´,
´QUINHENTOS´,´SEISCENTOS´,´SETECENTOS´,´OITOCENTOS´,´NOVECENTOS´);
aVint:Array[1..9] of string = (´ONZE´,´DOZE´,´TREZE´,´QUATORZE´,
´QUINZE´,´DEZESSEIS´,´DEZESSETE´,´DEZOITO´,´DEZENOVE´);
aDez :Array[1..9] of string = (´DEZ´,´VINTE´,´TRINTA´,´QUARENTA´,
´CINQUENTA´,´SESSENTA´,´SETENTA´,´OITENTA´,´NOVENTA´);
aUnit:Array[1..9] of string = (´UM´,´DOIS´,´TREIS´,´QUATRO´,
´CINCO´,´SEIS´,´SETE´,´OITO´,´NOVE´);
Var
aVal:Array[1..3] of integer;
text : String;
begin
text := ´´;
aVal[1] := StrToInt( Copy( pCem,1,1) );
aVal[2] := StrToInt( Copy( pCem,2,1) );
aVal[3] := StrToInt( Copy( pCem,3,1) );
if StrToInt(pCem) > 0 then
begin
if StrToInt(pCem) = 100 then
text := ´CEM´
else begin
if aVal[1] > 0 then
text := aCent[aVal[1]]+iif((aVal[2]+aVal[3]) > 0,´ E ´,´ ´);
if (aVal[2] = 1) and (aVal[3] > 0) then
text := text + ´ ´ + aVint[Aval[3]]
else begin
if aVal[2] > 0 then
text := text+´ ´+aDez[aVal[2]]+iif(aVal[3]>0, ´ E ´,´ ´);
text := text+iif(aVal[3]>0,´ ´+aUnit[aVal[3]],´ ´);
end;
end;
end;
text := text + ´ ´;
Result := text;
end;

function StripDouble( pString:String ):String;
begin
while pos(´ ´,pString) > 0 do Delete(pString,pos(´ ´,pString),1);
Result := pString
end;

function StrZero(xValue:Extended; xWidth:Integer; xDecimals:Integer):String;
Var
sValue:String;
begin
Str(xValue:xWidth:xDecimals,sValue);
Result := Right(Replicate( ´0´,xWidth ) + Trim(sValue), xWidth);
end;

function Replicate( pString:String; xWidth:Integer ):String;
Var
nCount : Integer;
pStr : String;
begin
pStr := ´´;
for nCount := 1 to xWidth do pStr := pStr + pString;
Result := pStr;
end;

function Space( iLength:Integer ):String;
begin
Result := Replicate( ´ ´,iLength );
end;

function PadL( sString:String; iLength:Integer; cChar:Char ):String;
begin
Result := Right( Replicate( cChar, iLength ) + sString, iLength );
end;

function PadR( sString:String; iLength:Integer; cChar:Char ):String;
begin
Result := _Left( sString + Replicate( cChar, iLength ), iLength );
end;

function PadC( sString:String; iLength:Integer; cChar:Char ):String;
begin
Result := _Left( Replicate( cChar, (iLength - Length( sString )) div 2 )
+ sString + replicate( cChar, (iLength - Length( sString )) div 2 + 2 ), iLength );
end;

function _Left( sString:String; iLength:Integer ):String;
begin
Result := Copy( sString, 1, iLength );
end;

function Right( pString:String; xWidth:Integer ):String;
begin
Result := Copy( pString, Length( pString )-xWidth+1, xWidth );
end;

function Cgc( xCGC:String ):Boolean;
Var
d1,d4,xx,nCount,fator,resto,digito1,digito2 : Integer;
Check : String;
begin
d1 := 0; d4 := 0; xx := 1;
for nCount := 1 to Length( xCGC )-2 do
begin
if Pos( Copy( xCGC, nCount, 1 ), ´/-.´ ) = 0 then begin
if xx < 5 then fator := 6 - xx else fator := 14 - xx;
d1 := d1 + StrToInt( Copy( xCGC, nCount, 1 ) ) * fator;
if xx < 6 then fator := 7 - xx else fator := 15 - xx;
d4 := d4 + StrToInt( Copy( xCGC, nCount, 1 ) ) * fator;
xx := xx+1;
end;
end;
resto := (d1 mod 11);
if resto < 2 then
digito1 := 0
else
digito1 := 11 - resto;
d4 := d4 + 2 * digito1;
resto := (d4 mod 11);
if resto < 2 then
digito2 := 0
else
digito2 := 11 - resto;
Check := IntToStr(Digito1) + IntToStr(Digito2);
if Check <> Right( xCGC, 2 ) then
Result := False
else
Result := True;
end;

function Cpf( xCPF:String ):Boolean;
Var
d1,d4,xx,nCount,resto,digito1,digito2 : Integer;
Check : String;
begin
d1 := 0; d4 := 0; xx := 1;
for nCount := 1 to Length( xCPF )-2 do
begin
if Pos( Copy( xCPF, nCount, 1 ), ´/-.´ ) = 0 then
begin
d1 := d1 + ( 11 - xx ) * StrToInt( Copy( xCPF, nCount, 1 ) );
d4 := d4 + ( 12 - xx ) * StrToInt( Copy( xCPF, nCount, 1 ) );
xx := xx+1;
end;
end;
resto := (d1 mod 11);
if resto < 2 then
digito1 := 0
else
digito1 := 11 - resto;
d4 := d4 + 2 * digito1;
resto := (d4 mod 11);
if resto < 2 then
digito2 := 0
else
digito2 := 11 - resto;
Check := IntToStr(Digito1) + IntToStr(Digito2);
if Check <> Right( xCPF, 2 ) then
Result := False
else
Result := True;
end;

function Encrypt( Senha:String ): String;
Const
Chave : String = ´Jesus´;
Var
x,y : Integer;
NovaSenha : String;
begin
for x := 1 to Length( Chave ) do begin
NovaSenha := ´´;
for y := 1 to Length( Senha ) do
NovaSenha := NovaSenha + chr( (Ord(Chave[x]) xor Ord(Senha[y])));
Senha := NovaSenha;
end;
result := Senha;
end;

function iif(Condicao:Boolean; retornaTrue, retornaFalse:Variant):Variant;
begin
if Condicao then
Result := retornaTrue
else
Result := retornaFalse;
end;

end.