[Murat OSMA]

DTPicker'i UserForm'unuza (Microsoft Date and Time Picker Control 6.0 (SP6)) nesnesi eklemeden de kullanabileceğiniz bir örnek eklemek istiyorum...

■ ClassModule (clsDTPickerOnComboBox) kodları;

Kod: Tümünü seç

Option Explicit
Private Type tagINITCOMMONCONTROLSEX
    dwSize          As Long
    dwICC           As Long
End Type
Private Type SYSTEMTIME
    Year            As Integer
    Month           As Integer
    DayOfWeek       As Integer
    Day             As Integer
    Hour            As Integer
    Minute          As Integer
    Second          As Integer
    Milliseconds    As Integer
End Type
Private Type SYSTEMTIMERANGE
    MinYear         As Integer
    MinMonth        As Integer
    MinDayOfWeek    As Integer
    MinDay          As Integer
    MinHour         As Integer
    MinMinute       As Integer
    MinSecond       As Integer
    MinMilliseconds As Integer
    MaxYear         As Integer
    MaxMonth        As Integer
    MaxDayOfWeek    As Integer
    MaxDay          As Integer
    MaxHour         As Integer
    MaxMinute       As Integer
    MaxSecond       As Integer
    MaxMilliseconds As Integer
End Type

Private Const DATETIMEPICK_CLASS = "SysDateTimePick32"
Private Const ICC_DATE_CLASSES = &H100
Private Const DTS_SHORTDATEFORMAT = &H0             ' YYYY/MM/DD
Private Const DTS_LONGDATEFORMAT = &H4              ' YYYY”NMMŒŽDD

Private Const GDT_VALID = 0
Private Const GDTR_MIN = &H1
Private Const GDTR_MAX = &H2

Private Const DTM_FIRST = &H1000
Private Const DTM_GETSYSTEMTIME = (DTM_FIRST + 1)
Private Const DTM_SETSYSTEMTIME = (DTM_FIRST + 2)
Private Const DTM_GETRANGE = (DTM_FIRST + 3)
Private Const DTM_SETRANGE = (DTM_FIRST + 4)
Private Const DTM_SETFORMAT = (DTM_FIRST + 5)
Private Const DTM_SETMCCOLOR = (DTM_FIRST + 6)
Private Const DTM_GETMCCOLOR = (DTM_FIRST + 7)
Private Const DTM_GETMONTHCAL = (DTM_FIRST + 8)
Private Const DTM_SETMCFONT = (DTM_FIRST + 9)
Private Const DTM_GETMCFONT = (DTM_FIRST + 10)

Private Const MCSC_BACKGROUND = 0
Private Const MCSC_TEXT = 1
Private Const MCSC_TITLEBK = 2
Private Const MCSC_TITLETEXT = 3
Private Const MCSC_MONTHBK = 4
Private Const MCSC_TRAILINGTEXT = 5

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000


Private Declare Function InitCommonControlsEx Lib "ComCtl32" _
    (LPINITCOMMONCONTROLSEX As Any) As Long
                               

Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" _
    (ByVal lpClassName As String, _
     ByVal lpWindowName As String) As Long


Private Declare Function FindWindowEx Lib "user32" _
    Alias "FindWindowExA" _
    (ByVal hwndParent As Long, _
     ByVal hwndChildAfter As Long, _
     ByVal lpszClass As String, _
     ByVal lpszWindow As String) As Long


Private Declare Function GetDeviceCaps Lib "gdi32" _
    (ByVal hdc As Long, ByVal nIndex As Long) As Long


Private Declare Function GetWindowLong Lib "user32" _
    Alias "GetWindowLongA" _
    (ByVal hWnd As Long, _
     ByVal nIndex As Long) As Long


Private Declare Function GetDesktopWindow Lib "user32" _
    () As Long


Private Declare Function GetDC Lib "user32" _
    (ByVal hWnd As Long) As Long


Private Declare Function ReleaseDC Lib "user32" _
    (ByVal hWnd As Long, ByVal hdc As Long) As Long


Private Declare Function CreateWindowEx Lib "user32" _
    Alias "CreateWindowExA" _
    (ByVal dwExStyle As Long, ByVal lpClassName As String, _
     ByVal lpWindowName As String, ByVal dwStyle As Long, _
     ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
     ByVal nHeight As Long, ByVal hwndParent As Long, _
     ByVal hMenu As Long, ByVal hInstance As Long, _
     lpParam As Any) As Long
   

Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Long, _
     ByVal wParam As Long, lParam As Any) As Long
                                 

