animasyonlu takvim örneğini çok beğendim ama çalışmama bir türlü ekleyemedim
yardımcı olabilirmisiniz?
#7
labtek, 24-07-2009 tarihinden beri AccessTr.neT üyesidir.
animasyonlu tarihde takvimin kendini güncellememesi
#7
#8
sn labtek, takıldığınız yeri belirtebilir misiniz?
#9
Menü Çubuğu/Ekle/Activex Denetiminden Takvim Denetimi ekle. Takvim Denetiminin Adını , "Takvim" olarak değiştir.
Kod Penceresini aç ve aşağıdaki kodu ekle
1 adet komut butonu ve 1 adet Tarih adında metin kutusu ekle.
Metin Kutusunun Biçim özelliğine
yaz
komut butonunun tıklandığında olayına
yaz.
Son olarak Aşağıda kodları yeni modül olarak ekle
Kod Penceresini aç ve aşağıdaki kodu ekle
Kod:
Private Sub Takvim_Click()
TakvimClick
End SubMetin Kutusunun Biçim özelliğine
Kod:
dd.mm.yyyykomut butonunun tıklandığında olayına
Kod:
Me.Tarih.SetFocus
CalendarSon olarak Aşağıda kodları yeni modül olarak ekle
Kod:
Option Compare Database
Option Explicit
Public Const twips As Long = 1440
Dim mm_actctl As Control
Public Function Calendar()
Dim sngStart As Single, CalCtrl As Control
Dim ctl As Control, FRM As Form
Dim m_left As Long, m_top As Long, t_height As Long
Dim w As Long, h As Long, Y As Double
Dim caltop As Long, calheight As Long, secHeight As Long
Dim frmWidth As Long, t_width As Long, I As Double
On Error GoTo Calendar_Err
Dim fldstatus As Boolean
fldstatus = False 'initialize
fldstatus = Check4Date()
If fldstatus = False Then
MsgBox "Sorry, Not a Date Type Control"
Exit Function
End If
Set ctl = Screen.ActiveControl
Set mm_actctl = ctl
Set CalCtrl = Screen.ActiveForm.Controls("Takvim")
Set FRM = Screen.ActiveForm
CalCtrl.Width = 0.1458 * twips ' 0.1458"
CalCtrl.Height = 0.1563 * twips ' 0.1563"
m_left = ctl.Left + ctl.Width
m_top = ctl.Top + ctl.Height
caltop = m_top
calheight = ctl.Height + (15 * twips * 0.106) '0.106"
secHeight = FRM.Section(acDetail).Height
frmWidth = FRM.Width
t_height = caltop + calheight
t_width = m_left + (15 * twips * 0.17) '0.17"
If t_height > secHeight Then
m_top = secHeight - (calheight + (0.106 * twips)) ' 0.106"
End If
If t_width > frmWidth Then
m_left = frmWidth - (15 * twips * 0.17) ' 0.17"
End If
CalCtrl.Left = m_left
CalCtrl.Top = m_top
CalCtrl.Visible = True
sngStart = Timer
I = 0.05: Y = I
Do While Timer < (sngStart + 0.75)
If Timer >= sngStart + Y Then
Y = Y + I
w = CalCtrl.Width + (0.17 * twips) ' 0.17"
CalCtrl.Width = w
h = CalCtrl.Height + (0.106 * twips) ' 0.106"
CalCtrl.Height = h
DoEvents
End If
Loop
Calendar_Exit:
Exit Function
Calendar_Err:
MsgBox Err.Description, , "Calendar"
Resume Calendar_Exit
End Function
Public Function TakvimClick()
Dim m_cal As Control, m_ctl As Control
On Error GoTo TakvimClick_Err
Set m_cal = Screen.ActiveForm.Controls("Takvim")
mm_actctl.Value = m_cal.Value
m_cal.Width = 0.1458 * twips ' 0.1458"
m_cal.Height = 0.1563 * twips ' 0.1563"
mm_actctl.SetFocus
DoEvents
m_cal.Visible = False
TakvimClick_Exit:
Exit Function
TakvimClick_Err:
MsgBox Err.Description, , "TakvimClick"
Resume TakvimClick_Exit
End Function
Public Function Check4Date() As Boolean
Dim ctl As Control, FRM As Form
Dim RecSource As String, ctlSource As String
Dim dtFormat As String, ctlType As Integer, fldType As Integer
Dim ctlName As String, statuscode As Integer, fldformat As String
Dim tblDef As TableDef, qryDef As QueryDef, cdb As Database
Dim tblDefFlag As Boolean
On Error GoTo Check4Date_Err
dtFormat = "dd/mm/yyyy"
Set FRM = Screen.ActiveForm
Set ctl = Screen.ActiveControl
ctlType = ctl.ControlType
If ctlType <> 109 Then
Check4Date = False
Exit Function
End If
ctlSource = ctl.ControlSource
If Len(ctlSource) = 0 Then
statuscode = 1
Else
statuscode = 2
End If
fldformat = ctl.Format
If fldformat = dtFormat Then
Check4Date = True
Exit Function
End If
If statuscode = 2 Then
RecSource = FRM.RecordSource
ctlName = ctl.Name
Set cdb = CurrentDb
tblDefFlag = False
For Each tblDef In cdb.TableDefs
If tblDef.Name = RecSource Then
tblDefFlag = True
Exit For
End If
Next
If tblDefFlag Then
Set tblDef = cdb.TableDefs(RecSource)
fldType = tblDef.Fields(ctlName).Type
If fldType = 8 Then
Check4Date = True
Exit Function
End If
End If
If tblDefFlag = False Then
Set qryDef = cdb.QueryDefs(RecSource)
fldType = qryDef.Fields(ctlName).Type
If fldType = 8 Then
Check4Date = True
Exit Function
End If
End If
End If
Check4Date_Exit:
Exit Function
Check4Date_Err:
MsgBox Err.Description, , "Check4Date_Err"
Resume Check4Date_Exit
End Function
#10
teşekkür ederim açıklayıcı olmuş hemen deniyeceğim
problem yaşarsam sizi rahatsız ederim
problem yaşarsam sizi rahatsız ederim
labtek, 24-07-2009 tarihinden beri AccessTr.neT üyesidir.
Konuyu Okuyanlar: 1 Ziyaretçi
