Função genérica para extenso de valores passados em números

gilsonpaulo · Mensagem por **gilsonpaulo** » 23 Nov 2010 08:48

/*
 * EXTCEM()  -  Valor por extenso de string numérica com tres d¡gitos
 *              de "000" a "999"
 */

FUNCTION ExtCem( pCem )

LOCAL aVal:= { VAL( SUBSTR( pCem, 1, 1 )),;
               VAL( SUBSTR( pCem, 2, 1 )),;
               VAL( SUBSTR( pCem, 3, 1 )) }
LOCAL tTam, tExt:= ""

LOCAL aCent:= { "Cento", "Duzentos", "Trezentos", "Quatrocentos",;
                "Quinhentos", "Seiscentos", "Setecentos","Oitocentos",;
                "Novecentos" }

LOCAL aVint:= { "Onze", "Doze", "Treze", "Quatorze", "Quinze", "Dezesseis",;
                "Dezessete", "Dezoito", "Dezenove" }

LOCAL aDez:=  { "Dez", "Vinte", "Trinta", "Quarenta", "Cinquenta", "Sessenta",;
                "Setenta", "Oitenta", "Noventa" }

LOCAL aUnit:= { "Um", "Dois", "Tres", "Quatro", "Cinco", "Seis", "Sete",;
                "Oito", "Nove" }

IF ( VAL( pCem ) > 0 )
   IF ( VAL( pCem ) == 100 )
      tExt:= "Cem"
     ELSE
      IF ( aVal[1] > 0 )
         tExt:= aCent[ aVal[1] ] + IIF(( aVal[2] + aVal[3] > 0 ), " e ", " " )
      ENDIF
      IF ( aVal[2] = 1 ) .AND. ( aVal[3] > 0 )
         tExt:= tExt + " " + aVint[ aVal[3] ] + " "
        ELSE
         IF ( aVal[2] > 0 )
            tExt:= tExt + " " + aDez[ aVal[2] ] + IIF( aVal[3] > 0, " e ", " " )
         ENDIF

         tExt:= tExt + IIF( aVal[3] > 0, " " + aUnit[ aVal[3] ], "" )
      ENDIF
   ENDIF
ENDIF

RETURN( tExt:= tExt + " " )

/*
 * EXTENSO()
 */

FUNCTION Extenso( pValor )

LOCAL tStr:= STRZERO( ABS( pValor), 18, 2 )
LOCAL aCifra:= {  { "Trilhao", "Trilhoes" },;
                  { "Bilhao",  "Bilhoes"  },;
                  { "Milhao",  "Milhoes"  },;
                  { "Mil",     "Mil"      },;
                  { "",        ""         },;
                  { "Centavo", "Centavos" }  }

LOCAL tX, tEx1
LOCAL tExtenso:=  ""
LOCAL tSubs:=     ""
LOCAL tCentavos:= VAL( SUBSTR( tStr, 17 ))

IF ( pValor > 0 )

   IF ( tCentavos > 0 )
      tExtenso:= ExtCem( STRZERO( tCentavos, 3 )) +;
                 aCifra[ 6 ][ IIF( tCentavos = 1, 1, 2 ) ]
   ENDIF

   IF ( INT( pValor ) > 0 )
      tExtenso:= IIF( INT( pValor ) = 1, "Real","Reais" ) +;
                 IIF( tCentavos > 0 ," e ", "" ) + tExtenso
   ENDIF

   FOR tX:= 5 TO 1 STEP -1
      IF ( VAL( tSubs:= SUBSTR( tStr, ( tX * 3 ) - 2, 3 )) > 0 )
         tExtenso:= ExtCem( tSubs ) +;
                    aCifra[tX, IIF( VAL( tSubs) = 1, 1, 2 ) ] + " " +;
                    tExtenso
      ENDIF

   NEXT tX

ENDIF

RETURN( StripDouble( tExtenso, " " ))
// eof rvlext.prg

Exemplo de como usar.:

Código: Selecionar todos

*--
*	FT2930.PRG	-	
*--


#include  "Acesso.ch"
#include  "SetCurs.ch"
#include  "Inkey.ch"

#define   nomeREL         "Emissao de duplicata"

