DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Private strTrkKelime As String
Private iCvpKont As Integer
Private Sub cmdCevap1_Click()
Call cevapKontrol(1)
End Sub
Private Sub cmdCevap2_Click()
Call cevapKontrol(2)
End Sub
Private Sub cmdCevap3_Click()
Call cevapKontrol(3)
End Sub
Private Sub cmdCevap4_Click()
Call cevapKontrol(4)
End Sub
Private Sub cmdCevap5_Click()
Call cevapKontrol(5)
End Sub
Private Sub cevapKontrol(i)
If Controls("cmdCevap" & i).Caption = strTrkKelime Then
MsgBox "Tebrikler, Doğru Cevap"
Call ingilizce_Türkçe
Else
MsgBox "Üzgünüm, Yanlış Cevap < " & 2 - iCvpKont & " > Tahmin Hakkınız kaldı"
iCvpKont = iCvpKont + 1
If iCvpKont = 3 Then Call ingilizce_Türkçe
End If
End Sub
Private Sub UserForm_Initialize()
Call ingilizce_Türkçe
End Sub
Private Sub ingilizce_Türkçe()
Dim Csf As Excel.Worksheet: Set Csf = Worksheets("Sozluk")
Dim dataEngKelime As Variant, dataTrkKelimeler As Variant, dataButonNo As Variant
Dim Sonsat As Long, lngSmdEngInd As Long, lngOncEngInd As Long
Dim i As Integer
'\\ Kontrolleri Sıfırlıyoruz
iCvpKont = 0
lblSoru.Caption = ""
lblOkunus.Caption = ""
For i = 1 To 5
Controls("cmdCevap" & i).Caption = ""
Next i
'\\ Havuzdan değerleri alıyoruz.
With Csf
Sonsat = .Cells(65536, 1).End(3).Row
dataEngKelime = BenzersizRastgeleSayilar(1, 2, Sonsat, enCevapHayır)
lngSmdEngInd = dataEngKelime(1)
strTrkKelime = .Cells(lngSmdEngInd, 2).Value
lblSoru.Caption = .Cells(lngSmdEngInd, 1).Value
lblOkunus.Caption = .Cells(lngSmdEngInd, 3).Value
CevaplarıHazırla:
dataTrkKelimeler = BenzersizRastgeleSayilar(4, 1, Sonsat, enCevapHayır)
For i = LBound(dataTrkKelimeler) To UBound(dataTrkKelimeler)
If dataTrkKelimeler(i) = lngSmdEngInd Then GoTo CevaplarıHazırla
If dataTrkKelimeler(i) = lngOncEngInd Then GoTo CevaplarıHazırla
Next i
CevaplarıYaz:
dataButonNo = BenzersizRastgeleSayilar(4, 1, 5, enCevapHayır)
For i = LBound(dataButonNo) To UBound(dataButonNo)
Controls("cmdCevap" & dataButonNo(i)).Caption = .Cells(dataTrkKelimeler(i), 2).Value
Next i
For i = 1 To 5
If Controls("cmdCevap" & i).Caption = "" Then Controls("cmdCevap" & i).Caption = strTrkKelime
Next i
End With
lngOncEngInd = lngSmdEngInd
End SubPublic Enum enCevap
enCevapevet
enCevapHayır
End Enum
Function BenzersizRastgeleSayilar(KacAdetSayi As Long, EnKucukSayi As Long, EnBuyukSayi As Long, Optional Sıralımı As enCevap) As Variant
'Benzersiz Rastgele Sayılar Üretir.
'Kullanımı Aşağıdaki gibidir
'Data = UniqueRandomNumbers(6, 1, 49)
Dim RandColl As Collection, varTemp() As Long
Dim k&, i&, j&
BenzersizRastgeleSayilar = False
If KacAdetSayi < 1 Then Exit Function
If EnKucukSayi > EnBuyukSayi Then Exit Function
If KacAdetSayi > (EnBuyukSayi - EnKucukSayi + 1) Then Exit Function
Set RandColl = New Collection
Randomize
Do
On Error Resume Next
i = CLng(Rnd * (EnBuyukSayi - EnKucukSayi) + EnKucukSayi)
RandColl.Add i, CStr(i)
On Error GoTo 0
Loop Until RandColl.Count = KacAdetSayi
ReDim varTemp(1 To KacAdetSayi)
For i = 1 To KacAdetSayi
varTemp(i) = RandColl(i)
Next i
Set RandColl = Nothing
If Sıralımı = enCevapevet Then
'**************ripek********************
For i = 1 To KacAdetSayi - 1
For j = i + 1 To KacAdetSayi
If varTemp(i) > varTemp(j) Then
k = varTemp(i)
varTemp(i) = varTemp(j)
varTemp(j) = k
End If
Next j
Next i
'**************ripek********************
End If
BenzersizRastgeleSayilar = varTemp
Erase varTemp
k = 0: i = 0: j = 0
'*****www.excel.web.Tr***********
End Function
Private Sub cevapKontrol(i)
If Controls("cmdCevap" & i).Caption = strTrkKelime Then
MsgBox "Tebrikler, Doğru Cevap"
Call ingilizce_Türkçe
Else
MsgBox "Üzgünüm, Yanlış Cevap < " & 2 - iCvpKont & " > Tahmin Hakkınız kaldı"
iCvpKont = iCvpKont + 1
If iCvpKont = 3 Then
MsgBox "Doğru Cevap:" & vbNewLine & vbNewLine & strTrkKelime & vbNewLine & vbNewLine & "Olacaktı.", vbInformation, "HSAYAR"
Call ingilizce_Türkçe
End If
End If
txtSoru.SetFocus
End Sub
k::SAYIN USTA sizin örneğinizi inceleme fırsatım oldu diğerlerine bakamadım
