|
自定义进度条
API的用处不是一时半会就可以说完了，但例子还是要一个个给，现在给出第二个利用API的例子，在Excel的状态栏中显示自定义的进度条。 '//此模块创建了一个显示在状态栏的自定义进度条，并可对状态栏的文字进行设置 '//——以下声明API函数—— '//创建文字函数，其中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 '//取得窗体设备环境函数 Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long '//设置环境内容，此处为文字 Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long '//删除创建的环境内容 Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long '//设置一个窗口为另一窗口的子窗口 Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent 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 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 '//设置场景背景色 Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long '//设置文本颜色 Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long '//取得系统色 Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long '//取得窗体客户区坐标 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 '标准 Private Const PBS_SMOOTH = &H1 '平滑 Private Const CCM_FIRST = &H2000& Private Const WM_USER = &H400 Private Const PBM_SETBKCOLOR = (CCM_FIRST + 1) '设置进度条背景色 Private Const PBM_SETPOS = (WM_USER + 2) '设置进度条状态 Private Const PBM_SETBARCOLOR = (WM_USER + 9) '设置进度条颜色 Private Const COLOR_BTNFACE = 15 '系统按纽背景色 Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type '//进度条显示时的样式 Enum PBType P_STANDARD = WS_VISIBLE Or WS_CHILD Or WS_BORDER Or PBS_STANDARD '标准样式 P_SMOOTH = WS_VISIBLE Or WS_CHILD Or WS_BORDER Or PBS_SMOOTH '平滑式 End Enum '// 文字的字体粗细需在0到1000之间，例如，400代表普通，700代表粗体，而0则表示默认。 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 '// 主过程 '//参数如下； '//FontHeight:文字高度,FontWeight:文字粗细,FontColor:文字颜色,Italic:斜体,lngPBType:进度条类型,MaxVlue:最大值,StopValue:停止值,Prompt:状态栏字符串。 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 '状态栏句柄 Dim PbHwnd As Long '创建的进度条 Dim XlStaBarRect As RECT '用于装载状态栏区域 Dim xlMain As Long 'EXCEL主窗口句柄 Dim hDcStatusBar As Long '状态栏设备环境 Dim hFont As Long, hFontOld As Long '创建的文字及原文字信息 Dim oldStatusBar As Boolean '原状态栏状态 Dim I As Long, iVal As String Dim StrLen As Integer '状态栏文本长度 Dim GetBarRECT As Long StrLen = Len(Prompt) * Abs(FontHeight) + 30 '// 取得EXCEL主窗口的句柄。 xlMain = FindWindow("XLMAIN", vbNullString) 'Excel2002及以后版本可以直接用Application.hWnd 来取得Excel主窗口的句柄 '// 取得状态栏的句柄。 状态栏类名："EXCEL4" hwndStatusbar = FindWindowEx(xlMain, 0, "EXCEL4", vbNullString) '//取得状态栏的客户区坐标 GetBarRECT = GetClientRect(hwndStatusbar, XlStaBarRect) '// 取得状态栏的场景 hDcStatusBar = GetDC(hwndStatusbar) '//创建一种将用于状态栏的文字, 注意: 文字名称的长度必修小于32 ' "新宋体"为自己给定的文字名，可以自行更改 hFont = CreateFont(FontHeight, 0, 0, 0, FontWeight, Italic, 0, 0, 134, 0, 0, 0, 0, "新宋体") '// 首先设置新字体并保存原来的字体！ hFontOld = SelectObject(hDcStatusBar, hFont) '// 保存原状态栏状态 oldStatusBar = Application.DisplayStatusBar Application.DisplayStatusBar = True '// 创建进度条 PbHwnd = CreateWindowEX(0, "msctls_progress32", "", lngPBType, StrLen, XlStaBarRect.Top + 1, 198, _ XlStaBarRect.Bottom - 2, hwndStatusbar, 0, 0, 0) '//将进度条设为状态栏的子窗口 SetParent PbHwnd, hwndStatusbar '// 进度条颜色，颜色可以自行设置 SendMessage PbHwnd, PBM_SETBARCOLOR, 0&, ByVal 16711680 '蓝色 '// 进度条背景色，颜色可以自行设置 SendMessage PbHwnd, PBM_SETBKCOLOR, 0&, ByVal 16777215 '白色 '//状态栏背景色，这里用的是按纽背景色 Call SetBkColor(hDcStatusBar, GetSysColor(COLOR_BTNFACE)) '//文字颜色，即状态栏前景色 Call SetTextColor(hDcStatusBar, FontColor) '//设置状态栏文字 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 '//向进度条发送消息，以更改进度条的状态 SendMessage PbHwnd, PBM_SETPOS, ByVal iVal, 0& Next I '// 清除进度条 DestroyWindow PbHwnd '// 恢复原来状态栏的字体 SelectObject hDcStatusBar, hFontOld '//释放状态栏的设备场景 ReleaseDC hwndStatusbar, hDcStatusBar '//恢复原状态栏状态 Application.StatusBar = False Application.DisplayStatusBar = oldStatusBar End Sub '//此为工作表中按钮调用程序 Sub SaveWorkbook() Call StatusBarMsg(-12, FW_BOLD, 255, False, P_SMOOTH, 800000, 800000, "正在保存当前工作薄，请稍候……") End Sub 下面是ThisWorkbook的代码 '//重置自定义设定 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)上的保存菜单重设为执行自己的过程 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 这样你就自定义好了进度条，可惜的是这个进度条还不算完善，它不能自行根据保存文件所需要的时间动态变化进度条的演示时间，还有，这时按菜单，工具栏与快捷键Ctrl+S其实都没有保存文件,我把保存文件的这行代码变成备注了！！请注意！点击下载完全代码。 |
|
|