PRIVATE 	dat,nfis,fin,icm,frete,total,conta,conta1,cod,quant,unit,ipi,for,doc,;
			conta,conta1,foraux,acum,custo,medio,ped,pfre,val,tval,val1,val2,val3,;
			ped,pedaux,pedt,desc,ate,cep


emp = SPACE(1)
foraux = 0
val1=0.00
val2=0.00
val3=0.00
val4=0.00
val5=0.00
cep = SPACE(8)
tval =0.00
dat=ctod("00.00.00")
fis1 = 0
nfis1=SPACE(5)
fis2 = 0
nfis2=SPACE(5)
fis3 = 0
nfis3=SPACE(5)

tip = SPACE(1)
des = SPACE(45)
pra = SPACE(30)
for = SPACE(4)
moe = SPACE(1)
foraux = 0
eve = SPACE(4)
hisaux = 0
his = SPACE(3)
var = SPACE(40)



SELECT 1
USE CADCLI SHARED ALIAS CLI

IF NETERR()
	Mensagem("Erro na abertura do arquivo, tente novamente")
	INKEY(0)
	TONE(1000,2)
	RETURN
ENDIF

SET INDEX TO INDCLI,INDNOM
GO TOP

SET ORDER TO 1

SELECT 2
USE CADNOT INDEX INDNOT SHARED ALIAS NOTA

IF NETERR()
	Mensagem("Alguem esta usando a nota fiscal.")
	INKEY(0)
	TONE(1000,2)
	CLOSE ALL
	RETURN
ENDIF

GO TOP


