'==================================
' UWAGA! Funkcja wymaga obu funkcji
' prywatnych zamieszczonych poniżej
'==================================
Const WERSJA As String = _
"Funkcja Słownie v.1.02 (Akademia-VBA.pl)"
Dim Opis(19) As String
Dim DziesOpis(2 To 10) As String
Dim SetOpis(1 To 9) As String
Dim Zlotowki As String
Dim Grosze As String
Dim TrojkaZl As String
Dim TrojkaTys As String
Dim TrojkaMln As String
Dim wynikGrosze As String
Dim wynikZlote As String
Dim Ujemna As Boolean
On Error GoTo Obsluga
'sprawdzenie czy puste
If IsNull(Kwota) Or IsEmpty(Kwota) Then
Slownie = "# Brak kwoty!"
Exit Function
End If
'sprawdzenie czy liczba
If Not IsNumeric(Kwota) Then
Slownie = "# Nieprawidłowy typ wartości!"
Exit Function
End If
'gdy ujemna
If Kwota < 0 Then
Ujemna = True
Kwota = -Kwota
End If
'konwersja na stringi
Zlotowki = CStr(Int(Kwota))
Grosze = CStr(Kwota - Int(Kwota))
'sprawdzenie, czy nie za duża, max 99 mln
If Len(Zlotowki) > 9 Then
Slownie = "# Kwota za duża, max 999 mln!"
Exit Function
End If
'ewentualne zaokrąglenie do 2 msc po przecinku
'tu drobna poprawka stąd wersja 1.01
'było ...= CStr(Round(CDbl(Grosze) * 100, 2))
If Len(Grosze) > 2 Then
Grosze = CStr(Round(CDbl(Grosze), 2) * 100)
End If
'kod zasadniczy
'==============
Select Case Len(Zlotowki)
Case 1 To 3
wynikZlote = Trojka(Zlotowki) & _
OpisRzeduWielkosci(CLng(Zlotowki), "zł", False)
Case 4 To 6
TrojkaZl = Right(Zlotowki, 3)
TrojkaTys = Left(Zlotowki, Len(Zlotowki) - 3)
wynikZlote = Trojka(TrojkaTys) & _
OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _
& " " & Trojka(TrojkaZl) & _
OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True)
Case 7 To 9
TrojkaZl = Right(Zlotowki, 3)
TrojkaTys = Mid(Zlotowki, Len(Zlotowki) - 5, 3)
TrojkaMln = Left(Zlotowki, Len(Zlotowki) - 6)
wynikZlote = Trojka(TrojkaMln) & _
OpisRzeduWielkosci(CLng(TrojkaMln), "mln", True) _
& " " & Trojka(TrojkaTys) & _
OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _
& " " & Trojka(TrojkaZl) & _
OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True)
End Select
wynikGrosze = Trojka(Grosze) & _
OpisRzeduWielkosci(CLng(Grosze), "gr", False)
Slownie = IIf(Ujemna, "minus ", "") & _
Trim(wynikZlote & " " & wynikGrosze)
Exit Function
Obsluga:
MsgBox Err & " - " & Err.Description, vbCritical, WERSJA
End Function
Private Function OpisRzeduWielkosci( _
Liczba As Long, RzadWielkosci As String, _
WiekszeTysiac As Boolean) As String
Dim JestZero As Boolean
Dim DwieOstatnie As Long
Dim Ostatnia As Long
If Liczba = 0 Then
If WiekszeTysiac Then
If RzadWielkosci = "zł" Then
OpisRzeduWielkosci = "złotych"
End If
Else
OpisRzeduWielkosci = ""
End If
Exit Function
End If
DwieOstatnie = CLng(Right(CStr(Liczba), 2))
Ostatnia = CLng(Right(CStr(Liczba), 1))
Select Case RzadWielkosci
Case "gr"
Select Case DwieOstatnie
Case 0, 5 To 19
OpisRzeduWielkosci = " groszy"
Case 1
OpisRzeduWielkosci = " grosz"
Case 2 To 4
OpisRzeduWielkosci = " grosze"
Case Is > 19
Select Case Ostatnia
Case 0, 1, Is > 4
OpisRzeduWielkosci = " groszy"
Case 2 To 4
OpisRzeduWielkosci = " grosze"
End Select
End Select
Case "zł"
Select Case DwieOstatnie
Case 0, 5 To 19
OpisRzeduWielkosci = " złotych"
Case 1
OpisRzeduWielkosci = " złoty"
Case 2 To 4
OpisRzeduWielkosci = " złote"
Case Is > 19
Select Case Ostatnia
Case 0, 1, Is > 4
OpisRzeduWielkosci = " złotych"
Case 2 To 4
OpisRzeduWielkosci = " złote"
End Select
End Select
Case "tys"
Select Case DwieOstatnie
Case 0, 5 To 19
OpisRzeduWielkosci = " tysięcy"
Case 1
OpisRzeduWielkosci = " tysiąc"
Case 2 To 4
OpisRzeduWielkosci = " tysiące"
Case Is > 19
Select Case Ostatnia
Case 0, 1, Is > 4
OpisRzeduWielkosci = " tysięcy"
Case 2 To 4
OpisRzeduWielkosci = " tysiące"
End Select
End Select
Case "mln"
Select Case DwieOstatnie
Case 0, 5 To 19
OpisRzeduWielkosci = " milionów"
Case 1
OpisRzeduWielkosci = " milion"
Case 2 To 4
OpisRzeduWielkosci = " miliony"
Case Is > 19
Select Case Ostatnia
Case 0, 1, Is > 4
OpisRzeduWielkosci = " milionów"
Case 2 To 4
OpisRzeduWielkosci = " miliony"
End Select
End Select
End Select
End Function
Private Function Trojka(strLiczba As String) As String
Dim lngLiczba As Long
Dim lngOstatnia As Long
Dim lngDwieOstatnie As Long
Dim Opis(19) As String
Dim DziesOpis(10) As String
Dim SetOpis(9) As String
If CLng(strLiczba) = 0 Then
Trojka = ""
Exit Function
End If
Opis(0) = "zero"
Opis(1) = "jeden"
Opis(2) = "dwa"
Opis(3) = "trzy"
Opis(4) = "cztery"
Opis(5) = "pięć"
Opis(6) = "sześć"
Opis(7) = "siedem"
Opis(8) = "osiem"
Opis(9) = "dziewięć"
Opis(10) = "dziesięć"
Opis(11) = "jedenaście"
Opis(12) = "dwanaście"
Opis(13) = "trzynaście"
Opis(14) = "czternaście"
Opis(15) = "piętnaście"
Opis(16) = "szesnaście"
Opis(17) = "siedemnaście"
Opis(18) = "osiemnaście"
Opis(19) = "dziewiętnaście"
DziesOpis(0) = "zero"
DziesOpis(1) = "dziesięć"
DziesOpis(2) = "dwadzieścia"
DziesOpis(3) = "trzydzieści"
DziesOpis(4) = "czterdzieści"
DziesOpis(5) = "pięćdziesiąt"
DziesOpis(6) = "sześćdziesiąt"
DziesOpis(7) = "siedemdziesiąt"
DziesOpis(8) = "osiemdziesiąt"
DziesOpis(9) = "dziewięćdziesiąt"
SetOpis(0) = "zero"
SetOpis(1) = "sto"
SetOpis(2) = "dwieście"
SetOpis(3) = "trzysta"
SetOpis(4) = "czterysta"
SetOpis(5) = "pięćset"
SetOpis(6) = "sześćset"
SetOpis(7) = "siedemset"
SetOpis(8) = "osiemset"
SetOpis(9) = "dziewięćset"
lngLiczba = CLng(strLiczba)
'tu policzymy ostatnią
lngOstatnia = CLng(Right(strLiczba, 1))
Select Case lngLiczba
Case Is < 20
Trojka = Opis(lngLiczba)
Case Is < 100
If lngLiczba Mod 10 = 0 Then
Trojka = DziesOpis(lngLiczba / 10)
Else
Trojka = DziesOpis((lngLiczba - lngOstatnia) / 10) _
& " " & Opis(lngOstatnia)
End If
Case Else 'trzycyfrowa
If lngLiczba Mod 100 = 0 Then
Trojka = SetOpis(lngLiczba / 100)
Else
'tu policzymy dwie ostatnie
lngDwieOstatnie = CLng(Right(strLiczba, 2))
If lngLiczba Mod 10 = 0 Then
Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
& " " & DziesOpis(lngDwieOstatnie / 10)
Else
If lngDwieOstatnie < 20 Then
Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
& " " & Opis(lngDwieOstatnie)
Else
Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
& " " & DziesOpis((lngDwieOstatnie - lngOstatnia) / 10) _
& " " & Opis(lngOstatnia)
End If
End If
End If
End Select
End Function