Página 1 de 1

Unidade de medida

Enviado: Qua Fev 08, 2012 11:46 am
por belgerson
Olá a todos.
Trabalho em cartório de notas e em algumas escrituras, preciso escrever metros por extenso, como por exemplo: 1.928,20 (hum mil, novecentos e vinte e oito metros e vinte centímetros).
Basicamente achei que poderia ter algo como a EXTENS32.DLL que escreve os valores por extenso.
Procurei por vários fóruns e achei algo aproximado, porem não sei rodar isto através de uma macro do word (sei criar e editar uma macro, mas na edição, copiar e colar a função abaixo, dá erro).
Se alguém puder ajudar verificando se esta macro funciona da forma acima e deixa-la pronta para o uso, agradeço imensamente.





Function VExtenso(NValor)
On Error GoTo 99
If IsNull(NValor) Or NValor > 9999999 Then
VExtenso = "# VALOR POR EXTENSO..............."

Exit Function
End If

If (NValor) < 0 Then
NValor = NValor * -1
End If

Dim nContador, nTamanho As Integer
Dim CValor, CPArte, CFinal, Etiq As String
ReDim aGrupo(4), aTexto(4) As String


ReDim aUnid(19) As String
aUnid(1) = "Um ": aUnid(2) = "Dois ": aUnid(3) = "Três "
aUnid(4) = "Quatro ": aUnid(5) = "Cinco ": aUnid(6) = "Seis "
aUnid(7) = "Sete ": aUnid(8) = "Oito ": aUnid(9) = "Nove "
aUnid(10) = "Dez ": aUnid(11) = "Onze ": aUnid(12) = "Doze "
aUnid(13) = "Treze ": aUnid(14) = "Quatorze ": aUnid(15) = "Quinze "
aUnid(16) = "Dezesseis ": aUnid(17) = "Dezessete ": aUnid(18) = "Dezoito "
aUnid(19) = "Dezenove "

ReDim aDezena(9) As String
aDezena(1) = "Dez ": aDezena(2) = "Vinte ": aDezena(3) = "Trinta "
aDezena(4) = "Quarenta ": aDezena(5) = "Cinquenta "
aDezena(6) = "Sessenta ": aDezena(7) = "Setenta ": aDezena(8) = "Oitenta "

aDezena(9) = "Noventa "

ReDim aCentena(9) As String
aCentena(1) = "Cento ": aCentena(2) = "Duzentos "
aCentena(3) = "Trezentos ": aCentena(4) = "Quatrocentos "
aCentena(5) = "Quinhentos ": aCentena(6) = "Seiscentos "
aCentena(7) = "Setecentos ": aCentena(8) = "Oitocentos "
aCentena(9) = "Novecentos "


CValor = Format$(NValor, "0000000000.00")
aGrupo(1) = Mid$(CValor, 2, 3)
aGrupo(2) = Mid$(CValor, 5, 3)
aGrupo(3) = Mid$(CValor, 8, 3)
aGrupo(4) = "0" + Mid$(CValor, 12, 2)


For nContador = 1 To 4
CPArte = aGrupo(nContador)
nTamanho = Switch(Val(CPArte) < 10, 1, Val(CPArte) < 100, 2, Val(CPArte) _
< 1000, 3)
If nTamanho = 3 Then
If Right$(CPArte, 2) <> "00" Then
aTexto(nContador) = aTexto(nContador) + aCentena(Left(CPArte, 1)) + _
"e "
nTamanho = 2
Else
aTexto(nContador) = aTexto(nContador) + IIf(Left$(CPArte, 1) = "1", _
"CEM ", aCentena(Left(CPArte, 1)))
End If
End If
If nTamanho = 2 Then
If Val(Right(CPArte, 2)) < 20 Then
aTexto(nContador) = aTexto(nContador) + aUnid(Right(CPArte, 2))
Else
aTexto(nContador) = aTexto(nContador) + aDezena(Mid(CPArte, 2, 1))
If Right$(CPArte, 1) <> "0" Then
aTexto(nContador) = aTexto(nContador) + "e "
nTamanho = 1
End If
End If
End If
If nTamanho = 1 Then
aTexto(nContador) = aTexto(nContador) + aUnid(Right(CPArte, 1))
End If
Next


If Val(aGrupo(1) + aGrupo(2) + aGrupo(3)) = 0 And Val(aGrupo(4)) <> 0 Then
CFinal = aTexto(4) + IIf(Val(aGrupo(4)) = 1, "centímetro", "centímetros")

Else
CFinal = ""
CFinal = CFinal + IIf(Val(aGrupo(1)) <> 0, aTexto(1) + _
IIf(Val(aGrupo(1)) > 1, "milhões ", "milhão "), "")
If Val(aGrupo(2) + aGrupo(3)) = 0 Then
CFinal = CFinal + "de "

Else
CFinal = CFinal + IIf(Val(aGrupo(2)) >= 1, aTexto(2) + "mil ", "")
End If

CFinal = CFinal + aTexto(3) + IIf(Val(aGrupo(1) + aGrupo(2) + aGrupo(3)) _
= 1, "metro ", "metros ")
CFinal = CFinal + IIf(Val(aGrupo(4)) <> 0, "e " + aTexto(4) + _
IIf(Val(aGrupo(4)) = 1, "centímetro", "centímetros"), "")
End If
VExtenso = CFinal

If NValor > 2 And NValor < 2000 And Left(VExtenso, 2) = "um" Then
VExtenso = Mid(VExtenso, 4, 250)

Else
VExtenso = CFinal
End If
Exit Function
99:
VExtenso = "# ERRO DE VALOR"
Exit Function

End Function


End Function
End Sub

Re: Unidade de medida

Enviado: Sex Fev 10, 2012 2:48 pm
por webmaster
Colega,

Essa função não ajuda?

http://www.tomasvasquez.com.br/blog/mic ... or-extenso

Pode ser usada no Word também.

Abraços