Takvim bu güne hatalı gidiyor
Tarih
10/08/2009 20:57
Konu Sahibi
herdogan
Yorumlar
12
Okunma
2965
Konuyu Oyla:
  • Derecelendirme: 0/5 - 0 oy
  • 5
  • 4
  • 3
  • 2
  • 1

Derecelendirme: 0/5 - 0 oy



herdogan
Hesap Aktif Değil
Kullanici Avatari
Aktivasyon Bekleyen
130
21/12/2008
Edirne
Ofis 2003
10/06/2016,21:25
Çözüldü 
Arkaşaların hazırladığı bir çalışmayı kendime uyarlamaya çalışıyorum.
Randevu formundaki takvime bu güne git eklemeye çalıştım. Eklediğim yerler aşağıdaki kodlar içerisinde sonlarda. İlk açılışta doğru çalışıyor. Fakat yıl yada ay değiştirince birden fazla günü işaretliyor. Günü kırmızı yazıl ile göstermesi gerekiyor. Bir den fazla günü kırmızı yapıyor.
Bunun dışında forma eklenecek bir butonlada bu güne gitmesi gerekiyor.

Dim intI As Integer, intJ As Integer, strnum As String
Dim gun1 As String, gun2 As String, bugun1 As String
Me.dolu = ""
For intI = 1 To 42
strnum = Format(intI, "00")
Me("lbl" & strnum).Caption = ""
Me("lbl" & strnum).Visible = True
Me("lbl" & strnum).BackColor = -2147483633
Me("lbl" & strnum).FontSize = 25
Me("lbl" & strnum).FontBold = True
Next intI
Set db = CurrentDb
intMonth = Me!cmbMonth
intYear = Me!cmbYear
intFirst = WeekDay(DateSerial(intYear, intMonth, 1), vbMonday)
intLastDay = Day(DateAdd("m", 1, DateSerial(intYear, intMonth, 1)) - 1)
intLast = intFirst + intLastDay - 1
intJ = 1
strSQL = "SELECT * From Srg WHERE süz=" & cmbMonth & "" & cmbYear
Set rst = db.OpenRecordset(strSQL)

For intI = intFirst To intLast
strnum = Format(intI, "00")

Me("lbl" & strnum).Caption = intJ

intJ = intJ + 1

Next intI
dolusay = 0
Do Until rst.EOF
gun2 = Day(rst![randevu tarihi])
For intI = 1 To 42
strnum = Format(intI, "00")

If Me("lbl" & strnum).Caption = gun2 Then
Me("lbl" & strnum).BackColor = 65280
dolusay = dolusay + 1

End If
Next intI

Me.dolu = "TAKVİMDE" & " " & dolusay & " " & "DOLU GÜN VE" & " " & intLastDay - dolusay & " " & "BOŞ GÜN VAR"

rst.MoveNext

Loop

If dolusay = 0 Then
Me.dolu = "BU AYDA HİÇ KAYIT YOK hepsi boş gözün aydın"
End If

If intLast < 36 Then
intJ = False
Else
intJ = True
End If

For intI = 1 To 42
strnum = Format(intI, "00")
If Me("lbl" & strnum).Caption = "" Then
Me("lbl" & strnum).Visible = False
End If

Next intI
'Burayı ekledim
bugun1 = Day(Me.[bugun])
For intI = 1 To 42
strnum = Format(intI, "00")

If Me("lbl" & strnum).Caption = bugun1 Then
Me("lbl" & strnum).ForeColor = 255

End If
Next intI


Ek Dosyalar
.rar   hastane.rar (Dosya Boyutu: 110,35 KB / İndirme Sayısı: 22)
Cevapla


Bilgisayarcı
Atçalı
Kullanici Avatari
Onursal
657
29/01/2008
410
Antalya
Ofis 2003
01/11/2011,15:17
Çözüldü 
Ben yapılmak isteneni tam anlayamadığım için soruyorum. Bugün 'ün kırmızı renkte mi olmasını istiyorsunuz? Yoksa bir düğme koyayım o direkt olarak takvimde bugünü ( dolayısıyla bu ayı) açsın mı istiyorsunuz?
Bana işe yarayan bir müdür göster,sana dünyayı yerinden oynatayım.
                                                                                        Descartes


Cevapla


herdogan
Hesap Aktif Değil
Kullanici Avatari
Aktivasyon Bekleyen
130
21/12/2008
Edirne
Ofis 2003
10/06/2016,21:25
Çözüldü 
Sayın Bilgisayarcı;
Bu günün kırmızı olmasını istiyorum
Cevapla


Bilgisayarcı
Atçalı
Kullanici Avatari
Onursal
657
29/01/2008
410
Antalya
Ofis 2003
01/11/2011,15:17
Çözüldü 

