AccessTr.neT

Sayfalar: 1 2

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

yardımcı olabilirmisiniz?

sn labtek, takıldığınız yeri belirtebilir misiniz?

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

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

Sayfalar: 1 2

labtek

ozanakkaya

ozanakkaya

labtek