Funcao - funcoes do pascal

Top Previous Next

unit Unit2;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls;

type Tnumeros = array[1..10] of string[15];

Tmoeda = array[1..3,1..2] of string[10];

var

cTexto,cValor1,cPosicao1,cPosicao2,cPosicao3,cPosicao4 : string;

cTipoMoeda: Byte;

const

aUnidade : Tnumeros = ('UM ','DOIS ',' TRES ',' QUATRO ',' CINCO ',' SEIS ',

' SETE ',' OITO ',' NOVE ','');

aDezena : Tnumeros = ('DEZ ','VINTE ','TRINTA ','QUARENTA ','CINQUENTA ',

'SESSENTA ','SETENTA ','OITOTENTA ','NOVENTA ','');

aDezena2 : Tnumeros = ('DEZ ','ONZE ',' DOZE ','TREZE ','QUATORZE ',

'QUINZE ','DEZESSEIS ','DEZESSETE ','DEZOITO ','DEZENOVE ');

aCentena : Tnumeros = ('CENTO ','DUZENTOS ','TREZENTOS ','QUATROCENTOS ',

'QUINHENTOS ','SEISCENTOS ',

'SETECENTOS ','OITOCENTOS ','NOVECENTOS ','');

aMilhar : Tnumeros = ('MIL ','MILHAO ','MILHOES ','','','','','','','');

aMoeda : Tmoeda = (('CRUZEIRO ','CRUZEIROS '),('DOLAR ','DOLARES '),('REAL ','REAIS '));

aCentavo : Tnumeros = ('CENTAVO','CENTAVOS','','','','','','','','');

Function Left(inString : String; numChars : Byte) : String;

Function Right(inString : String; numChars : Byte) : String;

Function Len(inString : String) : Byte;

Function LTrim(inString : String) : String;

Function RTrim(inString : String) : String;

Function Trim(inString : String) : String;

Function Empty(inString : String) : Boolean;

Function SubStr(inString : String; numChars, strSize : Byte) : String;

Function PutStr(inString,putString: String; where: Byte) : String;

Function Stuff(putString, inString: String; where: Integer) : String;

Function Lower(inString : String) : String;

Function Upper(inString : String) : String;

Function Instr(Temp_Item: String; From, Size: Byte): String;

Function NoTrailZeros(tempStr : String) : String;

Function MkStr(I,W:Integer) : String;

Function Spaces(i:Byte):String;

Function LeadZeros(inString :String) : String;

Function Str2Bin(inString :String) : Real;

Function IfStr( Text, Pattern : String) : Integer;

Function DayOfWeek( Day : Integer ): String;

Function Fix(x : Real): Real;

Function Int(x : Real): Real;

Function OCT( Value : Longint ): String;

Function Hex( Value : Longint ): String;

Function ASC( inString : String ): Byte;

Function RAD( Degrees : Real ): Real;

Function DEG( Radians : Real ): Real;

Function LOG( x : Real ): Real;

Function SGN( x : Integer ): Integer;

Procedure DefSeg( SegValue : Integer );

Function Peek( Offset : Word ): Byte;

Function PeekW( Offset : Word ): Word;

Function PeekL( Offset : Word ): Longint;

Procedure Poke( Offset: Word; Value : Byte );

Function TAN( x : Real ): Real; { input must be in radians }

Function Input( prompt : String): String;

Function InputS( prompt : String): String;

Function InputI( prompt : String): Integer;

Function InputR( prompt : String): Real;

function vercgc(snrcgc:string):Boolean;

function vercpf(snrcpf:string):Boolean;

function Alltrim(Text : string) : string;

function BuscaDireita(Busca,Text : string) : integer;

function BuscaTroca(Text,Busca,Troca : string) : string;

function Repete(Caractere : char; nCaracteres : integer) : string;

function StrZero(Num : Real ; Zeros,Deci: integer): string;

{.pa}

const

WeekDays : Array[1..7] of String =

