• Home
 · 
• Miscellaneous
 · 
• EXTENSO (Port.) - Converte n¨meros em valor por extenso (converts numbers into string with currency

EXTENSO (Port.) - Converte n¨meros em valor por extenso (converts numbers into string with currency

EXTENSO (Port.) - Converte n¨meros em valor por extenso (converts numbers into string with currency.: i.e.: 123.45 -> "cento e vinte e tr¨s

API Declarations


Global gstrSeparadorDecimal As String
Global gstrSeparadorMilhar As String
Global gstrSeparadorData As String

Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long




Rate EXTENSO (Port.) - Converte n¨meros em valor por extenso (converts numbers into string with currency

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

'Sub CaregaConfiguraçõesRegionais()

'Gabriel Tavares de Oliveira Castellani

'Carrega os padrões de ponto decimal, separador de milhar e
'data do Windows

Sub CarregaConfiguracoesRegionais()

    Dim ret As Long
    Dim auxSep As String * 2

    'le separador decimal do win.ini
    ret = GetProfileString("intl", "sDecimal", ".", auxSep, 2)
    gstrSeparadorDecimal = Left$(auxSep, 1)

    'le separador de milhar do win.ini
    ret = GetProfileString("intl", "sThousand", ",", auxSep, 2)
    gstrSeparadorMilhar = Left$(auxSep, 1)

    'le separador de data do win.ini
    ret = GetProfileString("intl", "sDate", "/", auxSep, 2)
    gstrSeparadorData = Left$(auxSep, 1)

End Sub


'*************************************************************
' Função CDUEXTENSO - CALLED BY EXTENSO (BELLOW)
'*************************************************************
' Gabriel Tavares de Oliveira Castellani
'*************************************************************
' Retorna um valor por extenso
'*************************************************************
Function CDUExtenso(ByVal Valor As Integer) As String

    Dim eastrU(0 To 19) As String
    Dim eastrD(2 To 9) As String
    Dim eastrC(0 To 9) As String
    Dim estrValor As String
    
    eastrU(0) = ""
    eastrU(1) = " e um"
    eastrU(2) = " e dois"
    eastrU(3) = " e três"
    eastrU(4) = " e quatro"
    eastrU(5) = " e cinco"
    eastrU(6) = " e seis"
    eastrU(7) = " e sete"
    eastrU(8) = " e oito"
    eastrU(9) = " e nove"
    eastrU(10) = " e dez"
    eastrU(11) = " e onze"
    eastrU(12) = " e doze"
    eastrU(13) = " e treze"
    eastrU(14) = " e quatorze"
    eastrU(15) = " e quinze"
    eastrU(16) = " e dezesseis"
    eastrU(17) = " e dezessete"
    eastrU(18) = " e dezoito"
    eastrU(19) = " e dezenove"
    
    eastrD(2) = " e vinte"
    eastrD(3) = " e trinta"
    eastrD(4) = " e quarenta"
    eastrD(5) = " e cinqüenta"
    eastrD(6) = " e sessenta"
    eastrD(7) = " e setenta"
    eastrD(8) = " e oitenta"
    eastrD(9) = " e noventa"
    
    eastrC(0) = ""
    eastrC(1) = ", cento"
    eastrC(2) = ", duzentos"
    eastrC(3) = ", trezentos"
    eastrC(4) = ", quatrocentos"
    eastrC(5) = ", quinhentos"
    eastrC(6) = ", seiscentos"
    eastrC(7) = ", setecentos"
    eastrC(8) = ", oitocentos"
    eastrC(9) = ", novecentos"
    
    Select Case Valor
        Case 100
            CDUExtenso = " e cem"
        Case 0
            CDUExtenso = ""
        Case 1
            CDUExtenso = "hum"
        Case Else
            estrValor = Format(Valor, "000")
            CDUExtenso = eastrC(Val(Left(estrValor, 1)))
            
            Select Case Val(Mid(estrValor, 2, 1))
                Case 0, 1
                    CDUExtenso = CDUExtenso & eastrU(Val(Right(estrValor, 2)))
                Case Else
                    CDUExtenso = CDUExtenso & eastrD(Val(Mid(estrValor, 2, 1)))
                    If Val(Right(estrValor, 1)) > 0 Then CDUExtenso = CDUExtenso & eastrU(Val(Right(estrValor, 1)))
            End Select
    End Select

End Function


'*************************************************************
' Função EXTENSO  - MAIN FUNCTION - CALL THIS ONE
'*************************************************************
' Gabriel Tavares de Oliveira Castellani
'*************************************************************
' Retorna um valor por extenso
'*************************************************************
Function Extenso(ByVal Valor As Double) As String

    Dim eastrInteiro() As String
    Dim eastrMilhares() As String
    Dim i As Integer, j As Integer
    Dim estrTeste As String
    Dim eastrParticula(0 To 2) As String
    
    eastrParticula(0) = ""
    eastrParticula(1) = " mil"
    eastrParticula(2) = " milh"
    
    eastrInteiro = Split(Format(Valor, "###,###,##0.00"), gstrSeparadorDecimal)
    eastrMilhares = Split(eastrInteiro(0), gstrSeparadorMilhar)
    
    estrTeste = ""
    For i = 0 To UBound(eastrMilhares)
        eastrMilhares(i) = CDUExtenso(eastrMilhares(i))
        estrTeste = estrTeste & eastrMilhares(i)
    Next
    eastrInteiro(1) = CDUExtenso(eastrInteiro(1))
    
    If estrTeste & eastrInteiro(1) = "" Then
        Extenso = "zero reais"
    Else
        j = 0
        For i = UBound(eastrMilhares) To 0 Step -1
            If j = 2 Then
                If Trim(eastrMilhares(i)) = "hum" Then
                    eastrParticula(j) = eastrParticula(j) & "ão"
                Else
                    eastrParticula(j) = eastrParticula(j) & "ões"
                End If
            End If
            Extenso = eastrMilhares(i) & eastrParticula(j) & Extenso
            j = j + 1
        Next
        If Extenso = "hum" Then
            Extenso = Extenso & " real"
        Else
            Extenso = Extenso & " reais"
        End If
        
        If eastrInteiro(1) <> "" Then
            If eastrInteiro(1) = "hum" Then
                Extenso = IIf(Extenso <> "", Extenso & " e um centavo", "hum centavo")
            Else
                Extenso = Extenso & eastrInteiro(1) & " centavos"
            End If
        End If
        
        If Left(Extenso, 2) = " e" Or Left(Extenso, 2) = ", " Then Extenso = Right(Extenso, Len(Extenso) - 2)
        Extenso = Trim(Extenso)
        
    End If

End Function

'******************************************************
' USE THIS FOR AN EXAMPLE
'******************************************************
Private Sub Form_Click()
    CarregaConfiguracoesRegionais
    MsgBox Extenso(123.45)
End Sub