• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Word'de rakamı yazıya çevirme

P

penguen6363

Katılım
21 Kasım 2008
Mesajlar
113
Excel Vers. ve Dili
EXCEL2000
Selam Arkadaşlar
Forumda arama yaptım ama bulamadım wordde rakkamı yazıya çevirebiliyormuyuz.
Teşekkürler.
 
merhaba
syn Haluk'un böyle bir çalışması sitede olacak.
word sorularında arama yapınız.
 
Malesef Sayın Uzman Amele
Konuyla ilgili bir soru ve cevap var ama 2007 yılı lduğu için dosyayı açmıyor :frown:
 
merhaba
syn Haluk'un Word içinde sayıyı yazıya çevirme kodlarını ytl den tl ye uyarlamaya çalıştım.

boş bir word belgesi açın,
visual basic düzenleyicisinde Normal / Microsoft Word Objects / Thisdocument içersine aşağıdaki kodları yazın.
sayıyı seçip sağ tuş ile TL yaz... (Raider ®) tıklayın

Kod: 
Dim MyBar As CommandBar
Dim MyBar2 As CommandBar
Dim MyBar3 As CommandBar
'
Sub AutoExec()
Call PopUpMenu
End Sub
'
Sub PopUpMenu()
Set MyBar = Application.CommandBars("Text")
Set MyBar2 = Application.CommandBars("Fields")
Set MyBar3 = Application.CommandBars("Table Text")
'
On Error Resume Next
MyBar.FindControl(Tag:="TagTL").Delete
MyBar2.FindControl(Tag:="TagTL").Delete
MyBar3.FindControl(Tag:="TagTL").Delete
On Error GoTo 0
'
Set MenuObject = MyBar.Controls.Add(Type:=msoControlButton, Temporary:=True)
MenuObject.Tag = "TagTL"
MenuObject.Caption = "TL yaz... (Raider ®)"
MenuObject.BeginGroup = True
MenuObject.OnAction = "YazTL"
MenuObject.FaceId = 7
'
Set MenuObject = MyBar2.Controls.Add(Type:=msoControlButton, Temporary:=True)
MenuObject.Tag = "TagTL"
MenuObject.Caption = "TL yaz... (Raider ®)"
MenuObject.BeginGroup = True
MenuObject.OnAction = "YazTL"
MenuObject.FaceId = 7
'
Set MenuObject = MyBar3.Controls.Add(Type:=msoControlButton, Temporary:=True)
MenuObject.Tag = "TagTL"
MenuObject.Caption = "TL yaz... (Raider ®)"
MenuObject.BeginGroup = True
MenuObject.OnAction = "YazTL"
MenuObject.FaceId = 7
'
Set MyBar = Nothing
Set MyBar2 = Nothing
Set MyBar3 = Nothing
Set MenuObject = Nothing
End Sub
'
Function TL(sayi)
sayi = Round(sayi, 2)
X = InStr(1, sayi, ",")
If X > 0 Then
Lira = yaz$(Mid(sayi, 1, X - 1)) & " TÜRK LİRASI "
TempKurus = Mid(sayi, X + 1, 98)
If Len(TempKurus) = 1 Then TempKurus = TempKurus * 10
Kurus = yaz$(TempKurus) & " KURUŞ "
Else
Lira = yaz$(sayi) & " TÜRK LİRASI "
End If
TL = Lira & Kurus
End Function
'
Function yaz$(sayi)
Dim b$(9)
Dim y$(9)
Dim m$(4)
Dim v$(15)
Dim c$(3)
b$(0) = ""
b$(1) = "BİR"
b$(2) = "İKİ"
b$(3) = "ÜÇ"
b$(4) = "DÖRT"
b$(5) = "BEŞ"
b$(6) = "ALTI"
b$(7) = "YEDİ"
b$(8) = "SEKİZ"
b$(9) = "DOKUZ"
y$(0) = ""
y$(1) = "ON"
y$(2) = "YİRMİ"
y$(3) = "OTUZ"
y$(4) = "KIRK"
y$(5) = "ELLİ"
y$(6) = "ALTMIŞ"
y$(7) = "YETMİŞ"
y$(8) = "SEKSEN"
y$(9) = "DOKSAN"
m$(0) = "TRILYON"
m$(1) = "MİLYAR"
m$(2) = "MİLYON"
m$(3) = "BİN"
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
a$ = ""
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$ = "BİRBİN") Then e$ = "BİN"
s$ = s$ + e$
Next X
If s$ = "" Then s$ = "SIFIR"
If pozitif = 0 Then s$ = "" + s$
yaz$ = s$
GoTo tamam
hata: yaz$ = "hata"
tamam:
End Function
'
Sub YazTL()
If IsNumeric(Selection) Then
Selection = Selection & TL(Selection)
End If
End Sub
'
Sub AutoExit()
Application.CommandBars("Text").Reset
Application.CommandBars("Fields").Reset
Application.CommandBars("Table Text").Reset
End Sub
 
Bende dosyayı ekleyeyim.
 

Ekli dosyalar

Teşekkür

Sayın Uzmanamele ve Ali

İlginiz ve katkılarınız için çok teşekkürler
 
Ben çalıştırdım süper oldu da...
Benim başka bir düşüncem var.

