Birden fazla kod eklemek

[irfnal]

Herkese merhabalar, siteye yeni üye oldum. Ben İngilizce çalışmak için kendime excelde bir çalışma dosyası hazırladım. Bu çalışma dosyasında İngilizce sözcüğün yanına Türkçe'sini yazınca yanda doğru yazıyor falan ama tabi bu yeterli olmuyor ses ile de desteklemem lazım. Daha öncesinde 2000 civarında bir kelimenin ses dosyalarını wav uzantısı ile kaydettim. Bu ses dosyalarını kelimenin üzerine tıklayınca çalsın istiyorum. Bunun için de ses dosyalarını çağırma kodu buldum ve excelde bu çalışma kodlarındaki çalınacak sesin isimlerini değiştirdim. Yani 2000 tane kodu hazırladım fakat bu kodlar alt alta word dosyasında duruyor. Hepsini aynı anda module olarak kaydedemiyorum tek tek yaparsam da 2000 tane kelimenin kodu çok uzun sürecek bana bir yol gösterir misiniz? Bir de hücreye tıklayınca sesi çağırmak için bir kod buldum fakat sayfa1'in kod bölümüne kodu yazıyorum mesela A1'e tıklayınca sesi alıyorum fakat ben 2000 tane hücreye tıklayacağım o yüzden alt alta kopyalayıp hücre numarasını değiştirmeyi denedim kabul etmiyor. Yardımlarınızı bekliyorum.
Resimleri ne yazık ki sitenin izin verdiği kadar kaliteli yükleyebildim. Umarım derdimi anlatabilmişimdir.
Ben kodları buraya da yazıyorum daha rahat görebilin diye.

Private Sub Worksheet_SelectionChange(ByVal target As range)

If Intersect(target, [A1]) Is Nothing Then Exit Sub
MsgBox "A1 Hücresini Seçtiniz", vbInformation
'Yapmak istediğiniz işlemler için gerekli kodları bundan sonra yazabilirsiniz
Call ability
End Sub
Bu hücreye tıklamak için kullanmaya çalıştığım.

Bu da ses dosyası için kullanacağım 2000 koddan biri
#If Win64 Then
Private Declare PtrSafe Function PlaySound Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As LongPtr, ByVal dwFlags As Long) As Boolean
#Else
Private Declare Function PlaySound Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As Long, ByVal dwFlags As Long) As Boolean
#End If
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000
Function ability() As String
'Updateby Extendoffice 20161223
Call PlaySound("C:\Users\new\Documents\ses\ability", _
0, SND_ASYNC Or SND_FILENAME)
SoundMe = ""
End Function

Şimdiden herkese çok teşekkür ederim.

 

[muratboz06]

ability kelimesi için ses dosyası ability.wav olarak C:\Users\new\Documents\ses\ klasörü içende mi?
Birde ingilizce kelimeler hangi sütunda yer alıyor? A mı?

 

[irfnal]

eve klasrün içerisinde bütün ses dosyaları 2100 civarı var hepsi için bu şekilde ismi ile ayrı kodu ayarladım ama hepsi word dosyasında hepsini birlikte bir modüle yazamıyorum tek tek wordden kopyalayıp yapıştırmak günler sürer. Kelimeler A sütununda yalış olmasın tam sayı vereyim 2132 tane kelime var

 

[muratboz06]

Modüllerdeki bütün kodları siliniz.
Aşağıdaki kodu kelimelerin bulunduğu sayfanın kod bölümüne kopyalayınız.
A sütununda ingilizce kelime olan herhangi bir hücreye tıklayınız, eğer C:\Users\new\Documents\ses\ klasörü içinde tıkladığınız hücredeki kelimenin adında wav dosyası var ise oynatacaktır.

#If Win64 Then
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" _
        Alias "PlaySoundA" (ByVal lpszName As String, _
        ByVal hModule As LongPtr, ByVal dwFlags As Long) As Boolean
