常駐於工具列上的月曆控件-增益集
說 明 本範例將[月曆控件]常駐於工具列上，方便使用者查閱日期或選擇日期，功能如下
1.直接調用月曆控件來輸入日期
2.按 Ctrl + t 可以直接輸入當天的日期(類似Excel 2002 版以前的 Ctrl + ;，從Excel 2003版以後就不能用了)
3.新版增加了窗體開啟/關閉時淡入及淡出的效果及一些小修正
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
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
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
說明:
附件內有兩個檔案，請解壓縮到同一資料夾內，請執行安裝程式
VBE 密碼:chijanzen
本範例必須要安裝[月曆控件]才能執行，如果電腦安裝月曆控件，請參考以下連結
http://vba.com.tw/VBAFILE/ActiveX/G0010.htm