segunda-feira, 26 de julho de 2010

Recebe uma Double e retorna no formato monetário

Function FormatCurrency(num As Double) As String

'*************************************************************************************
'Função que Recebe uma Double( Ex.:12345.86 ou -12345.86 ) e retorna esse valor
'tipo String formatado como monetário. ( Ex.:R$12.345,86 ou R$-12.345,86)
'*************************************************************************************


On Error Goto ops

Dim SstrNumInt As String
Dim sign As String
Dim x, ant, RoundNum, cents As String

sign = Left(num,1)
If sign<>"-" Then
sign = ""
End If

RoundNum = Round(num, 2)
ant= Cstr(Fix(RoundNum))
ant = SubstituiString(Cstr(ant),"-","")
virgulapos = Instr(Cstr(RoundNum),",")
TamanhoNum = Len(Cstr(RoundNum))
decimal = TamanhoNum - virgulapos
If ant = (Cstr(RoundNum))Then
cents="00"
Elseif decimal = 1 Then
cents= (Right(Cstr(RoundNum),2)+"0")
Else
cents= Right(Cstr(RoundNum),2)
End If

cents = SubstituiString(Cstr(cents),",","")

num = ant
SstrNumInt = Cstr(Fix(Round(num, 2)))

If num < 1000 Then
x = SstrNumInt
Else
If num >= 1000 And num < 10000 Then
x = Left(SstrNumInt,1) + "." + Right(SstrNumInt,3)
Else
If num >= 10000 And num < 100000 Then
x = Left(SstrNumInt,2) + "." + Right(SstrNumInt,3)
Else
If num >= 100000 And num < 1000000 Then
x = Left(SstrNumInt,3) + "." + Right(SstrNumInt,3)
Else
If num >= 1000000 And num < 10000000 Then
x = Left(SstrNumInt,1) + "." + Mid(SstrNumInt,2,3) + "." + Right(SstrNumInt,3)
Else
If num >= 10000000 And num < 100000000 Then
x = Left(SstrNumInt,2) + "." + Mid(SstrNumInt,3,3) + "." + Right(SstrNumInt,3)
Else
If num >= 100000000 And num < 1000000000 Then
x = Left(SstrNumInt,3) + "." + Mid(SstrNumInt,4,3) + "." + Right(SstrNumInt,3)
Else
If num >= 1000000000 And num < 10000000000 Then
x = Left(SstrNumInt,1) + "." + Mid(SstrNumInt,2,3) + + "." + Mid(SstrNumInt,5,3)+"." + Right(SstrNumInt,3)
End If
End If
End If
End If
End If
End If
End If
End If
FormatCurrency = Cstr(sign + Cstr(x) + "," + Cstr(cents))

Exit Function

ops:
Messagebox "Erro na função FormatCurrency - " & Str(Err) & ": " & Error & " - line: " & Erl

End Function

Nenhum comentário:

Postar um comentário