Private Declare Function MoveWindow Lib "user32" _
    (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, _
     ByVal nWidth As Long, ByVal nHeight As Long, _
     ByVal bRepaint As Long) As Long
                                 

Private Declare Function DestroyWindow Lib "user32" _
    (ByVal hWnd As Long) As Long
                               

Private Declare Function IsWindow Lib "user32" _
    (ByVal hWnd As Long) As Long


Private Declare Function SetFocus Lib "user32" _
    (ByVal hWnd As Long) As Long


Private mctlForm  As UserForm                       ' UserForm
Private WithEvents mctlComboBox As MSForms.ComboBox 'ComboBox

Private mlnghwndDateTime As Long                    ' DateTime
Private lngPixelsX As Long                          '
Private lngPixelsY As Long                          '
Private lnghWnd_Excel As Long                       ' Excel
Private lnghWnd_Form As Long                        '


' Cmd
Public Property Get Cmd() As MSForms.ComboBox
    Set Cmd = mctlComboBox
End Property

Public Property Let Cmd(ctlNewComboBox As MSForms.ComboBox)
    Set mctlComboBox = ctlNewComboBox
End Property

' UserForm
Public Property Get UserForm() As UserForm
    Set UserForm = mctlForm
End Property

Public Property Let UserForm(ctlNewUserForm As UserForm)
    Set mctlForm = ctlNewUserForm
End Property

' Value
Public Property Get Value() As Date
    Dim st As SYSTEMTIME
    Dim lngResult As Long
    lngResult = SendMessage(mlnghwndDateTime, _
        DTM_GETSYSTEMTIME, 0, st)
    With st
        Value = DateSerial(.Year, .Month, .Day)
    End With
End Property

Public Property Let Value(dtmNewValue As Date)
    Dim lngResult As Long
    Dim st As SYSTEMTIME
'sistem saati
    With st
        .Year = Year(dtmNewValue)
        .Month = Month(dtmNewValue)
        .Day = Day(dtmNewValue)
        .DayOfWeek = Weekday(dtmNewValue) - 1
        .Hour = 0
        .Minute = 0
        .Second = 0
    End With
    lngResult = SendMessage(mlnghwndDateTime, _
        DTM_SETSYSTEMTIME, GDT_VALID, st)
End Property


Public Sub Create()
    Dim icce            As tagINITCOMMONCONTROLSEX
    Dim lngResult       As Long
    Dim lnghInstance    As Long
    Dim lnghWnd_Sub     As Long
    Dim strThunder      As String

    If Val(Application.Version) <= 8 Then
        strThunder = "ThunderXFrame"        ' Excel97
    Else
        strThunder = "ThunderDFrame"        ' Excel2000
    End If
   
   
    If IsWindow(mlnghwndDateTime) <> 0 Then
        Call DestroyWindow(mlnghwndDateTime)
    End If
   
    'INITCOMMONCONTROLSEX
   
    With icce
        .dwICC = ICC_DATE_CLASSES
        .dwSize = Len(icce)
    End With
   

    lngResult = InitCommonControlsEx(icce)
   

    lnghWnd_Form = FindWindow(strThunder, mctlForm.Caption)
    If lnghWnd_Form = 0 Then Exit Sub


    Call GetLogPixelsXY
   
    lnghWnd_Excel = FindWindow("XLMAIN", Application.Caption)
    lnghInstance = GetWindowLong(lnghWnd_Excel, GWL_HINSTANCE)
       

    lnghWnd_Sub = FindWindowEx(lnghWnd_Form, 0&, vbNullString, vbNullString)
   

    mlnghwndDateTime = CreateWindowEx(0&, DATETIMEPICK_CLASS, vbNullString, _
        WS_CHILD Or WS_VISIBLE Or DTS_SHORTDATEFORMAT, _
        mctlComboBox.Left * lngPixelsX / 72, mctlComboBox.Top * lngPixelsY / 72, _
        mctlComboBox.Width * lngPixelsX / 72, mctlComboBox.Height * lngPixelsY / 72, _
        lnghWnd_Sub, 0&, lnghInstance, vbNullString)    ' Short(yyyy/mm/dd)