DO WHILE .T.


	CALL DUP

	venc1= CTOD("00.00.00")
	venc2= CTOD("00.00.00")	
	venc3= CTOD("00.00.00")
	venc4= CTOD("00.00.00")
	venc5= CTOD("00.00.00")
	val1=0.00
	eve = SPACE(4)
	hisaux = 0
	his = SPACE(3)
	var = SPACE(40)

	val2=0.00
	val3=0.00
	val4=0.00
	val5=0.00

	nom= SPACE(40)
	ende= SPACE(30)
	cgc= SPACE(20)
	ins= SPACE(16)
	mun= SPACE(15)
	bai= SPACE(15)
	ufd = SPACE(2)

	v1 = CTOD("00.00.00")
	v2 = CTOD("00.00.00")
	v3 = CTOD("00.00.00")
	v4 = CTOD("00.00.00")
	v5 = CTOD("00.00.00")



	nf1 = 0
	nf2 = 0
	nf3 = 0
	nf4 = 0
	nf5 = 0

	nfv1 = 0.00
	nfv2 = 0.00
	nfv3 = 0.00
	nfv4 = 0.00
	nfv5 = 0.00


	SET COLOR TO N/W,N/W
	@ 12,08 GET fis1 PICTURE "@K 99999" VALID fis1 > 0
	@ 12,14 GET fis2 PICTURE "@K 99999"
	@ 12,20 GET fis3 PICTURE "@K 99999"
	SET CURSOR ON
	READ
	SET CURSOR OFF
	IF LASTKEY() = 27 
		CLOSE ALL
		RETURN
	ENDIF

	nfis1 = STRZERO(fis1,5,0)
	nfis2 = STRZERO(fis2,5,0)
	nfis3 = STRZERO(fis3,5,0)

	@ 12,08 SAY nfis1

	SELECT NOTA
	GO TOP
	SEEK nfis1
	IF FOUND()
		foraux = VAL(CLINOT)
		nom= SUBSTR(NOMCLI,1,40)
		ende= SUBSTR(ENDCLI,1,30)
		cgc= CGCCLI
		ins= INSCLI
		mun= SUBSTR(MUNCLI,1,15)
		ufd = UFDCLI
		cep = CEPCLI
		dat = DATNOT	
		tval = TOTALNOTA
		venc1= VENC1NOT
		venc2 = VENC2NOT
		venc3= VENC3NOT
		val1 = VAL1NOT
		val2 = VAL2NOT
		val3 = VAL3NOT


		SELECT CLI
		SET ORDER TO 1
		GO TOP
		SEEK STRZERO(foraux,4,0)

		pra = RTRIM(mun)+"-"+RTRIM(ende)+"-CEP:"+cep

		SELECT NOTA
		GO TOP
		SEEK nfis2
		IF FOUND()
			val1 = val1 + VAL1NOT
			val2 = val2 + VAL2NOT
			val3 = val3 + VAL3NOT
		ENDIF

		SELECT NOTA
		GO TOP
		SEEK nfis3
		IF FOUND()
			val1 = val1 + VAL1NOT
			val2 = val2 + VAL2NOT
			val3 = val3 + VAL3NOT
		ENDIF

	ELSE
	

		SET COLOR TO N/W,N/W
		@ 06,12 GET foraux PICTURE "@K 9999"
		SET CURSOR ON
		READ
		SET CURSOR OFF
		IF LASTKEY()=27
			LOOP
		ENDIF


		for = STRZERO(foraux,4,0)

		@ 06,12 SAY for

		SELECT CLI
		SET ORDER TO 1
		GO TOP
		SEEK for
		IF .NOT. FOUND()
			TONE(1000,2)
			LOOP
		ENDIF

		nom= SPACE(40)
		ende= SPACE(30)
		cgc= SPACE(20)
		ins= SPACE(16)
		mun= SPACE(15)
		bai= SPACE(15)
		ufd = SPACE(2)

		nom= DESCLI
		ende= ENDCLI
		cgc= CGCCLI
		ins= INSCLI
		mun= CIDCLI
		ufd = UFDCLI
		pra = RTRIM(mun)+"-"+RTRIM(ende)+"-CEP:"+cep
		cep = CEPCLI

	ENDIF

	SET COLOR TO N/W,N/W
	@ 06,17 GET nom PICTURE "@K XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
	@ 06,65 GET dat PICTURE "@K 99.99.99" VALID !EMPTY(dat)
	@ 07,12 GET ende PICTURE "@KX"
	@ 07,54 GET mun PICTURE "@KX"
	@ 08,12 GET ufd PICTURE "@KX"
	@ 09,11 GET cgc PICTURE "@KX"
	@ 09,52 GET ins PICTURE "@KX"
	@ 10,11 GET cep PICTURE "@KR 99999/999"
	@ 11,11 GET pra PICTURE "@K XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
	SET CURSOR ON
	READ
	SET CURSOR OFF
	IF LASTKEY() = 27
		LOOP
	ENDIF

	tval = val1+val2+val3

	SET COLOR TO N/W,N/W
	@ 12,34 GET tval PICTURE "@K 99999.99" VALID tval > 0.00
	SET CURSOR ON
	READ
	SET CURSOR OFF
	IF LASTKEY()=27
		LOOP
	ENDIF


	SET COLOR TO N/W,N/W
	@ 16,07 GET venc1 PICTURE "@K 99.99.99" VALID !EMPTY(venc1)
	@ 16,19 GET val1 PICTURE "@K 99999999999.99"
	@ 17,07 GET venc2 PICTURE "@K 99.99.99"
	@ 17,19 GET val2 PICTURE "@K 99999999999.99"
	@ 18,07 GET venc3 PICTURE "@K 99.99.99"
	@ 18,19 GET val3 PICTURE "@K 99999999999.99"
	@ 19,07 GET venc4 PICTURE "@K 99.99.99"
	@ 19,19 GET val4 PICTURE "@K 99999999999.99"
	@ 20,07 GET venc5 PICTURE "@K 99.99.99"
	@ 20,19 GET val5 PICTURE "@K 99999999999.99"

	SET CURSOR ON
	READ
	SET CURSOR OFF
	IF LASTKEY()=27
		LOOP
	ENDIF


	IF .NOT. Confirma("Posso prosseguir S/N?")
		LOOP
	ENDIF


        Impdup()


ENDDO

//============
PROCEDURE IMPDUP


