• DİKKAT

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

Almanca yazdırma

  • Konbuyu başlatan Konbuyu başlatan pcman
  • Başlangıç tarihi Başlangıç tarihi
P

pcman

Katılım
23 Kasım 2007
Mesajlar
245
Excel Vers. ve Dili
2003
Merhaba Arkadaşlar yazıya çeviren kodlarda ufakbir değişiklik yapmam gerekiyor.

Kod: 
Option Compare Database

Function Euro2(sayi)
    x = InStr(1, sayi, ",")
    If x > 0 Then
        Lira = yaz$(Mid(sayi, 1, x - 1)) & " Euro "
        TempKurus = Mid(sayi, x + 1, 98)
        If Len(TempKurus) = 1 Then TempKurus = TempKurus * 10
        If Len(TempKurus) > 2 Then TempKurus = Mid(TempKurus, 1, 2)
        Kurus = yaz$(TempKurus) & "  Cent"
    Else
        Lira = yaz$(sayi) & " Euro "
    End If
    Euro2 = 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) = "EİN"
b$(2) = "ZWEI"
b$(3) = "DREI"
b$(4) = "VIER"
b$(5) = "FÜNF"
b$(6) = "SECHS"
b$(7) = "SIEBEN"
b$(8) = "ACHT"
b$(9) = "NEUN"
y$(0) = ""
y$(1) = "ZEHN"
y$(2) = "ZWANZIG"
y$(3) = "DREIZIG"
y$(4) = "VIERIG"
y$(5) = "FÜNFZIG"
y$(6) = "SECHZIG"
y$(7) = "SIEBZIG"
y$(8) = "ACHTZIG"
y$(9) = "NEUNZIG"
m$(0) = "TRILYON"
m$(1) = "MILYAR"
m$(2) = "MILYON"
m$(3) = "TAUSEND"
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$ = "HUNDERT"
Else
E$ = b$(c(1)) + "HUNDERT"
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$ = "SIFIR"
If pozitif = 0 Then s$ = "" + s$
yaz$ = s$
GoTo tamam
hata: yaz$ = "hata"
tamam:
End Function



Burda dikkatinizi çekmiştir sayıyı almanca yazdırıyorum
ama almancada birler ve onlar basamağının yerdeğiştirmesi gerekiyor türkçedeki gibi değil

türkçe yazıya çevirde

1234 olduğunda binikiyüzotuzdört yzıyor almanca olunca binikiyüzdörtotuz olması gerekiyor

yukardada dediğim gibi sadece onlar ve birler yerdeğiştirecek
 
Merhaba..


Fonksiyonun ilgili yerlerini değiştirirseniz istediğiniz gibi birler, onlardan önce gelir..


Kod: 
Option Compare Database
[COLOR=red].........[/COLOR]
[COLOR=red]............[/COLOR]
[COLOR=red]......[/COLOR]
 
End If
E$ = E$ + [COLOR=red]b[/COLOR]$(c([COLOR=red]3[/COLOR])) + [COLOR=red]y[/COLOR]$(c([COLOR=red]2[/COLOR]))
If E$ <> "" Then E$ = E$ + m$(x)
[COLOR=red].........[/COLOR]
[COLOR=red]............[/COLOR]
[COLOR=red]......[/COLOR]
End Function



EİNTAUSENDZWEIHUNDERTVIERDREIZIG Euro.. ;)
 
Sn Taruz &#199;ok Te&#351;ekk&#252;r ederim Ufak bir ricam daha olucak araya Und Yazmam&#305;z laz&#305;m

1234 = binikiy&#252;z Und D&#246;rtOtuz

&#351;eklinde onlar ve birler yerde&#287;i&#351;tikten sonra birlerin ba&#351;&#305;na Und Gelmesi laz&#305;m
 
Merhaba..

Kod: 
[COLOR=blue]......[/COLOR]
[COLOR=blue]........[/COLOR]
[COLOR=blue]......[/COLOR]
Else
E$ = b$(c(1)) + "HUNDERT [COLOR=red]Und[/COLOR] "
End If
[COLOR=black]E$ = E$ + b$(c(3)) + y$(c(2))[/COLOR]
If E$ <> "" Then E$ = E$ + m$(x)
[COLOR=blue].........[/COLOR]
[COLOR=blue]............[/COLOR]
[COLOR=blue]......[/COLOR]
End Function

İlgili yeri değiştirin..
 
Yüz

galiba Son Değişiklik

Kod: 
Option Compare Database

Function Euro2(sayi)
    x = InStr(1, sayi, ",")
    If x > 0 Then
        Lira = yaz$(Mid(sayi, 1, x - 1)) & " Euro "
        TempKurus = Mid(sayi, x + 1, 98)
        If Len(TempKurus) = 1 Then TempKurus = TempKurus * 10
        If Len(TempKurus) > 2 Then TempKurus = Mid(TempKurus, 1, 2)
        Kurus = yaz$(TempKurus) & "  Cent"
    Else
        Lira = yaz$(sayi) & " Euro "
    End If
    Euro2 = 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) = "EİN"
b$(2) = "ZWEI"
b$(3) = "DREI"
b$(4) = "VIER"
b$(5) = "FÜNF"
b$(6) = "SECHS"
b$(7) = "SIEBEN"
b$(8) = "ACHT"
b$(9) = "NEUN"
y$(0) = ""
y$(1) = "UNDZEHN"
y$(2) = "UNDZWANZIG"
y$(3) = "UNDDREIZIG"
y$(4) = "UNDVIERZIG"
y$(5) = "UNDFÜNFZIG"
y$(6) = "UNDSECHZIG"
y$(7) = "UNDSIEBZIG"
y$(8) = "UNDACHTZIG"
y$(9) = "UNDNEUNZIG"
m$(0) = "TRILYON"
m$(1) = "MILYAR"
m$(2) = "MILYON"
m$(3) = "TAUSEND"
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$ = "HUNDERT"
Else
E$ = b$(c(1)) + "HUNDERT"
End If
E$ = E$ + b$(c(3)) + y$(c(2))
If E$ <> "" Then E$ = E$ + m$(x)
[COLOR="Red"]If E$ = "HUNDERT" Then E$ = "EİNHUNDERT"[/COLOR]
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

Burda Taruz Arkadaşımın Yardımıyla Und Bağlacını yerleştirdim ama bu almanlar çok ters adamlar..

1123 olduğunda binyüzyirmiüç diyoruz almanlarda Birbinbiryüz yani sadece yüz olduğunda başına bir geliyor ikiyüz olduğunda sistem başına iki koyuyor...
şu anki kodlar birbin diyor ama biryüz demiyor sadece yüz olduğunda yüz yazıyor

If E$ = "HUNDERT" Then E$ = "EİNHUNDERT" ben bunu yaptım ama olmadı
 
Son düzenleme:
Almanca Yazıya çevirme

Kod: 
Option Compare Database

Function Euro2(sayi)
    x = InStr(1, sayi, ",")
    If x > 0 Then
        Lira = yaz$(Mid(sayi, 1, x - 1)) & " Euro "
        TempKurus = Mid(sayi, x + 1, 98)
        If Len(TempKurus) = 1 Then TempKurus = TempKurus * 10
        If Len(TempKurus) > 2 Then TempKurus = Mid(TempKurus, 1, 2)
        Kurus = yaz$(TempKurus) & "  Cent"
    Else
        Lira = yaz$(sayi) & " Euro "
    End If
    Euro2 = 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) = "EİN"
b$(2) = "ZWEI"
b$(3) = "DREI"
b$(4) = "VIER"
b$(5) = "FÜNF"
b$(6) = "SECHS"
b$(7) = "SIEBEN"
b$(8) = "ACHT"
b$(9) = "NEUN"
y$(0) = ""
y$(1) = "UNDZEHN"
y$(2) = "UNDZWANZIG"
y$(3) = "UNDDREIZIG"
y$(4) = "UNDVIERZIG"
y$(5) = "UNDFÜNFZIG"
y$(6) = "UNDSECHZIG"
y$(7) = "UNDSIEBZIG"
y$(8) = "UNDACHTZIG"
y$(9) = "UNDNEUNZIG"
m$(0) = "TRILYON"
m$(1) = "MILYAR"
m$(2) = "MILYON"
m$(3) = "TAUSEND"
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$ = "EİNHUNDERT"
Else
E$ = b$(c(1)) + "HUNDERT"
End If
E$ = E$ + b$(c(3)) + y$(c(2))
If E$ <> "" Then E$ = E$ + m$(x)
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

Taruz Arkadaşıma Teşekkür Ederim
 
bu kullanım doğru mu? merak ettim de
40 için UNDVIERZIG Euro yazıyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst