常駐於工具列上的月曆控件-增益集(第二版)

by chijanzen on 九月 1st, 2008 | View: 2,165 views

Tags

No Tags

Comments (0)

索引	H0050
主題	常駐於工具列上的月曆控件-增益集(第二版)
版本	>= 10.0(Office 2002)
說明	本範例將[月曆控件]常駐於工具列上，方便使用者查閱日期或選擇日期，功能如下 1.直接調用月曆控件來輸入日期 2.按 Ctrl + t 可以直接輸入當天的日期(類似Excel 2002 版以前的 Ctrl + ;，從Excel 2003版以後就不能用了) 3.新版增加了窗體開啟/關閉時淡入及淡出的效果及一些小修正
參考

Code

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars("Formatting").Controls("Calendar").Delete
    On Error GoTo 0
    Application.OnKey "^t"
End Sub
　

Private Sub Workbook_Open()
    If hasCalendar Then
        Call CreateControl
        'Ctrl + t 輸入當天的日期
        Application.OnKey "^t", "Insert_today"
    Else
        MsgBox "您並未安裝月曆控件(mscal.ocx)，無法使用本增益集 "
    End If
End Sub
　

Code

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
       ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" ( _
        ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, _
        ByVal dwFlags 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
        ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Const WS_EX_LAYERED = &H80000
Const GWL_EXSTYLE = (-20)
Const LWA_ALPHA = &H2        '表示把窗體設置成半透明樣式
　

Sub CreateControl()
    Dim caobjBtn As CommandBarButton
    On Error Resume Next
    Application.CommandBars("Formatting").Controls("Calendar").Delete
    Err.Clear
    Set caobjBtn = Application.CommandBars("Formatting").Controls.Add( _
            Type:=msoControlButton, Temporary:=True)
    With caobjBtn
        .Caption = "Calendar"
        .TooltipText = "月曆"
        .OnAction = "CaForm_Initialize"
        .BeginGroup = True
        .Style = msoButtonIcon
        .FaceId = 125
    End With
End Sub
　

Sub CaForm_Initialize()
CaForm.Show 0
End Sub
　

Sub Insert_today()
    If TypeName(ActiveCell) = "Range" Then
        ActiveCell = Date
    End If
End Sub
　

Function hasCalendar() As Boolean
    Dim obj As Object
    On Error Resume Next
    Set obj = CreateObject("MSCAL.Calendar")
    hasCalendar = (Err = 0)
    Set obj = Nothing
End Function
　

Sub SetUFOpacity(Alpha As Byte, rhwnd As Long)
    Dim rtn As Long
    rtn = GetWindowLong(rhwnd, GWL_EXSTYLE)    '取的窗口原先的樣式
    rtn = rtn Or WS_EX_LAYERED            '使窗體添加上新的樣式
    SetWindowLong rhwnd, GWL_EXSTYLE, rtn      '把新的樣式賦給窗體
    SetLayeredWindowAttributes rhwnd, 0, Alpha, LWA_ALPHA
End Sub
　

Code

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private WithEvents evnsht As Excel.Worksheet
Dim yoffset As Long, xOffset As Long
Dim Counter1 As Integer, Counter2 As Integer
Dim hndMe As Long
　

Private Sub CommandButton1_Click()
Unload Me
End Sub
　

Private Sub UserForm_Activate()
    With Application.CommandBars("Formatting")
        Me.Top = (.Top + .Height) * 0.75 + yoffset
        Me.Left = (.Controls("Calendar").Left + _
                .Controls("Calendar").Width) * 0.75 + xOffset - Me.Width
    End With
    For Counter1 = 1 To 240 Step 1
        Call SetUFOpacity(CByte(Counter1), hndMe)
        For Counter2 = 1 To 100
            DoEvents
        Next Counter2
    Next Counter1
    Me.Calendar1.Value = Date
End Sub
　

Private Sub UserForm_Initialize()
    xOffset = (Me.Width - Me.InsideWidth) / 2
    yoffset = Me.Height - Me.InsideHeight - xOffset - 1
    hndMe = FindWindow(vbNullString, Me.Caption)
    SetWindowLong hndMe, -16, &H84080080    '去標頭
    SetWindowLong hndMe, -20, &H40000  '去外框
    DrawMenuBar hndMe
    Me.Calendar1.Top = 0
    Me.Calendar1.Left = 0
    Me.Label1.Top = Me.Calendar1.Height
    Me.Width = Me.Calendar1.Width
    Me.Height = Me.Calendar1.Height + Me.Label1.Height
        Set evnsht = ActiveSheet
End Sub
　

Private Sub Calendar1_Click()
    If TypeName(ActiveCell) = "Range" Then
        ActiveCell = CDate(Calendar1.Value)
    End If
    Unload Me
End Sub
　

Private Sub Calendar1_DblClick()
Unload Me
End Sub
　

Private Sub evnsht_SelectionChange(ByVal Target As Range)
Unload Me
End Sub
　

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    For Counter1 = 240 To 1 Step -1
        Call SetUFOpacity(CByte(Counter1), hndMe)
        For Counter2 = 1 To 100
            DoEvents
        Next Counter2
    Next Counter1
    Set evnsht = Nothing
End Sub
　