DO WHILE .T.

	num = SPACE(2)
	valor =0.00
	ve = CTOD("00.00.00")

	DECLARE op[10]
	op[1] = "1. Vencimento"
	op[2] = "2. Vencimento"
	op[3] = "3. Vencimento"
	op[4] = "4. Vencimento"
	op[5] = "5. Vencimento"
	op[6] = "Abandonar"

	Boxsdin(07,20,14,40,.T.)
	SET COLOR TO N/GR,W*/N+

	mo = ACHOICE(08,21,13,39,op)

	IF LASTKEY() = 27
		RETURN
	ENDIF


	IF mo=1

		IF val1 = 0.00 .OR. EMPTY(venc1)
			TONE(1000,2)
			LOOP
		ENDIF				


		vlext	= SPACE(300)
		vlex1	= SPACE(58)				&&... primeira linha do empenho
		vlex2	= SPACE(58)				&&... segunda linha extenso
		vlex3	= SPACE(58)				&&... terceira linha extenso

		IF .NOT. Confirma("Posso Imprimir?S/N")
			LOOP
		ENDIF

		num = "01"
		ve = venc1
		valor = val1

		IMP2930()

	ENDIF


	IF mo=2

		IF val2 = 0.00 .OR. EMPTY(venc2)
			TONE(1000,2)
			LOOP
		ENDIF				


		vlext	= SPACE(300)
		vlex1	= SPACE(58)				&&... primeira linha do empenho
		vlex2	= SPACE(58)				&&... segunda linha extenso
		vlex3	= SPACE(58)				&&... terceira linha extenso

		IF .NOT. Confirma("Posso Imprimir?S/N")
			LOOP
		ENDIF

		num = "02"
		ve = venc2
		valor = val2

		IMP2930()

	ENDIF

	IF mo=3

		IF val3 = 0.00 .OR. EMPTY(venc3)
			TONE(1000,2)
			LOOP
		ENDIF				


		vlext	= SPACE(300)
		vlex1	= SPACE(58)				&&... primeira linha do empenho
		vlex2	= SPACE(58)				&&... segunda linha extenso
		vlex3	= SPACE(58)				&&... terceira linha extenso

		IF .NOT. Confirma("Posso Imprimir?S/N")
			LOOP
		ENDIF

		num = "03"
		ve = venc3
		valor = val3

                IMP2930()

	ENDIF

	IF mo=4

		IF val4 = 0.00 .OR. EMPTY(venc4)
			TONE(1000,2)
			LOOP
		ENDIF				


		vlext	= SPACE(300)
		vlex1	= SPACE(58)				&&... primeira linha do empenho
		vlex2	= SPACE(58)				&&... segunda linha extenso
		vlex3	= SPACE(58)				&&... terceira linha extenso

		IF .NOT. Confirma("Posso Imprimir?S/N")
			LOOP
		ENDIF

		num = "04"
		ve = venc4
		valor = val4

		IMP2930()

	ENDIF

	IF mo=5

		IF val5 = 0.00 .OR. EMPTY(venc5)
			TONE(1000,2)
			LOOP
		ENDIF				


		vlext	= SPACE(300)
		vlex1	= SPACE(58)				&&... primeira linha do empenho
		vlex2	= SPACE(58)				&&... segunda linha extenso
		vlex3	= SPACE(58)				&&... terceira linha extenso

		IF .NOT. Confirma("Posso Imprimir?S/N")
			LOOP
		ENDIF

		num = "05"
		ve = venc5
		valor = val5

		IMP2930()

	ENDIF


	IF mo= 6
		EXIT
	ENDIF

ENDDO


RETURN


PROCEDURE Imp2930

IF !Onprinter(nomeREL)
	RETURN
ENDIF



?? CHR(27)+"0"

clin = 0

clin = clin + 10
@ clin,58 SAY DAY(dat) PICTURE "99"
@ clin,64 SAY MONTH(dat) PICTURE "99"
@ clin,69 SAY YEAR(dat) PICTURE "9999"
clin = clin + 6

@ clin,03 SAY tval PICTURE "99999.99"
@ clin,18 SAY nfis1 PICTURE "99999"
IF fis3 <> 0
	@ clin,13 SAY "/"
	@ clin,14 SAY SUBSTR(nfis3,4,2)
ELSEIF fis2 <> 0
	@ clin,13 SAY "/"
	@ clin,14 SAY SUBSTR(nfis2,4,2)
ENDIF
@ clin,26 SAY valor PICTURE "@E 999,999.99"
@ clin,43 SAY nfis1 PICTURE "999999"
@ clin,48 SAY "-"
@ clin,49 SAY num
@ clin,51 SAY ve PICTURE "99.99.99"

clin = clin + 6

//IF desc > 0.00
//	@ clin,18 SAY desc PICTURE "@E 999,999.99"
//	@ clin,50 SAY ate
//ENDIF