Kod:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
Private Sub SetDays()
Dim intI As Integer, intJ As Integer, strnum As String
Dim gun1 As String, gun2 As String, bugun1 As String
  Me.dolu = ""
  For intI = 1 To 42
    strnum = Format(intI, "00")
    Me("lbl" & strnum).Caption = ""
    Me("lbl" & strnum).Visible = True
    Me("lbl" & strnum).BackColor = -2147483633
    Me("lbl" & strnum).FontSize = 25
    Me("lbl" & strnum).FontBold = True
  Next intI
  
  intMonth = Me!cmbMonth
  intYear = Me!cmbYear
  intFirst = WeekDay(DateSerial(intYear, intMonth, 1), vbMonday)
  intLastDay = Day(DateAdd("m", 1, DateSerial(intYear, intMonth, 1)) - 1)
  intLast = intFirst + intLastDay - 1
  intJ = 1
  
  strSQL = "SELECT * From Srg WHERE  süz=" & cmbMonth & "" & cmbYear
  Set db = CurrentDb
  Set rst = db.OpenRecordset(strSQL)
  
  For intI = intFirst To intLast
    strnum = Format(intI, "00")
    Me("lbl" & strnum).Caption = intJ
    intJ = intJ + 1
  Next intI
  dolusay = 0
  Do Until rst.EOF
    gun2 = Day(rst![randevu tarihi])
    For intI = 1 To 42
      strnum = Format(intI, "00")
      If Me("lbl" & strnum).Caption = gun2 Then
        Me("lbl" & strnum).BackColor = 65280
        dolusay = dolusay + 1
      End If
    Next intI
    rst.MoveNext
  Loop
  
  For intI = 1 To 42
    strnum = Format(intI, "00")
    Me("lbl" & strnum).Visible = (Me("lbl" & strnum).Caption <> "")
  Next intI
  
  If dolusay = 0 Then
    Me.dolu = "BU AYDA HİÇ KAYIT YOK hepsi boş gözün aydın"
  Else
    Me.dolu = "TAKVİMDE" & " " & dolusay & " " & "DOLU GÜN VE" & " " & intLastDay - dolusay & " " & "BOŞ GÜN VAR"
  End If
' BİLGİSAYARCI'
  'Bugünü işaretlemek için yeter şart önce bu ayda mıyız?
  If (intMonth = Month(Now)) And (intYear = Year(Now)) Then
    'Bu aydayız
    gun1 = Day(Now)
    For intI = 1 To 42
      strnum = Format(intI, "00")
      If Me("lbl" & strnum).Caption = gun1 Then
        Me("lbl" & strnum).BackColor = vbBlue
        Exit For
      End If
    Next intI
  End If

End Sub


Bazı gereksiz işlemleri temizledim. Kodun okunabilirliği için düzenlemeler yaptım. En sonuna da gerekli olan kodu ekledim.

Kod:
1
2
3
4
5
6
7
8
9
10
11
12
13
' BİLGİSAYARCI'
  'Bugünü işaretlemek için yeter şart önce bu ayda mıyız?
  If (intMonth = Month(Now)) And (intYear = Year(Now)) Then
    'Bu aydayız
    gun1 = Day(Now)
    For intI = 1 To 42
      strnum = Format(intI, "00")
      If Me("lbl" & strnum).Caption = gun1 Then
        Me("lbl" & strnum).BackColor = vbBlue
        Exit For
      End If
    Next intI
  End If


Ben vbblue dedim onu vbred yapabilirsin. Kodun bütününe tam bakamadım ama hala gereksiz işlemler var gibi sanki

Bana işe yarayan bir müdür göster,sana dünyayı yerinden oynatayım.
                                                                                        Descartes


Cevapla


assenucler

Kullanici Avatari
Onursal
A.... S.... Ş....
2.052
31/10/2008
63
İstanbul
-
29/11/2016,00:04
Çözüldü 
Sayın bilgisayarcı;

Merhaba..

Hocam dosyayı göremiyorum. Acaba ilk mesaja mı eklediniz?

Teşekkürler..
Cevapla


Bilgisayarcı
Atçalı
Kullanici Avatari
Onursal
657
29/01/2008
410
Antalya
Ofis 2003
01/11/2011,15:17
Çözüldü 
Dosya eklemedim .Kodun kendisini yazdım.
Bana işe yarayan bir müdür göster,sana dünyayı yerinden oynatayım.
                                                                                        Descartes


Cevapla







Konuyu Okuyanlar: 1 Ziyaretçi


Konu ile Alakalı Benzer Konular
Konular Yazar Yorumlar Okunma Tarih Son Yorum
  tablodaki verilerin silinmeden ertesi güne yeni kayıt açılması dayko 10 336 25/08/2016, 11:42 dayko
  Access te Outlook Tarzı Takvim siyahca 14 1.059 08/05/2016, 18:22 siyahca
Çözüldü Hatalı Kayıta Gitme Hk larion 2 340 29/10/2015, 23:00 larion
Çözüldü IIf formülünde hatalı sonuç balkan85 5 643 04/09/2015, 13:40 balkan85
Çözüldü Randevu Günü İçin,O Güne Özel Not Girebilmeyi Nasıl Yaparız? mehami 15 1.222 21/06/2015, 15:16 mehami


Türkçe Çeviri: MCTR, Forum Yazılımı: MyBB, © 2002-2016 MyBB Group.
DMCA.com Protection Status
© Desing by XSTYLED| Develops by ozanakkaya