End Sub

Public Sub GotFocus()
    Call SetFocus(mlnghwndDateTime)
End Sub

Public Sub Destroy()
    Call Class_Terminate
End Sub

Private Sub Class_Initialize()
    mlnghwndDateTime = 0
End Sub

Private Sub Class_Terminate()
    If IsWindow(mlnghwndDateTime) <> 0 Then
        Call DestroyWindow(mlnghwndDateTime)
    End If
End Sub

Private Sub mctlComboBox_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, _
                               ByVal Shift As Integer)
    If KeyCode = 9 Then Call SetFocus(mlnghwndDateTime)
End Sub

Private Sub GetLogPixelsXY()
     Dim lnghwnd As Long
     Dim lngDC As Long
     lnghwnd = GetDesktopWindow()
     lngDC = GetDC(lnghwnd)
     lngPixelsX = GetDeviceCaps(lngDC, LOGPIXELSX)
     lngPixelsY = GetDeviceCaps(lngDC, LOGPIXELSY)
     ReleaseDC lnghwnd, lngDC
End Sub

■ Module (modDTPickerOnComboBox) kodları;

Kod: Tümünü seç

Option Explicit
Option Base 1
Public Const g_lngComboBox_Max = 5
Public clsDTPCBox(1 To g_lngComboBox_Max) As New clsDTPickerOnComboBox

Public Sub GP_DestroyClass_ALL(objForm As UserForm)
    Dim IX As Integer
     For IX = 1 To g_lngComboBox_Max
        clsDTPCBox(IX).Destroy
        Set clsDTPCBox(IX) = Nothing
    Next IX
End Sub

Sub Show_DTPicker()
    UserForm1.Show
End Sub

■ UserForm kodları;

Kod: Tümünü seç

Option Explicit
Private Sub UserForm_Initialize()
    Dim colCmbBox As New Collection
    Dim IX As Integer
   
    With colCmbBox
        .Add Item:=ComboBox1
        .Add Item:=ComboBox2
        .Add Item:=ComboBox3
        .Add Item:=ComboBox4
        .Add Item:=ComboBox5
    End With
   
    For IX = 1 To g_lngComboBox_Max

        Set clsDTPCBox(IX) = New clsDTPickerOnComboBox
        With clsDTPCBox(IX)
            .Cmd = colCmbBox(IX)
            .UserForm = Me
            .Create
        End With
    Next IX
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
   Call GP_DestroyClass_ALL(Me)
End Sub

[Enes Recep BAĞ]

Ellerine sağlık Murat Bey,

[Erhan Yavuz]

Murat harikasın..

[Murat OSMA]

Rica ederim Enes Bey, faydalı olması dileğiyle.

Erhan abi, harika olan sensin.

Tek bir sorunu var onu da çözebilirsem o zaman daha kullanışlı olacak..

[Tarkan VURAL]

