MyDesign | Kod Arşivi - Anasayfaya Dön   No banner in farm
Anasayfa Araştır Forum Gelişmiş Arama Siteniz İçin En Hit İçerikler RSS İçerik Ekle Scriptler Destekleyenler Kadromuz Reklam İletişim Giriş Sayfası Yap  Sık Kullanılanlara Ekle
Bu Kategorinin En Yeni Kodları:


Bu Kategorinin En Çok Görüntülenen Kodları:






Arama:
Gelişmiş Arama


No banner in farm



En Çok Görüntülenen Kodlar:


Üye Girişi:
 Üye Ol



Anasayfa > VisualBasic > Kodlar

Rakamı Yazıya Çevirme

Metin kutusuna girilen sayıyı yazıyla yazar

Kategori : VisualBasic
Gönderen : LonG
Telif :
Tarih : 19 Temmuz 2005
Örnek Dosya : İndir
Okunma Sayısı : 37614
Puan
: 8,9 / 10 (29 Oy)
Puan Verin :
Google Bookmarks  del.icio.us  Digg  Yahoo! MyWeb  Windows Live  Furl
 
 
Function Yazıyla$(sayi)
Dim b$(9)
Dim y$(9)
Dim m$(4)
Dim v(15)
Dim c(3)
b$(0) = ""
b$(1) = "Bir"
b$(2) = "İki"
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(sayi)
If Left$(a$, 1) = "-" Then pozitif = 1 Else pozitif = 0
a$ = Right$(a$, Len(a$) - 1)
For x = 1 To Len(a$)
If (Asc(Mid$(a$, x, 1)) > Asc("9")) Or (Asc(Mid$(a$, x, 1)) < Asc("0")) Then GoTo hata
Next x
If Len(a$) > 15 Then GoTo hata
a$ = String(15 - Len(a$), "0") + a$
For x = 1 To 15
v(x) = Val(Mid$(a$, x, 1))
Next x
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 = 1 Then s$ = "Eksi" + s$
Yazıyla$ = s$
GoTo tamam
hata: Yazıyla$ = "Hata"
tamam:
End Function
Private Sub Command1_Click()
Text2.Text = Yazıyla(Text1.Text)
End Sub
 
 

Rakamı Yazıya Çevirme için yazılan yorumlar

Hikmet durmaz  { 19 Nisan 2016 }
Kuruşlar için ek olarak aşağıdaki kodları kullanın
rakam.Text = Format(CDbl(rakam.Text), "########0.00")
yazi.Text = Yazıyla(Val(rakam.Text))
yazi = yazi + "lira"
If Right(rakam.Text, 2) = "00" Then
Exit Sub
End If

Select Case Mid(rakam.Text, Len(rakam.Text) - 1, 1)
Case 0
yazi = yazi + ""
Case 1
yazi = yazi + "on"
Case 2
yazi = yazi + "yirmi"
Case 3
yazi = yazi + "otuz"
Case 4
yazi = yazi + "kırk"
Case 5
yazi = yazi + "elli"
Case 6
yazi = yazi + "altmış"
Case 7
yazi = yazi + "yetmiş"
Case 8
yazi = yazi + "seksen"
Case 9
yazi = yazi + "doksan"
End Select

Select Case Mid(rakam.Text, Len(rakam.Text), 1)
Case 0
yazi = yazi + "kuruş"
Case 1
yazi = yazi + "birkuruş"
Case 2
yazi = yazi + "ikikuruş"
Case 3
yazi = yazi + "üçkuruş"
Case 4
yazi = yazi + "dörtkuruş"
Case 5
yazi = yazi + "beşkuruş"
Case 6
yazi = yazi + "altıkuruş"
Case 7
yazi = yazi + "yedikuruş"
Case 8
yazi = yazi + "sekizkuruş"
Case 9
yazi = yazi + "dokuzkuruş"
End Select

hikmet  { 22 Ocak 2015 }
10089648 busayısı 10 milyon olarak okuyor kodlar hatalı onbin seksendokuztl 648 krs demesı lazım

Cengiz Öz  { 22 Eylül 2013 }
insert module seçip yapıştır kullanırken de =yazıyla(a1) gibi a1 hücresinde ne varsa değeri yazıya çevirir =yazıyla() istediğiniz bir hücreye tanımlamalısınız

Ahmet SARI  { 24 Nisan 2013 }
Function Yazıyla$(sayi)
Dim b$(9)
Dim y$(9)
Dim m$(4)
Dim v(15)
Dim c(3)
b$(0) = ""
b$(1) = "Bir "
b$(2) = "İki "
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(sayi)
If Left$(a$, 1) = "-" Then pozitif = 1 Else pozitif = 0
a$ = Right$(a$, Len(a$) - 1)
For x = 1 To Len(a$)
If (Asc(Mid$(a$, x, 1)) > Asc("9")) Or (Asc(Mid$(a$, x, 1)) < Asc("0")) Then GoTo hata
Next x
If Len(a$) > 15 Then GoTo hata
a$ = String(15 - Len(a$), "0") + a$
For x = 1 To 15
v(x) = Val(Mid$(a$, x, 1))
Next x
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$ = "Bir Bin ") Then e$ = "Bin "
s$ = s$ + e$
Next x
If s$ = "" Then s$ = "Sıfır"
If pozitif = 1 Then s$ = "Eksi" + s$
Yazıyla$ = s$
GoTo tamam
hata: Yazıyla$ = "Hata"
tamam:
End Function
Private Sub Command1_Click()
Dim myStr As String
Dim xPos As Integer
Dim yPos As Integer

myStr = Text1
xPos = InStr(1, myStr, ".") 'nokta ara
yPos = InStr(1, myStr, ",") 'virgul ara

If xPos = 0 Then 'sayi noktali degilse
If yPos = 0 Then 'sayi virgullu degilse
Text2.Text = Yazıyla(Text1.Text)
Else
Text2.Text = Yazıyla(Mid$(myStr, 1, yPos - 1)) & "Lira " & Yazıyla(Mid$(myStr, yPos + 1, Len(myStr))) & "Kuruş"
End If
Else
Text2.Text = Yazıyla(Mid$(myStr, 1, xPos - 1)) & "Lira " & Yazıyla(Mid$(myStr, xPos + 1, Len(myStr))) & "Kuruş"
End If
End Sub
' Bu projenin sahibinden özür dileyerek üzerinde biraz değişiklik yaptım. Noktalı sayıları da çevirilebilir hale getirdim. Ahmet SARI.

kamer  { 23 Haziran 2011 }
arkadaşlar ben yapamadım bunu tam anlatabilirmisiniz
bunu kullanılan bie excel dosyasını bana gönderebilirmisini

samet   { 20 Mayıs 2009 }
allah razı müthiş bir kod command 2de text ekleyince çalışıyor

HAKAN HAYALOĞLU   { 31 Ekim 2008 }
arkadaşım bilgi için teşk ama bir türlü rakamı yazıya çevirmiyor altf11 visual basic ekliyorum ama olmuyor. yardımmmmm!

Yorum ekleyin

Anasayfa > VisualBasic > Kodlar > Rakamı Yazıya Çevirme
Kategoriler:


Forum:



Bağlantılar:


En Son Yorumlanan İçerikler:


Murat Yavuz | Site Haritası | Gizlilik Bildirimi | 54.80.54.2 | 0,11 Saniye
© Copyright 2004-2017 MyDesign | Kod Arşivi. Tüm Hakları Saklıdır.
MyDesign | Kod Arşivi, en iyi görünüm için, 1024x768 ve üzeri çözünürlük tavsiye eder.