Excel de olduğu gibi başka bir metin kısmına bunu otomatik yazabilirmi...

Faturalarda yazılan rakamların başka bir kolonda tl sini yazmak gibi...
 
Ben sağ tıklıyorum ama ytl yaz diye bir menü çıkmıyor.
 
uzmanamele' Alıntı:
merhaba
syn Haluk'un Word içinde sayıyı yazıya çevirme kodlarını ytl den tl ye uyarlamaya çalıştım.

boş bir word belgesi açın,
visual basic düzenleyicisinde Normal / Microsoft Word Objects / Thisdocument içersine aşağıdaki kodları yazın.
sayıyı seçip sağ tuş ile TL yaz... (Raider ®) tıklayın

Kod: 
Dim MyBar As CommandBar
Dim MyBar2 As CommandBar
Dim MyBar3 As CommandBar
'
Sub AutoExec()
Call PopUpMenu
End Sub
'
Sub PopUpMenu()
Set MyBar = Application.CommandBars("Text")
Set MyBar2 = Application.CommandBars("Fields")
Set MyBar3 = Application.CommandBars("Table Text")
'
On Error Resume Next
MyBar.FindControl(Tag:="TagTL").Delete
MyBar2.FindControl(Tag:="TagTL").Delete
MyBar3.FindControl(Tag:="TagTL").Delete
On Error GoTo 0
'
Set MenuObject = MyBar.Controls.Add(Type:=msoControlButton, Temporary:=True)
MenuObject.Tag = "TagTL"
MenuObject.Caption = "TL yaz... (Raider ®)"
MenuObject.BeginGroup = True
MenuObject.OnAction = "YazTL"
MenuObject.FaceId = 7
'
Set MenuObject = MyBar2.Controls.Add(Type:=msoControlButton, Temporary:=True)
MenuObject.Tag = "TagTL"
MenuObject.Caption = "TL yaz... (Raider ®)"
MenuObject.BeginGroup = True
MenuObject.OnAction = "YazTL"
MenuObject.FaceId = 7
'
Set MenuObject = MyBar3.Controls.Add(Type:=msoControlButton, Temporary:=True)
MenuObject.Tag = "TagTL"
MenuObject.Caption = "TL yaz... (Raider ®)"
MenuObject.BeginGroup = True
MenuObject.OnAction = "YazTL"
MenuObject.FaceId = 7
'
Set MyBar = Nothing
Set MyBar2 = Nothing
Set MyBar3 = Nothing
Set MenuObject = Nothing
End Sub
'
Function TL(sayi)
sayi = Round(sayi, 2)
X = InStr(1, sayi, ",")
If X > 0 Then
Lira = yaz$(Mid(sayi, 1, X - 1)) & " TÜRK LİRASI "
TempKurus = Mid(sayi, X + 1, 98)
If Len(TempKurus) = 1 Then TempKurus = TempKurus * 10
Kurus = yaz$(TempKurus) & " KURUŞ "
Else
Lira = yaz$(sayi) & " TÜRK LİRASI "
End If
TL = Lira & Kurus
End Function
'
Function yaz$(sayi)
Dim b$(9)
Dim y$(9)
Dim m$(4)
Dim v$(15)
Dim c$(3)
b$(0) = ""
b$(1) = "BİR"
b$(2) = "İKİ"
b$(3) = "ÜÇ"
b$(4) = "DÖRT"
b$(5) = "BEŞ"
b$(6) = "ALTI"
b$(7) = "YEDİ"
b$(8) = "SEKİZ"
b$(9) = "DOKUZ"
y$(0) = ""
y$(1) = "ON"
y$(2) = "YİRMİ"
y$(3) = "OTUZ"
y$(4) = "KIRK"
y$(5) = "ELLİ"
y$(6) = "ALTMIŞ"
y$(7) = "YETMİŞ"
y$(8) = "SEKSEN"
y$(9) = "DOKSAN"
m$(0) = "TRILYON"
m$(1) = "MİLYAR"
m$(2) = "MİLYON"
m$(3) = "BİN"
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
a$ = ""
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$ = "BİRBİN") Then e$ = "BİN"
s$ = s$ + e$
Next X
If s$ = "" Then s$ = "SIFIR"
If pozitif = 0 Then s$ = "" + s$
yaz$ = s$
GoTo tamam
hata: yaz$ = "hata"
tamam:
End Function
'
Sub YazTL()
If IsNumeric(Selection) Then
Selection = Selection & TL(Selection)
End If
End Sub
'
Sub AutoExit()
Application.CommandBars("Text").Reset
Application.CommandBars("Fields").Reset
Application.CommandBars("Table Text").Reset
End Sub
Genişletmek için tıkla ...

Sayın hocam ağolun çok işime yarayacak yalnız bir sorunum var yazıya çevirme işini bir alt satırda değilde rakamın olduğu satırda yapması için ne yapmam gerekir.yardımcı olursanız sevinirim.
 
Son düzenleme:
word de bu makroyu çalıştıracak bir buton oluşturmak istiyorum. buton oluşturuyorum ama o makroyu nasıl atayacağımı bilmiyorum. yardımlarınız için şimdiden teşekkürler
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst