sesli okutma

Katılım
18 Aralık 2005
Mesajlar
464
Excel Vers. ve Dili
ofis2003
arkadaşlar forumdan adını hatırlayamadığım bir arkadaşımızın yapmış olduğu sesli sayı okuma çalışması elimde var.buna sayıların okumasını bitirdikten sonra ses dosyasını eklediğim "numaralı kaydınız kaydedilmiştir" adlı dosyamıda söylemesini istiyorum ancak bunu kendim başaramadım yardımlarınızı bekliyorum.fazla olan kısımlarıda çıkartırmısınız.teşekkürler
 

dEdE

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
Mrb.,
Mevcut kodu aşaığdaki şekilde değiştirdim. Sanırım sizin istediğiniz buydu.
Kod:
Function seslioku(sy)
On Error Resume Next
sesx$ = ThisWorkbook.Path & "\" & "numaralı cihazın kaydı yapılmıştır.wav" '--Eklenen kod----
dz1 = Array(" ", "bir", "iki", "üç", "dört", "beş", "altı", "yedi", "sekiz", "dokuz")
dz2 = Array(" ", "on", "yirmi", "otuz", "kırk", "elli", "altmış", "yetmiş", "seksen", "doksan")
dz3 = Array(" ", "", "bin", "milyon", "milyar", "trilyon", "katrilyon")
tur = Len(sy) \ 3
kalan = Len(sy) Mod 3
k = 2
sayı = ""
For i = 1 To tur
sya = Mid(sy, (Len(sy) - k), 3)
sy1 = dz1(Mid(sya, 3, 1)): sy2 = dz2(Mid(sya, 2, 1)): sy3 = dz1(Mid(sya, 1, 1))
Select Case Mid(sya, 1, 1)
Case 1
sy3 = "yüz"
Case Is > 1
sy3 = sy3 & " " & "yüz"
End Select
If i = 2 Then
Select Case Val(sya)
Case 0
sy1 = ""
Case 1
sy1 = "bin"
Case Is > 1
sy1 = sy1 & " " & "bin"
End Select
Else
birim = dz3(i)
End If
If Val(sya) > 0 Then
sayı = sy3 & " " & Trim(sy2) & " " & sy1 & " " & birim & " " & Trim(sayı)
k = k + 3
Else
k = k + 3
End If
Next i
If kalan = 0 Then
f = sayı
p = InStr(1, LTrim(f), " ")
Do While p > 0
s = Trim(Mid(f, 1, p))
f = LTrim(Mid(f, p, Len(f)))
p = InStr(1, f, " ")
ses$ = ThisWorkbook.Path & "\" & s & ".wav"
Call PlaySound(ses$, 1, 0)
Loop
If f <> "" Then
s = f
ses$ = ThisWorkbook.Path & "\" & s & ".wav"
Call PlaySound(ses$, 1, 0)
End If
Call PlaySound(sesx$, 1, 0) '-------Eklenen kod------
Exit Function
Else
End If
syb = Mid(sy, 1, kalan)
sy11 = dz1(Mid(syb, kalan, 1)): sy22 = dz2(Mid(sy, kalan - 1, 1))
If tur = 1 Then
Select Case Val(Mid(syb, 1, 2))
Case 0
sy11 = ""
Case 1
sy11 = "bin"
Case Is > 1
sy11 = sy11 & " " & "bin"
End Select
Else
birim1 = dz3(tur + 1)
End If
sayı = sy22 & " " & sy11 & " " & birim1 & " " & sayı
f = LTrim(sayı)
p = InStr(1, f, " ")
Do While p > 0
s = Trim(Mid(f, 1, p))
f = LTrim(Mid(f, p, Len(f)))
p = InStr(1, f, " ")
ses$ = ThisWorkbook.Path & "\" & s & ".wav"
Call PlaySound(ses$, 1, 0)
Loop
If f <> "" Then
s = f
ses$ = ThisWorkbook.Path & "\" & s & ".wav"
Call PlaySound(ses$, 1, 0)
End If
Call PlaySound(sesx$, 1, 0) '-------Eklenen kod------
End Function
Saygılar.
 
Katılım
18 Aralık 2005
Mesajlar
464
Excel Vers. ve Dili
ofis2003
syn dEdE ilgini için teşekkürler. söylemiş olduğunuz eklentileri yaptım ancak sayıyı okuyor fakat cihaz kaydı yappılmıştırı çalmıyor.acaba hatam nerede olabilir..
 

dEdE

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
Mrb.,
Kodu tekrar değiştirdim. Akşam aceleyle hata yapmışım. Yukarıdaki kodu aynen kullanırsanız sorununuz çözülecektir. Eğer hala çalışmıyorsa "numaralı cih..." isimli sese dosyasının adında veye dosya yolunda bir sorun var demektir.
Gerçi tüm olasılıkları denemedim ama yaptığım denemelerde hata vermeden çalıştı.
Saygılar.
 
Katılım
18 Aralık 2005
Mesajlar
464
Excel Vers. ve Dili
ofis2003
syn dEdEyardımınız ve emeğiniz için çok teşekkür ederim.çpk güzel olmuş :mutlu: .sizden mümkünse birşey daha istiye bilirmiyim eğer mümkünse bu kodların çalışma mantığını açıklayabilirmisiniz. başka denemelerimde bana veri tabanı olması maksatlı olarak açıklama veya küçük bir örnek eklermisiniz.bu kodlardan anladım desem pek yalan olmaz.....
 
Üst