自定義進(jìn)度條
API的用處不是一時半會就可以說完了，但例子還是要一個個給，現(xiàn)在給出第二個利用API的例子，在Excel的狀態(tài)欄中顯示自定義的進(jìn)度條。
'//此模塊創(chuàng)建了一個顯示在狀態(tài)欄的自定義進(jìn)度條，并可對狀態(tài)欄的文字進(jìn)行設(shè)置
'//——以下聲明API函數(shù)——
'//創(chuàng)建文字函數(shù)，其中fCharacterSet：字符集;134為GB2312
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal fHeight As Long, ByVal fWidth As Long, ByVal fEscapement As Long, ByVal fOrientation As Long, ByVal fWeight As Long, ByVal fItalic As Long, ByVal fUnderline As Long, ByVal fStrikeout As Long, ByVal fCharacterSet As Long, ByVal fPrecision As Long, ByVal fClipping As Long, ByVal fQuality As Long, ByVal fPitchAndFamily As Long, ByVal fName As String) As Long
'//取得窗體設(shè)備環(huán)境函數(shù)
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
'//設(shè)置環(huán)境內(nèi)容，此處為文字
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
'//刪除創(chuàng)建的環(huán)境內(nèi)容
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'//釋放設(shè)備環(huán)境
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
'//該函數(shù)創(chuàng)建一個具有擴(kuò)展風(fēng)格的重疊式窗口、彈出式窗口或子窗口
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
'//破壞創(chuàng)建的窗口
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
'//設(shè)置一個窗口為另一窗口的子窗口
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
'//視情況向窗體發(fā)送不同的信息
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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'//查找一個窗口中子窗口的句柄
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
'//設(shè)置場景背景色
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
'//設(shè)置文本顏色
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
'//取得系統(tǒng)色
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
'//取得窗體客戶區(qū)坐標(biāo)
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'//——以下定義常量及類型——
Private Const WS_VISIBLE = &H10000000 '可見
Private Const WS_CHILD = &H40000000 '子窗口
Private Const WS_BORDER = &H800000 '單邊框
Private Const PBS_STANDARD = &H0 '標(biāo)準(zhǔn)
Private Const PBS_SMOOTH = &H1 '平滑
Private Const CCM_FIRST = &H2000&
Private Const WM_USER = &H400
Private Const PBM_SETBKCOLOR = (CCM_FIRST + 1) '設(shè)置進(jìn)度條背景色
Private Const PBM_SETPOS = (WM_USER + 2) '設(shè)置進(jìn)度條狀態(tài)
Private Const PBM_SETBARCOLOR = (WM_USER + 9) '設(shè)置進(jìn)度條顏色
Private Const COLOR_BTNFACE = 15 '系統(tǒng)按紐背景色
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'//進(jìn)度條顯示時的樣式
Enum PBType
P_STANDARD = WS_VISIBLE Or WS_CHILD Or WS_BORDER Or PBS_STANDARD '標(biāo)準(zhǔn)樣式
P_SMOOTH = WS_VISIBLE Or WS_CHILD Or WS_BORDER Or PBS_SMOOTH '平滑式
End Enum
'// 文字的字體粗細(xì)需在0到1000之間，例如，400代表普通，700代表粗體，而0則表示默認(rèn)。
Enum FnWeight
FW_DONTCARE = 0
FW_THIN = 100
FW_EXTRALIGHT = 200
FW_ULTRALIGHT = 200
FW_LIGHT = 300
FW_NORMAL = 400
FW_REGULAR = 400
FW_MEDIUM = 500
FW_SEMIBOLD = 600
FW_DEMIBOLD = 600
FW_BOLD = 700
FW_EXTRABOLD = 800
FW_ULTRABOLD = 800
FW_HEAVY = 900
FW_BLACK = 900
End Enum
'// 主過程
'//參數(shù)如下；
'//FontHeight:文字高度,FontWeight:文字粗細(xì),FontColor:文字顏色,Italic:斜體,lngPBType:進(jìn)度條類型,MaxVlue:最大值,StopValue:停止值,Prompt:狀態(tài)欄字符串。
Sub StatusBarMsg(FontHeight As Long, FontWeight As FnWeight, FontColor As Long, Italic As Boolean, lngPBType As PBType, MaxVlue As Long, StopValue As Long, Prompt As String)
Dim hwndStatusbar As Long '狀態(tài)欄句柄
Dim PbHwnd As Long '創(chuàng)建的進(jìn)度條
Dim XlStaBarRect As RECT '用于裝載狀態(tài)欄區(qū)域
Dim xlMain As Long 'EXCEL主窗口句柄
Dim hDcStatusBar As Long '狀態(tài)欄設(shè)備環(huán)境
Dim hFont As Long, hFontOld As Long '創(chuàng)建的文字及原文字信息
Dim oldStatusBar As Boolean '原狀態(tài)欄狀態(tài)
Dim I As Long, iVal As String
Dim StrLen As Integer '狀態(tài)欄文本長度
Dim GetBarRECT As Long
StrLen = Len(Prompt) * Abs(FontHeight) + 30
'// 取得EXCEL主窗口的句柄。
xlMain = FindWindow("XLMAIN", vbNullString) 'Excel2002及以后版本可以直接用Application.hWnd 來取得Excel主窗口的句柄
'// 取得狀態(tài)欄的句柄。 狀態(tài)欄類名："EXCEL4"
hwndStatusbar = FindWindowEx(xlMain, 0, "EXCEL4", vbNullString)
'//取得狀態(tài)欄的客戶區(qū)坐標(biāo)
GetBarRECT = GetClientRect(hwndStatusbar, XlStaBarRect)
'// 取得狀態(tài)欄的場景
hDcStatusBar = GetDC(hwndStatusbar)
'//創(chuàng)建一種將用于狀態(tài)欄的文字, 注意: 文字名稱的長度必修小于32 ' "新宋體"為自己給定的文字名，可以自行更改
hFont = CreateFont(FontHeight, 0, 0, 0, FontWeight, Italic, 0, 0, 134, 0, 0, 0, 0, "新宋體")
'// 首先設(shè)置新字體并保存原來的字體！
hFontOld = SelectObject(hDcStatusBar, hFont)
'// 保存原狀態(tài)欄狀態(tài)
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
'// 創(chuàng)建進(jìn)度條
PbHwnd = CreateWindowEX(0, "msctls_progress32", "", lngPBType, StrLen, XlStaBarRect.Top + 1, 198, _
XlStaBarRect.Bottom - 2, hwndStatusbar, 0, 0, 0)
'//將進(jìn)度條設(shè)為狀態(tài)欄的子窗口
SetParent PbHwnd, hwndStatusbar
'// 進(jìn)度條顏色，顏色可以自行設(shè)置
SendMessage PbHwnd, PBM_SETBARCOLOR, 0&, ByVal 16711680 '藍(lán)色
'// 進(jìn)度條背景色，顏色可以自行設(shè)置
SendMessage PbHwnd, PBM_SETBKCOLOR, 0&, ByVal 16777215 '白色
'//狀態(tài)欄背景色，這里用的是按紐背景色
Call SetBkColor(hDcStatusBar, GetSysColor(COLOR_BTNFACE))
'//文字顏色，即狀態(tài)欄前景色
Call SetTextColor(hDcStatusBar, FontColor)
'//設(shè)置狀態(tài)欄文字
Application.StatusBar = Prompt
For I = 1 To MaxVlue
iVal = I / MaxVlue * 100
If I = StopValue Then
'//保存工作薄
'ActiveWorkbook.Save
Call SetBkColor(hDcStatusBar, GetSysColor(COLOR_BTNFACE))
Call SetTextColor(hDcStatusBar, FontColor)
Application.StatusBar = Prompt
End If
'//向進(jìn)度條發(fā)送消息，以更改進(jìn)度條的狀態(tài)
SendMessage PbHwnd, PBM_SETPOS, ByVal iVal, 0&
Next I
'// 清除進(jìn)度條
DestroyWindow PbHwnd
'// 恢復(fù)原來狀態(tài)欄的字體
SelectObject hDcStatusBar, hFontOld
'//釋放狀態(tài)欄的設(shè)備場景
ReleaseDC hwndStatusbar, hDcStatusBar
'//恢復(fù)原狀態(tài)欄狀態(tài)
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
End Sub
'//此為工作表中按鈕調(diào)用程序
Sub SaveWorkbook()
Call StatusBarMsg(-12, FW_BOLD, 255, False, P_SMOOTH, 800000, 800000, "正在保存當(dāng)前工作薄，請稍候……")
End Sub
下面是ThisWorkbook的代碼
'//重置自定義設(shè)定
Private Sub Workbook_BeforeClose(Cancel As Boolean)
With Application
.CommandBars("Worksheet Menu Bar").Controls("文件(&F)").Controls("保存(&S)").Reset
.CommandBars("Standard").Controls("保存(&S)").Reset
.OnKey "^s"
End With
End Sub
'//將菜單,工具欄和快捷鍵(Ctrl+S)上的保存菜單重設(shè)為執(zhí)行自己的過程
Private Sub Workbook_Open()
With Application
.CommandBars("Worksheet Menu Bar").Controls("文件(&F)").Controls("保存(&S)").OnAction = "SaveWorkbook"
.CommandBars("Standard").Controls("保存(&S)").OnAction = "SaveWorkbook"
.OnKey "^s", "SaveWorkbook"
End With
End Sub
這樣你就自定義好了進(jìn)度條，可惜的是這個進(jìn)度條還不算完善，它不能自行根據(jù)保存文件所需要的時間動態(tài)變化進(jìn)度條的演示時間，還有，這時按菜單，工具欄與快捷鍵Ctrl+S其實(shí)都沒有保存文件,我把保存文件的這行代碼變成備注了??！請注意！
點(diǎn)擊下載完全代碼。