#Else
    Private Declare Function PlaySound Lib "winmm.dll" _
        Alias "PlaySoundA" (ByVal lpszName As String, _
        ByVal hModule As Long, ByVal dwFlags As Long) As Boolean
#End If
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    If Selection.Count = 1 Then
        If Not Intersect(Target, Range("A:A")) Is Nothing Then
        If Target.Value <> "" Then
        Call PlaySound("C:\Users\new\Documents\ses\" & Target.Value & ".wav", _
      0, SND_ASYNC Or SND_FILENAME)
            End If
        End If
    End If
End Sub

 

[irfnal]

Allah razı olsun. Çok teşekkür ederim. Gerçekten harikasınız. Bİr şey daha sorabilir miyim? Acaba bir başka dosyada aynı isimde bulunan resimleri hücreye tıklayınca ekranda açıklama eklemişim gibi gözükebilir mi? Böyle bir şey mümkün mü? Örneğin Car kelimesine tıkladım küçük açıklama ekranında dosyanın içindeki car isimli resim göründü.

 

[irfnal]

Sizi çok meşgul ediyorum biliyorum ama siz kodu göndermeden önce ben sayfa kısmına şu kodu yazmıştım bununla cevabı doğru yazamazsam cevab kontrol ediyordum. sayfa kısmına ikinci kod olarak ekleyebilir miyim? Bir sayfa için sadece tek kod mu yazabiliyoruz?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Intersect(Target, [D12132]) Is Nothing Then Exit Sub

If Target.Count > 1 Then Exit Sub
With Selection.Validation
.Delete
.Add xlValidateInputOnly, xlValidAlertStop, xlBetween
.InputMessage = Sheets("ingilizce").Cells(Target.Row, "B")
End With

End Sub

 

[muratboz06]

C:\Temp\ Klasörü içindeki sesi oynatır, resmi ekler. Ses ve Resim dosyalarının olduğu klasörlere göre değiştirirsiniz. Resimlerin dosya uzantısı .jpg olarak varsayılmıştır. Değiştirebilirsiniz.

#If Win64 Then
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" _
        Alias "PlaySoundA" (ByVal lpszName As String, _
        ByVal hModule As LongPtr, ByVal dwFlags As Long) As Boolean
#Else
    Private Declare Function PlaySound Lib "winmm.dll" _
        Alias "PlaySoundA" (ByVal lpszName As String, _
        ByVal hModule As Long, ByVal dwFlags As Long) As Boolean
#End If
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    ActiveSheet.DrawingObjects.Delete
    Dim Resim As Object

    If Selection.Count = 1 Then
        If Not Intersect(Target, Range("A:A")) Is Nothing Then
        If Target.Value <> "" Then
        Call PlaySound("C:\temp\" & Target.Value & ".wav", _
      0, SND_ASYNC Or SND_FILENAME)
     Set Resim = ActiveSheet.Pictures.Insert("C:\temp\" & Target.Value & ".jpg")
  
     With Range("C" & Target.Row)
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With
    
            End If
        End If
    End If
End Sub

 

[irfnal]

çok teşekkür ederim harikasınız. Peki buna bu kodu da eklemeniz mümkün mü?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Intersect(Target, [D12132]) Is Nothing Then Exit Sub

If Target.Count > 1 Then Exit Sub
With Selection.Validation
.Delete
.Add xlValidateInputOnly, xlValidAlertStop, xlBetween
.InputMessage = Sheets("ingilizce").Cells(Target.Row, "B")
End With

End Sub

 

[muratboz06]

Örnek excel dosyası paylaşırsanız yukarıda bahsettiğinizde yapılır. muratbozlagan06@gmail.com a e-posta atabilirsiniz. Örnek dosyada yapmak istediğinizi gösteriniz.

 

[irfnal]

Yaptığım dosyayı mailinize gönderdim.