yeni TL

akd

Destek Ekibi
Destek Ekibi
Katılım
14 Ağustos 2004
Mesajlar
1,105
Excel Vers. ve Dili
2003
Merhaba arkadaşlar
Benim bu yeni TL ye çevirme kodunda içinden çıkamadığım bir sorunum var Kodlarrı aşağıya yazacağım sorunşu
1111 yazıpta ytl ye çavirmek istedigimde
Bir Bin Bir Yüz Onbir Lira sıfır Kuruş
diye yazıyor. lütfen bu yanlışlık nereden geliyor bakarmısınız.
Selamlar... :lol:
Option Explicit

Function yaz(ByVal Tutar)

Dim kg, cent, Temp
Dim DecimalPlace, Count
Dim pozitif, x As Integer
Dim a$, s$, e$
Dim alt_birim As String
Dim döviz As String

Dim b$(9)
Dim y$(9)
Dim m$(4)
Dim v(15)
Dim C(3)

b$(0) = ""
b$(1) = " bir"
b$(2) = " iki"
b$(3) = " üç"
b$(4) = " dört"
b$(5) = " beş"
b$(6) = " altı"
b$(7) = " yedi"
b$(8) = " sekiz"
b$(9) = " dokuz"

y$(0) = " "
y$(1) = " on"
y$(2) = " yirmi"
y$(3) = " otuz"
y$(4) = " kırk"
y$(5) = " elli"
y$(6) = " altmış"
y$(7) = " yetmiş"
y$(8) = " seksen"
y$(9) = " doksan"

m$(0) = " trilyon"
m$(1) = " milyar"
m$(2) = " milyon"
m$(3) = " bin"
m$(4) = " "

a$ = Str(Tutar)
If Left$(Str(Tutar), 1) = " " Then pozitif = 1 Else pozitif = 0
a$ = Right$(a$, Len(a$) - 1)
s$ = ""
For x = 0 To 4
C(1) = v((x * 3) + 1)
C(2) = v((x * 3) + 2)
C(3) = v((x * 3) + 3)
If C(1) = 0 Then
e$ = ""
ElseIf C(1) = 1 Then
e$ = " Yüz"
Else
e$ = b$(C(1)) + " yüz"
End If
e$ = e$ + y$(C(2)) + b$(C(3))
If e$ <> "" Then e$ = e$ + m$(x)
If (x = 3) And (e$ = " birbin") Then e$ = " bin"
s$ = s$ + e$
Next x

If s$ = "" Then s$ = " sıfır"
If pozitif = 0 Then s$ = " Eksi" + s$
ReDim Place(10) As String
Place(2) = " Bin"
Place(3) = " Milyon"
Place(4) = " Milyar"
Place(5) = " Trilyon"

Tutar = Trim(Str(Tutar))

DecimalPlace = InStr(Tutar, ".")

If DecimalPlace > 0 Then
cent = GetHundreds(Left(Mid(Tutar, DecimalPlace + 1) & "00", 2))
Tutar = Trim(Left(Tutar, DecimalPlace - 1))
End If

Count = 1
Do While Tutar <> ""
Temp = GetHundreds(Right(Tutar, 3))
If Temp <> "" Then kg = Temp & Place(Count) & kg
If Len(Tutar) > 3 Then
Tutar = Left(Tutar, Len(Tutar) - 3)
If Left(kg, 6) = " BirBin" Then kg = Mid(kg, 4, Len(kg))
If Left(kg, 6) = " BirYüz" Then kg = Mid(kg, 4, Len(kg))
Else
Tutar = ""
End If
Count = Count + 1
Loop

If Left(kg, 6) = " BirBin" Then kg = Mid(kg, 4, Len(kg))
If Left(kg, 6) = " BirYüz" Then kg = Mid(kg, 4, Len(kg))

Select Case cent
Case ""
cent = " sıfır " & alt_birim
Case " Bir"
cent = " bir " & alt_birim
Case Else
cent = " " & cent & " " & alt_birim
End Select

If Left(cent, 12) = " Bir Yüz " Then cent = " " & Mid(cent, 8, Len(cent))

yaz = kg & " Lira" & cent & " Kuruş"

tamam:
End Function

Function GetHundreds(ByVal Tutar)
Dim Result As String

If Val(Tutar) = 0 Then Exit Function
Tutar = Right("000" & Tutar, 3)


If Mid(Tutar, 1, 1) <> "0" Then
Result = GetDigit(Mid(Tutar, 1, 1)) & " Yüz"
End If


If Mid(Tutar, 2, 1) <> "0" Then
Result = Result & GetTens(Mid(Tutar, 2))
Else
Result = Result & GetDigit(Mid(Tutar, 3))
End If

GetHundreds = Result
End Function

Function GetTens(TensText)
Dim Result As String

Result = ""
If Val(Left(TensText, 1)) = 1 Then
Select Case Val(TensText)
Case 10: Result = " On"
Case 11: Result = " Onbir"
Case 12: Result = " Oniki"
Case 13: Result = " Onüç"
Case 14: Result = " Ondört"
Case 15: Result = " Onbeş"
Case 16: Result = " Onaltı"
Case 17: Result = " Onyedi"
Case 18: Result = " Onsekiz"
Case 19: Result = " Ondokuz"
Case Else
End Select
Else
Select Case Val(Left(TensText, 1))
Case 2: Result = " Yirmi"
Case 3: Result = " Otuz"
Case 4: Result = " Kırk"
Case 5: Result = " Elli"
Case 6: Result = " Altmış"
Case 7: Result = " Yetmiş"
Case 8: Result = " Seksen"
Case 9: Result = " Doksan"
Case Else
End Select
Result = Result & GetDigit _
(Right(TensText, 1))
End If
GetTens = Result
End Function

Function GetDigit(Digit)
Select Case Val(Digit)
Case 1: GetDigit = " Bir"
Case 2: GetDigit = " İki"
Case 3: GetDigit = " Üç"
Case 4: GetDigit = " Dört"
Case 5: GetDigit = " Beş"
Case 6: GetDigit = " Altı"
Case 7: GetDigit = " Yedi"
Case 8: GetDigit = " Sekiz"
Case 9: GetDigit = " Dokuz"
Case Else: GetDigit = " "
End Select
End Function
 

akd

Destek Ekibi
Destek Ekibi
Katılım
14 Ağustos 2004
Mesajlar
1,105
Excel Vers. ve Dili
2003
sayın xxrt merhaba,
malesef o linki inceledim, oradaki kodlar normal çalışmıyor,
yukarıdaki kodda gerekli düzenlemeyi yapabilirseniz çok sevinirim.
saygılar...
 

akd

Destek Ekibi
Destek Ekibi
Katılım
14 Ağustos 2004
Mesajlar
1,105
Excel Vers. ve Dili
2003
Teşekkürler sayın raider...
 
Üst