class1.cls

用visual basic 6.0 开发的超市管理信息系统！

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CSysMonthCal32"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit



Private Type tagInitCommonControlsEx
    lngSize As Long
    lngICC As Long
End Type

Private Const ICC_DATE_CLASSES = &H100&

Private Declare Function InitCommonControlsEx Lib "Comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean

Private Const MONTHCAL_CLASSA = "SysMonthCal32"

Private Const H_MAX As Long = &HFFFF + 1
Private Const DTM_FIRST = &H1000
Private Const DTN_FIRST = (H_MAX - 760&)
Private Const DTN_LAST = (H_MAX - 799&)
Private Const MCM_FIRST = &H1000
Private Const MCM_HITTEST = (MCM_FIRST + 14)
Private Const MCN_FIRST = (H_MAX - 750&)
Private Const MCN_LAST = (H_MAX - 759&)
Private Const MCM_SETRANGE = (MCM_FIRST + 18)
Private Const MCN_SELECT = (MCN_FIRST + 4)
Private Const MCM_GETCURSEL = (MCM_FIRST + 1)
Private Const MCM_GETTODAY = (MCM_FIRST + 13)

Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1

Private Type SYSTEMTIME
        wYear As Integer
        wMonth As Integer
        wDayOfWeek As Integer
        wDay As Integer
        wHour As Integer
        wMinute As Integer
        wSecond As Integer
        wMilliseconds As Integer
End Type

 
Private Const WS_VISIBLE = &H10000000
Private Const WS_CHILD = &H40000000
 
Private Declare Function SendStringMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) 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 DestroyWindow Lib "user32" (ByVal hWnd As Long) 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 ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) 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 IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
 
 
Private Const DTN_DATETIMECHANGE = (DTN_FIRST + 1)
  
Private MonthCalHwnd As Long
Private MonthCalParent As Object
 
 

  

Public Property Get hWnd() As Long
    hWnd = MonthCalHwnd
End Property

Public Function Create( _
 Optional Left As Integer = 0, _
 Optional Top As Integer = 0, _
 Optional Width As Integer = 180, _
 Optional Height As Integer = 160) _
  As Boolean
    
    If Parent Is Nothing Then
        Create = False
        Exit Function
    End If
   
    
     
    MonthCalHwnd = CreateWindowEX(0, "SysMonthCal32", "", _
    WS_CHILD Or WS_VISIBLE, 0, 0, 0, 0, _
    Parent.hWnd, 0, App.hInstance, 0)
   
    Call ShowWindow(hWnd, SW_SHOWNORMAL)
    
     
   
    Call MoveWindow(MonthCalHwnd, Left, Top, Width, Height, True)
    
     
End Function

Public Property Set Parent(frm As Object)
    Set MonthCalParent = frm
End Property

Public Property Get Parent() As Object
    Set Parent = MonthCalParent
End Property

Private Sub Class_Initialize()
    Dim iccex As tagInitCommonControlsEx
    With iccex
        .lngSize = LenB(iccex)
        .lngICC = ICC_DATE_CLASSES
    End With
    Call InitCommonControlsEx(iccex)
    
    MonthCalHwnd = 0
End Sub

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

 Public Function GetCalendarDate() As Date
    Dim systime As SYSTEMTIME
    Dim CalDate As Date
   
    Call SendMessage(MonthCalHwnd, MCM_GETCURSEL, 0, systime)
  
    With systime
    CalDate = DateSerial(.wYear, .wMonth, .wDay)
    End With
    
    GetCalendarDate = CalDate
End Function