AccessTr.neTMicrosoft AccessAccess Cevaplanmış Soruları

animasyonlu tarihde takvimin kendini güncellememesi

1 2
26/10/2009, 23:05

labtek

animasyonlu takvim örneğini çok beğendim ama çalışmama bir türlü ekleyemedim

yardımcı olabilirmisiniz?
26/10/2009, 23:20

ozanakkaya

sn labtek, takıldığınız yeri belirtebilir misiniz?
26/10/2009, 23:45

ozanakkaya

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
Kod:
Private Sub Takvim_Click()
TakvimClick
End Sub

1 adet komut butonu ve 1 adet Tarih adında metin kutusu ekle.
Metin Kutusunun Biçim özelliğine
Kod:
dd.mm.yyyy
yaz

komut butonunun tıklandığında olayına

Kod:
Me.Tarih.SetFocus
Calendar
yaz.

Son 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
27/10/2009, 21:59

labtek

teşekkür ederim açıklayıcı olmuş hemen deniyeceğim
problem yaşarsam sizi rahatsız ederim
1 2