Code_NumberTect_Function



Option Base 0

'© Ioannis Varlamis 2005,2007

Private Const zero As String = "Μηδέν "

Function TextNumber(number As Variant, _

Optional NegativeText As String = "-", _

Optional IntGender As Integer = 3, _

Optional IntMeasurePlural As String, _

Optional IntMeasureSingular As String, _

Optional Separator As String = "και", _

Optional DecCount As Integer = -1, _

Optional DecGender As Integer = 3, _

Optional DecMeasurePlural As String, _

Optional DecMeasureSingular As String, _

Optional DecNoZero As Boolean = False, _

Optional IntNoZero As Boolean = False, _

Optional NoSpace As Boolean = False) As String

Application.Volatile True

If Application.Version < 9 Then GoTo myEnd

If IsDate(number) Then

TextNumber = DateText(number)

GoTo myEnd

End If

Select Case True

Case VBA.IsEmpty(number): GoTo myEnd

Case Not VBA.IsNumeric(number): TextNumber = CVErr(xlErrValue): GoTo myEnd

Case Application.IsLogical(number): TextNumber = CVErr(xlErrValue): GoTo myEnd

Case VBA.IsError(number): TextNumber = CVErr(xlErrValue): GoTo myEnd

End Select

Dim R(0 To 14) As Variant

Dim HD As Variant

Dim Y As Variant

Dim numberDEC As Variant: numberDEC = number

Dim M As Integer

Dim j As Integer

Dim IntPart As String

Dim DecPart As String

Dim dekata As String: dekata = "Δέκατα"

Dim dekato As String: dekato = "Δέκατο"

Dim sta As String: sta = "στά"

Dim sto As String: sto = "στό"

HD = VBA.Array("", "Δέκατα", _

"Εκατοστά", "Χιλιοστά", _

"Δεκάκις Χιλιοστά", "Εκατοντάκις Χιλιοστά", _

"Εκατομμυριοστά", "Δεκάκις Εκατομμυριοστά", _

"Εκατοντάκις Εκατομμυριοστά", "Δισεκατομμυριοστά", _

"Δεκάκις Δισεκατομμυριοστά", "Εκατοντάκις Δισεκατομμυριοστά", _

"Τρισεκατομμυριοστά", "Δεκάκις Τρισεκατομμυριοστά", _

"Εκατοντάκις Τρισεκατομμυριοστά", "Τετράκις Εκατομμυριοστά")

If Int(Abs(number)) = 1 And IntMeasureSingular "" _

Then IntMeasurePlural = IntMeasureSingular

IntPart = IntText(number, NegativeText, IntGender) & IntMeasurePlural

numberDEC = Abs(numberDEC)

numberDEC = Format(numberDEC, "0.000000000000000")

For j = 14 To 0 Step -1

R(j) = Mid(numberDEC, Len(numberDEC) - 14 + j, 1)

Next

numberDEC = VBA.Join(R, "")

Select Case True

Case DecCount = -1 And numberDEC = 0

DecCount = 0

DecMeasurePlural = ""

DecMeasureSingular = ""

Case DecCount = -1 And numberDEC 0

Y = numberDEC

Do

Y = Y / 10

M = M + 1

Loop While Y = Int(Y)

DecCount = 15 - M + 1

DecMeasurePlural = ""

DecMeasureSingular = ""

DecGender = 3

End Select

numberDEC = VBA.Left(numberDEC, DecCount)

If numberDEC = 1 And DecMeasureSingular "" Then DecMeasurePlural = DecMeasureSingular

Select Case True

Case DecCount = 0

Case DecMeasurePlural ""

DecPart = IntText(numberDEC, "", DecGender) & DecMeasurePlural

Case DecMeasurePlural = ""

DecPart = IntText(numberDEC, "", DecGender) & HD(DecCount)

If numberDEC = 1 And DecMeasureSingular = "" Then

DecPart = Replace(DecPart, dekata, dekato)