('Sunday','Monday','Tuesday','Wednesday',

'Thursday','Friday','Saturday');

Months : Array[1..12] of String =

('January','February','March','April','May',

'June','July','August','September','October',

'November','December');

CR = Chr(13);

LF = Chr(10);

FF = Chr(12);

ESC = Chr(27);

BS = Chr(08);

Space = ' ';

Yes = True;

No = False;

Var

Segment : Word; { Preset to zero }

GMT : Boolean;

Suppress : Boolean;

Implementation

{

{+---------------------------------------------------------------------+}

{: Function FIX - Truncates x to an integer :}

{+---------------------------------------------------------------------+}

{: format : v = FIX(x) :}

{: FIX strips all digits to the right of the :}

{: decimal point and returns the value of the :}

{: digits to the left of the decimal point. :}

{: :}

{: The difference between FIX and INT is that FIX does not return the :}

{: next lower number when x is negative. :}

{+---------------------------------------------------------------------+}

FUNCTION Fix(x : Real): Real;

Begin

Fix := x - Frac(x);

End;

{+---------------------------------------------------------------------+}

{: Function INT - Truncates x to an integer :}

{+---------------------------------------------------------------------+}

{: format : v = INT(x) :}

{: INT strips all digits to the right of the :}

{: decimal point and returns the value of the :}

{: digits to the left of the decimal point. :}

{: :}

{: The difference between FIX and INT is that FIX does not return the :}

{: next lower number when x is negative. :}

{+---------------------------------------------------------------------+}

FUNCTION Int(x : Real): Real;

Begin

If x < 0 Then

If Frac(x) >= 0.5 Then

Int := (x+1) - Frac(x)

Else

Int := Fix(x)

Else

Int := Fix(x)

End;

{+-------------------------------------------------------+}

{: Function : DayOfWeek ( Get Day of the Week ) :}

{+-------------------------------------------------------+}

{: Syntax : DayOfWeek ( <expN1> ) :}

{: :}

{: Action : Uses Day input value to obtain Weekday :}

{: ASCII string from constant array. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function DayOfWeek( Day : Integer ): String;

Begin

DayOfWeek := WeekDays[Day+1];

End;

{+-------------------------------------------------------+}

{: Function : LEFT :}

{+-------------------------------------------------------+}

{: Syntax : LEFT ( <expC> , <expN> ) :}

{: :}

{: where : <expC> = character string :}

{: <expN> = number of characters to return :}

{: Integer value :}

{: :}

{: Action : Returns a specified number of characters :}

{: in the character string <expC>, starting :}

{: from the leftmost character. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function Left;

Begin

Left := Copy(inString,1,numChars)

End;

{+-------------------------------------------------------+}

{: Function : RIGHT :}

{+-------------------------------------------------------+}

{: Syntax : RIGHT ( <expC> , <expN> ) :}

{: :}

{: where : <expC> = character string :}

{: <expN> = number of characters to return :}

{: Integer value :}

{: :}

{: Action : Returns the rightmost <expN> portion of a :}

{: character string <expC> :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function Right;

Var

index : Byte;

Begin

If numChars >= Length(inString) Then

Right := inString

Else

Begin

index := Length(inString) - numChars+1;

Right := Copy(inString,index,numChars)

End

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : LEN :}

{+-------------------------------------------------------+}

{: Syntax : LEN ( <expC> ) :}

{: :}

{: where : <expC> = character string :}

{: :}

{: Action : Returns the dynamic length of character :}

{: string <expC>. Nonprinting characters :}

{: and blanks are counted. :}

{: :}

{: Result Type : Integer :}

{+-------------------------------------------------------+}

Function Len;

Begin

Len := Ord(inString[0]);

End;

{+-------------------------------------------------------+}

{: Function : LTRIM :}

{+-------------------------------------------------------+}

{: Syntax : LTRIM ( <expC1> ) :}

{: :}

{: where : <expC1> = character string :}

{: :}

{: Action : Returns <expC1> with all leading SPACES :}

{: (blanks) removed. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function LTrim;

Var

p : Integer;

Begin

p := 1;

While (inString[p] = '') and (p <= Length(inString)) Do

inc( p );

If p > 1 Then

Begin

Move( inString[p], inString[1], Succ(Length(inString)) - p);

dec(inString[0], pred(p));

End;

LTrim := inString;

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : RTRIM :}

{+-------------------------------------------------------+}

{: Syntax : RTRIM ( <expC1> ) :}

{: :}

{: where : <expC1> = character string :}

{: :}

{: Action : Returns <expC1> with all trailing SPACES :}

{: (blanks) removed. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function RTrim;

Begin

While inString[Length(inString)] = ' ' Do

dec( inString[0] );

RTrim := inString;

End;

{+-------------------------------------------------------+}

{: Function : Trim :}

{+-------------------------------------------------------+}

{: Syntax : Trim ( <expC1> ) :}

{: :}

{: where : <expC1> = character string :}

{: :}

{: Action : Returns <expC1> with all trailing SPACES :}

{: (blanks) removed. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function Trim( inString : String ): String;

Begin

Trim := RTrim( inString );

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : EMPTY :}

{+-------------------------------------------------------+}

{: Syntax : EMPTY ( <expC1> ) :}

{: :}

{: where : <expC1> = character string :}

{: :}

{: Action : Returns TRUE if <expC1> contains only :}

{: SPACES (blanks). :}

{: :}

{: Result Type : Boolean :}

{+-------------------------------------------------------+}

Function Empty;

Var

index : Byte;

Begin

index := 1;

Empty := True;

While (index <= Length(inString))and (index <> 0) do

Begin

If inString[index] = ' ' Then

inc(index)

Else

Begin

Empty := False;

index := 0

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : SUBSTR :}

{+-------------------------------------------------------+}

{: Syntax : SUBSTR ( <expC>, <expN1>[, <expN2>] ) :}

{: :}

{: where : <expC> = character string :}

{: <expN1>,<expN2> = numeric value (Byte) :}

{: :}

{: Action : Returns a string of length <expN2> from :}

{: <expC>, beginning with the <expN1>th :}

{: character. The <expN1> and <expN2> must :}

{: be in the range 1 to 255. If <expN2> is :}

{: omitted or if there is fewer than <expN2> :}

{: characters to the right of the <expN1>th :}

{: character, all rightmost characters :}

{: beginning with the <expN1>th character are:}

{: returned. If <expN1> is greater than the :}

{: number of characters in <expC>, SUBSTR :}

{: returns a null string. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function SubStr;

Begin

SubStr := Copy(inString, numChars, StrSize );

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : PUTSTR :}

{+-------------------------------------------------------+}

{: Syntax : PUTSTR ( <expC1>, <expC2>, <expN1> ) :}

{: :}

{: where : <expC1>,<expC2> = character string :}

{: <expN1> = numeric value (Byte) :}

{: :}

{: Action : Replaces a portion of one string <expC1> :}

{: with another string <expC2>. The :}

{: characters in <expC1> beginning at :}

{: position <expN1> are replaced by the :}

{: characters in <expC2>. The number of :}

{: characters replaced is equal to the length:}

{: of string <expC2>. However, the :}

{: replacement of characters never goes :}

{: beyond the original length of <expC1>. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function PutStr;

Var

index, j : Byte;

Begin

index := Ord(putString[0]); { get size of input string}

For j := where to where + (index-1) do

inString[j] := putString[(j+1)-where];

PutStr := inString;

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : Stuff :}

{+-------------------------------------------------------+}

{: Syntax : Stuff ( <expC1>, <expC2>, <expN1> ) :}

{: :}

{: where : <expC1>,<expC2> = character string :}

{: <expN1> = numeric value (Byte) :}

{: :}

{: Action : Replaces a portion of one string <expC2> :}

{: with another string <expC1>. The :}

{: characters in <expC2> beginning at :}

{: position <expN1> are replaced by the :}

{: characters in <expC1>. The number of :}

{: characters replaced is equal to the length:}

{: of string <expC1>. However, the :}

{: replacement of characters never goes :}

{: beyond the original length of <expC2>. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function Stuff;

Begin

Insert(putString, inString, where);

Stuff := inString;

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : LOWER :}

{+-------------------------------------------------------+}

{: Syntax : LOWER ( <expC1> ) :}

{: :}

{: where : <expC1> = character string :}

{: :}

{: Action : Returns the specified character :}

{: expression <expC1> in lowercase. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function Lower;

Var

index : Byte; tempString : String;

Const

Upset = ['A'..'Z'];

LowSet = ['a'..'z'];

Begin

For index := 1 to Length(inString) do

Begin

If inString[index] in UpSet Then

tempString[index] := Chr(Ord(inString[index])+32)

Else

TempString[index] := inString[index];

End;

Lower := tempString;

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : UPPER :}

{+-------------------------------------------------------+}

{: Syntax : UPPER ( <expC1> ) :}

{: :}

{: where : <expC1> = character string :}

{: :}

{: Action : Returns the specified character :}

{: expression <expC1> in uppercase. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function Upper;

Var

index : Byte;

tempString : String;

Begin

For index := 1 to Length(inString) do

tempString[index] := UpCase(inString[index]);

tempString[0] := inString[0];

Upper := tempString;

End;

{+-----------------------------------------------------------+}

{: Function: I n s t r ( Instring ) :}

{+-----------------------------------------------------------+}

{: This function extracts a string beginning at pointer :}

{: From in string Temp_Item for Size chars and returns Value.:}

{+-----------------------------------------------------------+}

Function Instr;

Begin

Instr := Copy(Temp_Item, From, Size);

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : NoTrailZeros :}

{+-------------------------------------------------------+}

{: Syntax : NoTrailZeros ( <expC1> ) :}

{: :}

{: where : <expC1> = character string :}

{: :}

{: Action : Removes trailing Zeros from the specified :}

{: expression <expC1>. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function NoTrailZeros;

Var

index : Integer;

tempString : String;

Begin

While tempStr[Length(tempStr)] = '0' Do

tempStr[0] := Chr(Length(tempStr)-1);

NoTrailZeros := tempStr;

End;

{+-------------------------------------------------------+}

{: Function : MkStr ( Make String ) :}

{+-------------------------------------------------------+}

{: Syntax : MkStr ( <expN1>, <expN2> ) :}

{: :}

{: where : <expN1>,<expN2> = numeric values (integer):}

{: :}

{: Action : Makes a string of length <expN2> from :}

{: Integer expression <expN1>. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function MkStr;

Var

temp1 : String;

Begin

Str(I:W,temp1);

MKStr := temp1;

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : Spaces :}

{+-------------------------------------------------------+}

{: Syntax : Spaces ( <expN1> ) :}

{: :}

{: where : <expN1> = numeric value ( Byte ) :}

{: :}

{: Action : Makes a string of length <expN1> which :}

{: contains Space characters. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function Spaces;

Var

zip : String[255];

Begin

FillChar(zip,i+1,' ');

zip[0] := Chr(i);

Spaces := Zip;

End;

{+-------------------------------------------------------+}

{: Function : LeadZeros :}

{+-------------------------------------------------------+}

{: Syntax : LeadZeros ( <expC1> ) :}

{: :}

{: where : <expC1> = character string input :}

{: :}

{: Action : replace the leading spaces in a string :}

{: with ASCII Zeros. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function LeadZeros;

Var i : Integer;

Begin

i := 1;

While inString[i] = ' ' do

Begin

inString[i] := Chr(48);

inc(i);

End;

LeadZeros := inString;

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : Str2Bin ( String to Binary ) :}

{+-------------------------------------------------------+}

{: Syntax : Str2Bin ( <expC1> ) :}

{: :}

{: where : <expC1> = Character string :}

{: :}

{: Action : converts a string containing an ASCII :}

{: numeric value to an number. :}

{: :}

{: Result Type : Real :}

{+-------------------------------------------------------+}

Function Str2Bin;

Var

i : Real;

k : Integer;

Begin

Val(inString,i,k);

Str2Bin := i;

End;

{+-------------------------------------------------------+}

{: Function : IfStr ( If StringB in StringA ) :}

{+-------------------------------------------------------+}

{: Syntax : IfStr (<expC1>,<expC2>) :}

{: :}

{: where : <expC1> = Character string :}

{: <expC2> = Character string :}

{: :}

{: Action : Determines if <expC2> exists within :}

{: <expC1>. :}

{: :}

{: Result Type : Integer :}

{: Result Values : 0 = char not in stringA :}

{: 1-n = position of <expC2> within :}

{: <expC1> :}

{: :}

{+-------------------------------------------------------+}

Function IfStr( Text, Pattern : String) : Integer;

Begin

IfStr := Pos( Pattern, Text );

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : Oct Binary to Octal :}

{+-------------------------------------------------------+}

{: Syntax : Oct ( <expN1> ) :}

{: :}

{: where : <expN1> = Binary number of type Longint :}

{: :}

{: Action : Converts a binary number of type Longint :}

{: to a String containing 11 octal Digits. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function OCT( Value : Longint ) : String;

Var

i : Integer;

j : Word;

t1 : String;

f : Boolean;

Begin

If Value < 0 Then

Begin

Value := Value - $80000000;

F := True;

End

Else

F := False;

For i := 11 DownTo 2 Do

Begin

j := Value Mod 8;

Value := Value Div 8;

t1[i] := Chr( j+48 );

End;

If f Then

Value := Value + $2;

j := Value Mod 8;

t1[1] := Chr( j+48 );

t1[0] := Chr(11);

i := 1;

If Suppress Then

While t1[i] = '0' Do

Begin

t1[i] := ' ';

inc( i );

End;

OCT := LTrim( t1 );

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : Hex Binary to Hex :}

{+-------------------------------------------------------+}

{: Syntax : Hex ( <expN1> ) :}

{: :}

{: where : <expN1> = Binary number of type Longint :}

{: :}

{: Action : Converts a binary number of type Longint :}

{: to a String containing 8 Hex Digits. :}

{: :}

{: Result Type : String :}

{+-------------------------------------------------------+}

Function Hex( Value : Longint ):String;

Var

t1 : String;

i : Integer;

j : Word;

f : Boolean;

Function HexChr( HexNibble : Byte ): Char;

Begin

If HexNibble < 10 then

HexChr := Chr(HexNibble+48)

Else

HexChr := Chr(HexNibble+55);

End;

begin

If Value < 0 Then

Begin

Value := Value - $80000000;

F := True;

End

Else

F := False;

For i := 8 DownTo 2 Do

Begin

j := Value Mod 16;

Value := Value Div 16;

t1[i] := HexChr( j );

End;

If f Then

Value := Value + $8;

j := Value Mod 16;

t1[1] := HexChr( j );

t1[0] := Chr(8);

i := 1;

If Suppress Then

While t1[i] = '0' Do

Begin

t1[i] := ' ';

inc( i );

End;

HEX := LTrim( t1 );

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : ASC Get ASCII code from String :}

{+-------------------------------------------------------+}

{: Syntax : ASC ( <expS1> ) :}

{: :}

{: where : <expS1> = ASCII String :}

{: :}

{: Action : Returns the numeric value of the first :}

{: character of the String expression. :}

{: :}

{: Result Type : Byte :}

{+-------------------------------------------------------+}

Function ASC( inString : String ) : Byte;

Begin

If Length( inString ) > 0 Then

ASC := Ord( inString[1] )

Else

ASC := 0;

End;

{+-------------------------------------------------------+}

{: Function : RAD Convert from Degrees to Radians :}

{+-------------------------------------------------------+}

{: Syntax : RAD ( <expR1> ) :}

{: :}

{: where : <expR1> = Degrees of type Real :}

{: :}

{: Action : Converts a number (REAL) containing :}

{: Degrees to one expressed as Radians. :}

{: :}

{: Result Type : Real :}

{+-------------------------------------------------------+}

Function RAD( Degrees : Real ) : Real;

Begin

RAD := Degrees * ( Pi / 180 );

End;

{+-------------------------------------------------------+}

{: Function : DEG Convert from Radians to Degrees :}

{+-------------------------------------------------------+}

{: Syntax : DEG ( <expR1> ) :}

{: :}

{: where : <expR1> = Radians of type Real :}

{: :}

{: Action : Converts a number (REAL) containing :}

{: Radians to one expressed as Degrees. :}

{: :}

{: Result Type : Real :}

{+-------------------------------------------------------+}

Function DEG( Radians : Real ) : Real;

Begin

DEG := Radians * ( 180 / Pi );

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : LOG Returns the Log :}

{+-------------------------------------------------------+}

{: Syntax : DEG ( <expR1> ) :}

{: :}

{: where : <expR1> = number to obtain Log of :}

{: :}

{: Action : Returns the natural Logarithm of the :}

{: argument. :}

{: :}

{: Result Type : Real :}

{+-------------------------------------------------------+}

Function LOG( x : Real ) : Real;

Begin

LOG := LN( x );

End;

{+-------------------------------------------------------+}

{: Function : SGN Returns the Sign of argument :}

{+-------------------------------------------------------+}

{: Syntax : DEG ( <expI1> ) :}

{: :}

{: where : <expI1> = number to obtain Sign of :}

{: :}

{: Action : If <expI1> is positive SGN returns 1 :}

{: If <expI1> is zero SGN returns 0 :}

{: If <expI1> is negative SGN returns -1 :}

{: :}

{: Result Type : Integer :}

{+-------------------------------------------------------+}

Function SGN( x : Integer ): Integer;

Begin

If x = 0 Then

SGN := 0

Else

If x < 0 Then

SGN := -1

Else

SGN := 1;

End;

{.pa}

{+-------------------------------------------------------+}

{:Procedure : DEFSEG (assign current segment register) :}

{+-------------------------------------------------------+}

{: Syntax : DEFSEG ( <expI1> ) :}

{: :}

{: where : <expI1> = Integer value of Segment Reg :}

{: Segment = Global Variable :}

{: Action : Assigns <expI1> to the Segment Register :}

{+-------------------------------------------------------+}

Procedure DefSeg( SegValue : Integer);

Begin

Segment := SegValue;

End;

{+-------------------------------------------------------+}

{: Function : Peek Get contents of memory address :}

{+-------------------------------------------------------+}

{: Syntax : Peek ( <expW1> ) :}

{: :}

{: where : <expW1> = Offset of memory address of :}

{: type Word :}

{: :}

{: Action : Gets contents of memory address as :}

{: Segment:Offset. :}

{: :}

{: Result Type : Byte :}

{+-------------------------------------------------------+}

Function Peek( Offset : Word ): Byte;

Begin

Peek := Mem[Segment:Offset];

End;

{+-------------------------------------------------------+}

{: Function : PeekW Get contents of memory address :}

{+-------------------------------------------------------+}

{: Syntax : PeekW ( <expW1> ) :}

{: :}

{: where : <expW1> = Offset of memory address of :}

{: type Word :}

{: :}

{: Action : Gets contents of memory address as :}

{: Segment:Offset. :}

{: :}

{: Result Type : Word :}

{+-------------------------------------------------------+}

Function PeekW( Offset : Word ): Word;

Begin

PeekW := MemW[Segment:Offset];

End;

{.pa}

{+-------------------------------------------------------+}

{: Function : PeekL Get contents of memory address :}

{+-------------------------------------------------------+}

{: Syntax : PeekL ( <expW1> ) :}

{: :}

{: where : <expW1> = Offset of memory address of :}

{: type Word :}

{: :}

{: Action : Gets contents of memory address as :}

{: Segment:Offset. :}

{: :}

{: Result Type : Longint :}

{+-------------------------------------------------------+}

Function PeekL( Offset : Word ): Longint;

Begin

PeekL := MemL[Segment:Offset];

End;

{+-------------------------------------------------------+}

{: Procedure : Poke Put contents of memory address :}

{+-------------------------------------------------------+}

{: Syntax : Poke ( <expW1>, <expB1> ) :}

{: :}

{: where : <expW1> = Offset of memory address of :}

{: type Word :}

{: :}

{: <expB1> = Byte of data to poke :}

{: :}

{: Action : Pokes contents of memory address. :}

{: :}

{+-------------------------------------------------------+}

Procedure Poke( Offset: Word; Value : Byte );

Begin

Mem[Segment:Offset] := Value;

End;

{+-------------------------------------------------------+}

{: Function : TAN Computes Tangent of Angle :}

{+-------------------------------------------------------+}

{: Syntax : TAN ( <expR1> ) :}

{: :}

{: where : <expR1> = number to obtain TAN of :}

{: :}

{: Action : Returns the Tangent of angle in radians :}

{: :}

{: Result Type : Real :}

{+-------------------------------------------------------+}

Function TAN( x : Real ) : Real; { input must be in radians }

Begin

TAN := Sin(x)*(1/Cos(x));

End;

{.pa}

Function Input( prompt : String): String;

Var

t1 : String;

Begin

Write(prompt);

ReadLn(t1);

Input := t1;

End;

Function InputS( prompt : String): String;

Var

t1 : String;

Begin

Write(prompt);

ReadLn(t1);

InputS := t1;

End;

Function InputI( prompt : String): Integer;

Var

t1 : String;

Begin

Write(Prompt);

ReadLn(t1);

InputI := Trunc( Str2Bin( t1 ) );

End;

Function InputR( prompt : String): Real;

Var

t1 : String;

Begin

Write(Prompt);

ReadLn(t1);

InputR := Str2Bin( t1 );

End;

Procedure Print(Tex : String);

Begin

WriteLn(Tex);

End;

function vercpf ;

VAR

WCPFCALC : STRING;

WSOMACPF : INTEGER;

WSX1 : SHORTINT;

WCPFDIGT : INTEGER;

begin

if (snrcpf <> ' . . - ') and

(snrcpf <> '') then

{if snrcpf <> ' . . - ' then}

BEGIN

try

snrCpf := Copy(snrcpf,1,3)+Copy(snrcpf,5,3)+

Copy(snrcpf,9,3)+Copy(snrcpf,13,2);

wcpfcalc := copy(snrCpf, 1, 9);

wsomacpf := 0;

for wsx1:= 1 to 9 DO

wsomacpf := wsomacpf + strtoint(copy(wcpfcalc, wsx1, 1)) * (11 - wsx1);

wcpfdigt:= 11 - wsomacpf mod 11;

if wcpfdigt in [10,11] then

BEGIN

wcpfcalc:= wcpfcalc + '0';

END

else

BEGIN

wcpfcalc := wcpfcalc + inttoStr(wcpfdigt);

END;

wsomacpf:= 0;

for wsx1:= 1 to 10 DO

wsomacpf := wsomacpf + strtoint(copy(wcpfcalc, wsx1, 1)) * (12 - wsx1);

wcpfdigt:= 11 - wsomacpf mod 11;

if wcpfdigt in [10,11] then

BEGIN

wcpfcalc:= wcpfcalc + '0';

END

else

BEGIN

wcpfcalc := wcpfcalc + inttoStr(wcpfdigt);

END;

if snrcpf <> wcpfcalc then

begin

application.messagebox('C.P.F. Inválido !','Atenção!',mb_iconstop+mb_ok);

vercpf := false;

end

else

vercpf := true;

except on econverterror do

begin

application.messagebox('Valor informado não é válido !','Atenção!',mb_iconstop+mb_ok);

vercpf := false;

end

END

end;

function vercgc ;

VAR

WCGCCALC : STRING;

WSOMACGC : INTEGER;

WSX1 : SHORTINT;

WCGCDIGT : INTEGER;

begin

if (snrCGC <> ' . . / -') and

(snrCGC <> '') then

BEGIN

try

snrcgc := Copy(snrcgc,1,2)+Copy(snrcgc,4,3)+

Copy(snrcgc,8,3)+Copy(snrcgc,12,4)+Copy(snrcgc,17,2);

wCgcCalc := Copy(snrcgc,1,12);

WSOMACGC := 0;

{-----------------------------}

for wsx1:= 1 to 4 do

wsomacgc:= wsomacgc + strtoint(copy(wcgccalc, wsx1, 1)) * (6 - wsx1);

for wsx1:= 1 to 8 do

wsomacgc:= wsomacgc + strtoint(copy(wcgccalc, wsx1 + 4, 1)) * (10 - wsx1);

wcgcdigt:= 11 - wsomacgc mod 11;

if wcgcdigt in [10,11] then

BEGIN

wcgccalc:= wcgccalc + '0';

END

else

BEGIN

wcgccalc := wcgccalc + inttoStr(wcgcdigt);

END;

{---------------------------------}

wsomacgc:= 0;

for wsx1:= 1 to 5 do

wsomacgc:= wsomacgc + strtoint(copy(wcgccalc, wsx1, 1)) * (7 - wsx1);

for wsx1:= 1 to 8 do

wsomacgc:= wsomacgc + strtoint(copy(wcgccalc, wsx1 + 5, 1)) * (10 - wsx1);

wcgcdigt:= 11 - wsomacgc mod 11;

if wcgcdigt in [10,11] then

BEGIN

wcgccalc:= wcgccalc + '0';

END

else

BEGIN

wcgccalc := wcgccalc + inttoStr(wcgcdigt);

END;

if snrcgc <> wcgccalc then

begin

application.messagebox('C.G.C. Inválido !','Atenção!',mb_iconstop+mb_ok);

vercgc := false ;

end

else

vercgc := true ;

except on econverterror do

begin

application.messagebox('Valor informado não é válido !','Atenção!',mb_iconstop+mb_ok);

vercgc := false;

end

END

end;

function Alltrim(Text : string) : string;

begin

while Pos(' ',Text) > 0 do

Delete(Text,Pos(' ',Text),1);

Result := Text;

end;

function BuscaDireita(Busca,Text : string) : integer;

var n,retorno : integer;

begin

retorno := 0;

for n := length(Text) downto 1 do

begin

if Copy(Text,n,1) = Busca then

begin

retorno := n;

break;

end;

Result := retorno;

end;

function BuscaTroca(Text,Busca,Troca : string) : string;

var n : integer;

begin

for n := 1 to length(Text) do

begin

if Copy(Text,n,1) = Busca then

begin

Delete(Text,n,1);

Insert(Troca,Text,n);

end;

Result := Text;

end;

function Repete(Caractere : char; nCaracteres : integer) : string;

var n : integer; CadeiaCar : string;

begin

CadeiaCar := '';

for n := 1 to nCaracteres do

CadeiaCar := CadeiaCar + Caractere;

Result := CadeiaCar;

end;

function StrZero(Num : Real ; Zeros,Deci: integer): string;

var tam,z : integer;

res,zer : string;

begin

Str(Num:Zeros:Deci, res);

res := Alltrim(res);

tam := length(res);

zer := '';

for z := 1 to (Zeros-tam) do

zer := zer + '0';

Result := zer+res;

end;

end.