Seçilen tarihin değerini alabilen var mı ? Ben bir türlü yazılı veriye ulaşamadım. Ne Class ve nesneden. İşin ilginç yanı ise, aslında form üzerinde bulunan ComboBox nesneleri kullanılmıyor. Onların yerine SysDateTimePick32 ile sistem nesneleri geliyor. Mesela clsDTPickerOnComboBox classında bulunan Create prosedürünü biraz modifiye edeyim de dediğim daha net anlaşılsın. Kodlardaki mlnghwndDateTime = CreateWindowEx(0&, DATETIMEPICK_CLASS, vbNullString ..... kısmında yazılı olan left değerini 150 arttıralım. UserFormumuzu da yana doğru genişletelim.

mlnghwndDateTime = CreateWindowEx(0&, DATETIMEPICK_CLASS, vbNullString, _
WS_CHILD Or WS_VISIBLE Or DTS_SHORTDATEFORMAT, _
mctlComboBox.Left * lngPixelsX / 72 + 150, mctlComboBox.Top * lngPixelsY / 72, _
mctlComboBox.Width * lngPixelsX / 72, mctlComboBox.Height * lngPixelsY / 72, _
lnghWnd_Sub, 0&, lnghInstance, vbNullString) ' Short(yyyy/mm/dd)

Şimdi aşağıdaki prosedürü de form sayfasına ekleyelim. Açtığımızda formdaki boş bir bölgeyi tıklayalım. Form üzerinde görünsede aslında formun designeri üzerinde olmayan dtpicker nesnelerinin isimleri karşımıza gelmeyecek.

Kod: Tümünü seç

Private Sub UserForm_Click()
Dim i
For Each i In Me.Controls
MsgBox i.Name
Next i
End Sub

Y
ani bizim aslında müdahale ettiğimiz yer Combobox nesneleri değil, hafızada oluşturulan SysDateTimePick32 özelliğindeki nesneler. Hadi gel de şimdi burda doğru bir mantık yürütüp picker içindeki değeri al. Valla ben henüz değerleri alamadım. Çözebilecek biri varsa çözüm şeklini ben de öğrenmek isterim.

[Murat OSMA]

Benim de bahsettiğim sorun buydu.

UserForm üzerinde var olan nesnelerin üzerine yeni nesneler ekliyoruz ve bu nesneleri sanki DTPicker imiş gibi gösteriyoruz ama, seçilen tarihi bire yere yazdırma konusunda kalmıştım en son. Şimdi kodlara tekrar bakınca şu şekilde çözülebileceğini fark ettim. Akşam daha geniş bir şekilde inceleyip olması gerektiği gibi düzenlemeye çalışacağım.

1. ComboBox'tan tarih seçimini yaptıktan sonra UserForm'u tıklarsanız, istediğiniz yere 1. ComboBox'taki tarih değerini alıp yazdırabilirsiniz.

Kod: Tümünü seç

Private Sub UserForm_Click()
    Range("A1").Value = clsDTPCBox(1).Value
End Sub

Ya da ilgili satırı ClassModule'deki mctlComboBox_KeyUp olayına yazıp tarihi seçtikten sonra Tab tuşuna basarsanız da aynı işlemi yapacaktır.

Kod: Tümünü seç

Private Sub mctlComboBox_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 9 Then
        Call SetFocus(mlnghwndDateTime)
        Range("A1").Value = clsDTPCBox(1).Value
    End If
End Sub

[Ozan İLGÜN]

Ekteki örnek alternatif amaçlı sunulan alıntıdır.

[Tarkan VURAL]

Eyvallah Murat, eline sağlık.

[Murat OSMA]

Sağ ol abicim
İşe gidince UserForm'u tiklamadan ve Tab tuşuna basmadan Change ya da diğer olaylarla çözümüne bakacağım.

[Murat OSMA]

Sanırım şimdilik UserForm_MouseMove olayına yazmak daha mantıklı olacak.

Kod: Tümünü seç

Private Sub UserForm_MouseMove(ByVal Button As Integer, _
    ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Range("A1").Value = clsDTPCBox(1).Value
End Sub

[Tarkan VURAL]

Neden UserForm ?

[Murat OSMA]

Anlamadım abi, neden UserForm derken ?

[Tarkan VURAL]

Anlamadım abi, neden UserForm derken ?

Bir önceki sayfaya bakman gerek.

Sanırım şimdilik UserForm_MouseMove olayına yazmak daha mantıklı olacak.

Nesnenin Change, Click olaylarına yazılması gerekmiyor mu ?

[Murat OSMA]

Change ve Click olayı ile tetikleme yaptıramadığım için, en mantıklısı UserForm_MouseMove olayı ile yaptırmak olarak düşündüm. Tarihi seçtikten sonra Mouse hareket ettiğinde seçilen tarih A1 hücresine yazdırılıyor.

Dediğin gibi olması gereken; Change ya da Click olayı ile tarihi alabilmek, ama gece fazla bakamadım. O şekilde düzenleyebilirsek daha iyi olur elbette.

[demudi]

Merhaba Murat Bey,

Güzel çalışma için teşekkürler. Benüm de uygulamalarımda kullanabileceğim bir konu aslında. Yapılan yorumları okuduğumda, dosyanın ilk paylaştığınız halinden sanırım bir miktar değişiklikler oldu anlıyorum. Bu nedenle dosyanın son halini paylaşmanız mümkün olursa herkes daha kolay faydalanabilir diye düşünüyorum.

Teşekkürler, İyi Çalışmalar

[Murat OSMA]

Merhaba Murat Bey,

Aslında yapılan değişiklik sadece şu oldu: İlk mesajdaki dosyaya 10. mesajdaki kodları ilave ettim. Siz de o ilaveyi yapıp deneyebilirsiniz..

İyi günler.