DecPart = Replace(DecPart, sta, sto)

End If

End Select

Separator = ChrW(32) & Separator & ChrW(32)

If DecCount = 0 Then Separator = ""

If DecNoZero = True Then

If VBA.Left(DecPart, 5) = RTrim(zero) Then Separator = "": DecPart = ""

End If

If IntNoZero = True Then

If IntPart = NegativeText & zero Then Separator = "": IntPart = NegativeText

End If

TextNumber = Application.WorksheetFunction.Trim(IntPart & Separator & DecPart)

If NoSpace = True Then TextNumber = _

Application.WorksheetFunction.Substitute(TextNumber, " ", "")

myEnd:

End Function

Private Function IntText(numberINT As Variant, _

Optional NegativeText As String = "-", _

Optional GenderINT As Integer = 3) As String

Dim Tm As Variant

Dim Am As Variant

Dim Fm As Variant

Dim tt As Variant

Dim AFt As Variant

Dim TAFd As Variant

Dim Te As Variant

Dim Ae As Variant

Dim Fe As Variant

Tm = VBA.Array("", "Ένα ", "Δύο ", "Τρία ", "Τέσσερα ", _

"Πέντε ", "Έξι ", "Επτά ", "Οκτώ ", "Εννέα ")

Am = VBA.Array("", "Ένας ", "Δύο ", "Τρεις ", "Τέσσερις ", _

"Πέντε ", "Έξι ", "Επτά ", "Οκτώ ", "Εννέα ")

Fm = VBA.Array("", "Μία ", "Δύο ", "Τρεις ", "Τέσσερις ", _

"Πέντε ", "Έξι ", "Επτά ", "Οκτώ ", "Εννέα ")

tt = VBA.Array("Δέκα ", "Έντεκα ", "Δώδεκα ", "Δεκατρία ", "Δεκατέσσερα ", _

"Δεκαπέντε ", "Δεκαέξι ", "Δεκαεπτά ", "Δεκαοκτώ ", "Δεκαεννέα ")

AFt = VBA.Array("Δέκα ", "Έντεκα ", "Δώδεκα ", "Δεκατρείς ", "Δεκατέσσερις ", _

"Δεκαπέντε ", "Δεκαέξι ", "Δεκαεπτά ", "Δεκαοκτώ ", "Δεκαεννέα ")

TAFd = VBA.Array("", "Δέκα ", "Είκοσι ", "Τριάντα ", "Σαράντα ", _

"Πενήντα ", "Εξήντα ", "Εβδομήντα ", "Ογδόντα ", "Ενενήντα ")

Te = VBA.Array("", "Εκατόν ", "Διακόσια ", "Τριακόσια ", "Τετρακόσια ", _

"Πεντακόσια ", "Εξακόσια ", "Επτακόσια ", "Οκτακόσια ", "Εννιακόσια ")

Ae = VBA.Array("", "Εκατόν ", "Διακόσιοι ", "Τριακόσιοι ", "Τετρακόσιοι ", _

"Πεντακόσιοι ", "Εξακόσιοι ", "Επτακόσιοι ", "Οκτακόσιοι ", "Εννιακόσιοι ")

Fe = VBA.Array("", "Εκατόν ", "Διακόσιες ", "Τριακόσιες ", "Τετρακόσιες ", _

"Πεντακόσιες ", "Εξακόσιες ", "Επτακόσιες ", "Οκτακόσιες ", "Εννιακόσιες ")

Dim ekato As String: ekato = "Εκατό "

Dim ekaton As String: ekaton = "Εκατόν "

Dim Tx As String: Tx = "Χίλια "

Dim Ax As String: Ax = "Χίλιοι "

Dim Fx As String: Fx = "Χίλιες "

Dim xx As String: xx = "Χιλιάδες "

Dim mill As String: mill = "Ένα Εκατομμύριο "

Dim mills As String: mills = "Εκατομμύρια "