@ clin,28 SAY nom
clin = clin + 2
@ clin,28 SAY ende
clin = clin + 2
@ clin,28 SAY mun
clin = clin + 2
?? CHR(15)
@ clin,28+20 SAY pra
?? CHR(18)
@ clin,63 SAY ufd
@ clin,71 SAY cep PICTURE "@R 99999/999"
clin = clin + 2
@ clin,28 SAY cgc
@ clin,60 SAY ins

vlext = Extenso(valor)

vlext=vlext+REPLICATE("*",(116-LEN(vlext)))

clin = clin + 2
@ clin,27 SAY SUBSTR(vlext,1,52)
//@ clin,79 SAY "*"
clin = clin + 1
@ clin,28 SAY SUBSTR(vlext,53,52)
clin = clin + 1

clin = clin + 4


EJECT

?? CHR(27)+"2"
offprinter()

RETURN
*=====================

deividdjs · Mensagem por **deividdjs** » 12 Abr 2021 22:44

boa noite amigo...

quando eu coloco o valor de 1.000.000,00 ... a função não retorna o "de"

exemplo

un milhão "de" Reais ...

como faço para fazer funcionar isso ??

Abraço!!

Deivid Souza

Mensagem por **JoséQuintas** » 13 Abr 2021 12:31

se retorna MILHAO REAIS ou MILHOES REAIS, só trocar

Código: Selecionar todos

FUNCTION MeuExtenso( nValor )

LOCAL cExtenso

cExtenso := RotinaAnterior( nValor )
cExtenso := StrTran( cExtenso, "ILHAO REAIS", "ILHAO DE REAIS" )
cExtenso := StrTran( cExtenso, "ILHOES REAIS", "ILHOES DE REAIS" )

RETURN cExtenso

deividdjs · Mensagem por **deividdjs** » 13 Abr 2021 14:21

OBRIGADO MEU AMIGO ... acabei resolvendo ontem de outra forma ... showww!!

//------------------------------------//
* EXTENSO() /////////// EM ESPANHOL
//----------------------------------///

FUNCTION Extenso_ES( pValor,cSing,cPlural ) // RETORNA MOEDA SINGULAR E PLURAL

LOCAL tStr:= STRZERO( ABS(pValor), 18, 2 )
LOCAL aCifra:= { { "Trill¢n", "Trillones" },;
{ "Mil Millones", "Mil Millones" },;
{ "Mill¢n", "Millones" },;
{ "Mil", "Mil" },;
{ "", "" },;
{ "Centavo", "Centavos" }}

LOCAL tX, tEx1
LOCAL tExtenso:= ""
LOCAL tSubs:= ""
LOCAL tCentavos:= VAL( SUBSTR( tStr, 17 ))

IF ( pValor > 0 )

IF ( tCentavos > 0 )
tExtenso:= ExtCem_ES( STRZERO( tCentavos, 3 )) +;
aCifra[ 6 ][ IIF( tCentavos = 1, 1, 2 ) ]
ENDIF

IF ( INT( pValor ) > 0 )
tExtenso:= IIF( INT( pValor ) = 1,cSing,IIF(SUBSTR(tStr,10,6) = "000000"," de " + cPlural,cPlural)) +;
IIF( tCentavos > 0 ," con " + transform(tCentavos,"99") + "/100", "" ) // + tExtenso
ENDIF

FOR tX:= 5 TO 1 STEP -1
IF ( VAL( tSubs:= SUBSTR( tStr, ( tX * 3 ) - 2, 3 )) > 0 )
tExtenso:= ExtCem_ES( tSubs ) + aCifra[tX, IIF(VAL(tSubs) = 1, 1, 2 ) ] + " " + tExtenso
ENDIF

NEXT tX

ENDIF

RETURN( StripDouble( tExtenso, " " ))

NESTA PARTE DO CODIGO!!

IF ( INT( pValor ) > 0 )
tExtenso:= IIF( INT( pValor ) = 1,cSing,IIF(SUBSTR(tStr,10,6) = "000000"," de " + cPlural,cPlural)) +;
IIF( tCentavos > 0 ," con " + transform(tCentavos,"99") + "/100", "" ) // + tExtenso
ENDIF

Forte Abraço!