Paylaşım için teşekkürler maytas.
Visual Basic 6.0'da hazırlanmış Namaz Vakitleri.
(23/09/2009, 02:46)skat yazdı: Teşekkürler .Proje olarak ekleyebilirmisiniz
Yeni HDD aldığım için son bir hafta Windows ve diğer programları bilgisayarıma kurmakla meşguldüm, o yüzden bu isteğe hemen cevap veremedim.
İşte kodlar:
Kod:
Dim Web As Object
Private Sub Combo1_Click()
ListView1.ListItems.Clear
Label4.Caption = ""
Label5.Caption = ""
End Sub
Private Sub Command1_Click()
Dim Litem As ListItem
Dim Satir As Integer, Ay As Integer, Sutun As Integer
On Error GoTo Hata
If Combo1.Text = Empty Then Exit Sub
Command1.Enabled = False
Combo1.Locked = True
If Not Web Is Nothing Then
Set Web = CreateObject("InternetExplorer.application")
Web.Navigate "http://www.diyanet.gov.tr/turkish/namazvakti/vakithes_namazvakti.asp"
Do While Web.Busy: DoEvents: Loop
Do While Web.ReadyState <> 4: DoEvents: Loop
End If
Screen.MousePointer = vbHourglass
Web.Document.getElementById("sehirler").Value = Degistir(Combo1.Text)
Web.Document.getElementById("R1").Value = "AYLIK"
Web.Document.getElementById("Buton").Click
Do While Web.Busy: DoEvents: Loop
Do While Web.ReadyState <> 4: DoEvents: Loop
With ListView1
.ColumnHeaders.Clear
.ListItems.Clear
.HideColumnHeaders = False
.View = lvwReport
.GridLines = True
.ColumnHeaders.Add , , "Tarih", .Width / 6
.ColumnHeaders.Add , , "Haft. Günü", .Width / 6
.ColumnHeaders.Add , , "İmsak", .Width / 9
.ColumnHeaders.Add , , "Güneş", .Width / 9
.ColumnHeaders.Add , , "Öğle", .Width / 9
.ColumnHeaders.Add , , "İkindi", .Width / 9
.ColumnHeaders.Add , , "Akşam", .Width / 9
.ColumnHeaders.Add , , "Yatsı", .Width / 9
' .ColumnHeaders.Add , , "Kıble Saati", .Width * 7 / 45
End With
Do While Web.Busy: DoEvents: Loop
Do While Web.ReadyState <> 4: DoEvents: Loop
For Ay = 1 To 31
Set Litem = ListView1.ListItems.Add
Litem.Text = Trim(Web.Document.All.tags("table").Item(1).Rows(Ay).Cells(0).innertext)
Litem.SubItems(1) = Format(Trim(Web.Document.All.tags("table").Item(1).Rows(Ay).Cells(0).innertext), "dddd")
For Sutun = 1 To 6
Litem.SubItems(Sutun + 1) = Replace(Trim(Web.Document.All.tags("table").Item(1).Rows(Ay).Cells(Sutun).innertext), " ", ":")
Next
If CDate(Trim(Web.Document.All.tags("table").Item(1).Rows(Ay).Cells(0).innertext)) = Date Then
Litem.Bold = True
Litem.ForeColor = &H800000
For Sutun = 1 To 7
ListView1.ListItems(Ay).ListSubItems(Sutun).Bold = True
ListView1.ListItems(Ay).ListSubItems(Sutun).ForeColor = &H800000
Next
End If
Next
Web.Quit
Screen.MousePointer = vbNormal
Command1.Enabled = True
Combo1.Locked = False
Exit Sub
Hata:
On Error Resume Next
Screen.MousePointer = vbNormal
Command1.Enabled = True
Combo1.Locked = False
Web.Quit
End Sub
Private Sub Form_Load()
Screen.MousePointer = vbHourglass
Combo1.AddItem "ADANA"
Combo1.AddItem "ADIYAMAN"
Combo1.AddItem "AFYON"
Combo1.AddItem "AĞRI"
Combo1.AddItem "AKSARAY"
Combo1.AddItem "AMASYA"
Combo1.AddItem "ANKARA"
Combo1.AddItem "ANTALYA"
Combo1.AddItem "ARDAHAN"
Combo1.AddItem "ARTVİN"
Combo1.AddItem "AYDIN"
Combo1.AddItem "BALIKESİR"
Combo1.AddItem "BARTIN"
Combo1.AddItem "BATMAN"
Combo1.AddItem "BAYBURT"
Combo1.AddItem "BİLECİK"
Combo1.AddItem "BİNGÖL"
Combo1.AddItem "BİTLİS"
Combo1.AddItem "BOLU"
Combo1.AddItem "BURDUR"
Combo1.AddItem "BURSA"
Combo1.AddItem "ÇANAKKALE"
Combo1.AddItem "ÇANKIRI"
Combo1.AddItem "ÇORUM"
Combo1.AddItem "DENİZLİ"
Combo1.AddItem "DİYARBAKIR"
Combo1.AddItem "DÜZCE"
Combo1.AddItem "EDİRNE"
Combo1.AddItem "ELAZIĞ"
Combo1.AddItem "ERZİNCAN"
Combo1.AddItem "ERZURUM"
Combo1.AddItem "ESKİŞEHİR"
Combo1.AddItem "GAZİANTEP"
Combo1.AddItem "GİRESUN"
Combo1.AddItem "GÜMÜŞHANE"
Combo1.AddItem "HAKKARİ"
Combo1.AddItem "HATAY"
Combo1.AddItem "IĞDIR"
Combo1.AddItem "ISPARTA"
Combo1.AddItem "İSTANBUL"
Combo1.AddItem "İZMİR"
Combo1.AddItem "KAHRAMANMARAŞ"
Combo1.AddItem "KARABÜK"
Combo1.AddItem "KARAMAN"
Combo1.AddItem "KARS"
Combo1.AddItem "KASTAMONU"
Combo1.AddItem "KAYSERİ"
Combo1.AddItem "KIRIKKALE"
Combo1.AddItem "KIRKLARELİ"
Combo1.AddItem "KIRŞEHİR"
Combo1.AddItem "KİLİS"
Combo1.AddItem "KOCAELİ"
Combo1.AddItem "KONYA"
Combo1.AddItem "KÜTAHYA"
Combo1.AddItem "MALATYA"
Combo1.AddItem "MANİSA"
Combo1.AddItem "MARDİN"
Combo1.AddItem "MERSİN"
Combo1.AddItem "MUĞLA"
Combo1.AddItem "MUŞ"
Combo1.AddItem "NEVŞEHİR"
Combo1.AddItem "NİĞDE"
Combo1.AddItem "ORDU"
Combo1.AddItem "OSMANİYE"
Combo1.AddItem "RİZE"
Combo1.AddItem "SAKARYA"
Combo1.AddItem "SAMSUN"
Combo1.AddItem "SİİRT"
Combo1.AddItem "SİNOP"
Combo1.AddItem "SİVAS"
Combo1.AddItem "Ş.URFA"
Combo1.AddItem "ŞIRNAK"
Combo1.AddItem "TEKİRDAĞ"
Combo1.AddItem "TOKAT"
Combo1.AddItem "TRABZON"
Combo1.AddItem "TUNCELİ"
Combo1.AddItem "UŞAK"
Combo1.AddItem "VAN"
Combo1.AddItem "YALOVA"
Combo1.AddItem "YOZGAT"
Combo1.AddItem "ZONGULDAK"
Combo1.Text = "BURSA"
Set Web = CreateObject("InternetExplorer.application")
Web.Navigate "http://www.diyanet.gov.tr/turkish/namazvakti/vakithes_namazvakti.asp"
Screen.MousePointer = vbNormal
End Sub
Private Sub Timer1_Timer()
Dim Say As Byte, Tarih As Date, Saat As Date, Saat_Seri_No As Double, Vakit As Double, Sahur As Double
On Error Resume Next
If Format(Now, "hh:mm:ss") = "00:00:00" Then Call Command1_Click
Label3.Caption = Format(Now, "dddd dd.mm.yyyy hh:mm:ss")
If ListView1.ListItems.Count > 0 Then
For Say = 1 To ListView1.ListItems.Count
Tarih = ListView1.ListItems(Say)
Saat = Format(Now, "hh:mm:ss")
Saat_Seri_No = CDbl(Tarih) + CDbl(TimeSerial(Hour(Saat), Minute(Saat), Second(Saat)))
If Tarih = Date Then
For Sutun = 2 To 7
Vakit = CDbl(Tarih) + CDbl(CDate(ListView1.ListItems(Say).SubItems(Sutun)))
If Saat_Seri_No < Vakit Then
Label5.Caption = "İmsak'a kalan süre:"
Label4.Caption = Format(Vakit - CDbl(Now), "hh:mm:ss")
For i = 2 To 7
If ListView1.ListItems(Say).ListSubItems(i).ForeColor <> &H800000 Then
ListView1.ListItems(Say).ListSubItems(i).ForeColor = &H800000
ListView1.ListItems(Say).ListSubItems(i).Bold = True
ListView1.Refresh
End If
Next i
GoTo Bitir
Else:
If Sutun = 7 Then
Vakit1 = CDbl(Tarih + 1) + CDbl(CDate(ListView1.ListItems(Say + 1).SubItems(2)))
Else: Vakit1 = CDbl(Tarih) + CDbl(CDate(ListView1.ListItems(Say).SubItems(Sutun + 1)))
End If
If Saat_Seri_No >= Vakit And Saat_Seri_No < Vakit1 Then
If Sutun = 7 Then
Label5.Caption = "İmsak'a kalan süre:"
Label4.Caption = Format(Vakit1 - CDbl(Now), "hh:mm:ss")
Else
Label5.Caption = Ekle(ListView1.ColumnHeaders(Sutun + 2)) & " kalan süre:"
Label4.Caption = Format(Vakit1 - CDbl(Now), "hh:mm:ss")
End If
Satir = 1
Do
Satir = Satir + 1
If Satir < Sutun Then
If ListView1.ListItems(Say).ListSubItems(Satir).ForeColor <> &HFF8080 Then
ListView1.ListItems(Say).ListSubItems(Satir).ForeColor = &HFF8080
ListView1.ListItems(Say).ListSubItems(Satir).Bold = False
ListView1.Refresh
End If
Else:
If Satir = Sutun Then
If ListView1.ListItems(Say).ListSubItems(Sutun).ForeColor <> vbRed Then ListView1.ListItems(Say).ListSubItems(Sutun).ForeColor = vbRed: ListView1.Refresh
Else
If ListView1.ListItems(Say).ListSubItems(Satir).ForeColor <> &H800000 Then
ListView1.ListItems(Say).ListSubItems(Satir).ForeColor = &H800000
ListView1.ListItems(Say).ListSubItems(Satir).Bold = True
ListView1.Refresh
End If
End If
End If
Loop Until Satir = 7
Vakit1 = CDbl(Tarih) + CDbl(CDate(ListView1.ListItems(Say).SubItems(7)))
GoTo Bitir
End If
End If
Next Sutun
End If
Next
End If
Bitir:
If Not (ListView1.SelectedItem Is Nothing) Then ListView1.SelectedItem.Selected = False
End Sub
Private Function Degistir(Kelime As String)
Dim DiziA, DiziB
Dim i As Integer
DiziA = Array("Ğ", "Ü", "Ş", "Ç", "Ö", "İ", "ğ", "ü", "ş", "ç", "ö", "ı")
DiziB = Array("G", "U", "S", "C", "O", "I", "g", "u", "s", "c", "o", "i")
For i = 0 To UBound(DiziA)
If InStr(Kelime, DiziA(i)) > 0 Then
Kelime = Replace(Kelime, DiziA(i), DiziB(i))
End If
Next
Degistir = Kelime
End Function
Private Function Ekle(Kelime As String)
If Kelime = "İmsak" Then
Ekle = "İmsak'a"
ElseIf Kelime = "Güneş" Then
Ekle = "Güneş'e"
ElseIf Kelime = "Öğle" Then
Ekle = "Öğle'ye"
ElseIf Kelime = "İkindi" Then
Ekle = "İkindi'ye"
ElseIf Kelime = "Akşam" Then
Ekle = "Akşam'a"
ElseIf Kelime = "Yatsı" Then
Ekle = "Yatsı'ya"
End If
End Function
Mesajlarımızı Türkçe yazım kurallarına uygun yazalım.
Emeğe saygı gösterelim, bir teşekkürü çok görmeyelim.
Emeğe saygı gösterelim, bir teşekkürü çok görmeyelim.
teşekkürler arkadaş Allah razı olsun
Kolay gelsin
Kolay gelsin
malidolu, 12-09-2009 tarihinden beri AccessTr.neT üyesidir.
tesekkürler
bunu baska ülkenin takvimine yapmak istersek hangi kodu degistirmemiz lazim....
saygilar
bunu baska ülkenin takvimine yapmak istersek hangi kodu degistirmemiz lazim....
saygilar
Yakut, 11-03-2009 tarihinden beri AccessTr.neT üyesidir.
çok güzel yapmışsın bunun kodları sende varsa bana yollarmısın ?(cevab bekliyorum)
Konuyu Okuyanlar: 1 Ziyaretçi