Dim billion As String: billion = "Δις "

Dim trillion As String: trillion = "Τρις "

Dim V(0 To 14) As Variant

Dim apart As String, bpart As String, cpart As String

Dim dpart As String, epart As String, totalpart As String

Dim oSgn As Integer, oLen As Integer, i As Integer

oSgn = Sgn(numberINT)

numberINT = Abs(numberINT)

numberINT = Format(numberINT, "0.000000000000000")

numberINT = Int(numberINT)

oLen = Len(numberINT)

If oLen > 15 Then IntText = CVErr(xlErrValue): GoTo myEnd

For i = 0 To oLen - 1

V(15 - oLen + i) = Mid(numberINT, i + 1, 1)

Next

If V(1) + V(2) = 0 Then Te(1) = ekato

Select Case True

Case V(0) + V(1) + V(2) = 0

Case V(1) = 1

epart = Te(V(0)) & tt(V(2)) & trillion

Case Else

epart = Te(V(0)) & TAFd(V(1)) & Tm(V(2)) & trillion

End Select

Te(1) = ekaton

If V(5) + V(4) = 0 Then Te(1) = ekato

Select Case True

Case V(3) + V(4) + V(5) = 0

Case V(4) = 1

dpart = Te(V(3)) & tt(V(5)) & billion

Case Else

dpart = Te(V(3)) & TAFd(V(4)) & Tm(V(5)) & billion

End Select

Te(1) = ekaton

If V(7) + V(8) = 0 Then Te(1) = ekato

Select Case True

Case V(6) + V(7) + V(8) = 0

Case V(6) + V(7) = 0 And V(8) = 1

cpart = mill

Case V(7) = 1

cpart = Te(V(6)) & tt(V(8)) & mills

Case Else

cpart = Te(V(6)) & TAFd(V(7)) & Tm(V(8)) & mills

End Select

If GenderINT = 1 Then Tm = Am: tt = AFt: Te = Ae: Tx = Ax

If GenderINT = 2 Then Tm = Fm: tt = AFt: Te = Fe: Tx = Fx

Te(1) = ekaton

If V(11) + V(10) = 0 Then Fe(1) = ekato

Select Case True

Case V(9) + V(10) + V(11) = 0

Case V(9) + V(10) = 0 And V(11) = 1

bpart = Tx

Case V(10) = 1

bpart = Fe(V(9)) & AFt(V(11)) & xx

Case Else

bpart = Fe(V(9)) & TAFd(V(10)) & Fm(V(11)) & xx

End Select

Te(1) = ekaton

If V(14) + V(13) = 0 Then Te(1) = ekato

If V(13) = 1 Then apart = Te(V(12)) + tt(V(14)) _

Else: apart = Te(V(12)) & TAFd(V(13)) & Tm(V(14))

totalpart = epart & dpart & cpart & bpart & apart

If numberINT = 0 Then totalpart = zero

If oSgn = -1 Then NegativeText = NegativeText & " " Else NegativeText = ""

IntText = NegativeText & totalpart

myEnd:

End Function

Private Function DateText(mydate As Variant) As String

Dim oday As Integer: oday = Day(mydate)

Dim omonth As Integer: omonth = Month(mydate)

Dim oyear As Integer: oyear = Year(mydate)

Dim VMONTH As Variant

VMONTH = VBA.Array("", "Ιανουαρίου", "Φεβρουαρίου", "Μαρτίου", _

"Απριλίου", "Μαΐου", "Ιουνίου", "Ιουλίου", _

"Αυγούστου", "Σεπτεμβρίου", "Οκτωβρίου", _

"Νοεμβρίου", "Δεκεμβρίου")

DateText = IntText(oday, "", 2) & VMONTH(omonth) & ", " & IntText(oyear, "", 3)

End Function

................
................

In order to avoid copyright disputes, this page is only a partial summary.

Google Online Preview   Download