Konu Araçları | Konu Seçenekleri | Gösterim Stili
Tarih
10/08/2009 20:57
Konu Sahibi
herdogan
Yorumlar
12
Okunma
3745
Konuyu Oyla:
  • Derecelendirme: 0/5 - 0 oy
  • 5
  • 4
  • 3
  • 2
  • 1

Derecelendirme: 0/5 - 0 oy
Kullanici Avatari

herdogan

Aktivasyon Bekleyen
 43
 130
 34
 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



Kullanici Avatari

Bilgisayarcı

Aktif Üye
 Belirtilmemiş
 658
 34
 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



Kullanici Avatari

herdogan

Aktivasyon Bekleyen
 43
 130
 34
 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



Kullanici Avatari

Bilgisayarcı

Aktif Üye
 Belirtilmemiş
 658
 34
 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



Kullanici Avatari

assenucler

Aktif Üye*
A..... SE.... ŞE....
 2.057
 125
 31/10/2008
63
 İstanbul
 
 -
 01/12/2018,10:52
Çözüldü 
Sayın bilgisayarcı;

Merhaba..

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

Teşekkürler..



Kullanici Avatari

Bilgisayarcı

Aktif Üye
 Belirtilmemiş
 658
 34
 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




Konuyu Okuyanlar: 1 Ziyaretçi

Konu ile Alakalı Benzer Konular
Konular Yazar Yorumlar Okunma Son Yorum
Çözüldü Whatsapp Link İle Mesaj Gönderirken Tüm Metin Değil İlk Kelime Gidiyor zetyu 2 215 23/09/2018, 15:26
Son Yorum: zetyu
Çözüldü Ajanda Takvim Uygulaması orderyazbim 2 206 28/08/2018, 15:13
Son Yorum: orderyazbim
Çözüldü Hatalı Kayıta Gitme Hk larion 3 779 14/08/2018, 19:30
Son Yorum: ielmacilar
Çözüldü TAKVİM renklendirme ve listeleme 2 Doğan Uludüz 2 556 18/02/2017, 18:24
Son Yorum: Doğan Uludüz
Çözüldü TAKVİM renklendirme ve listeleme Doğan Uludüz 6 730 14/02/2017, 15:49
Son Yorum: Doğan Uludüz

Türkçe Çeviri: MCTR, Yazılım: MyBB, © 2002-2018 MyBB Group.