|
在Excel 中当每次保存文档时我们就能见到一个显示保存进度的进度条和状态栏显示的消息，我们可以通过Application的StatusBar属性来更改状态栏显示的文字，但我们能不能实现工作时在状态栏用进度条显示自己的工作进度呢？我们能不能更改状态栏显示的文字颜色呢？我们就试一试（在EXCEL2003及WINDOWSXP中通过）：
1、在Excel 的VBE窗口中插入一个模块，在此模块和 ThisWorkbook 中输入后面所列代码。
2 、在工作薄中的任意工作表中添加一窗体按钮控件，将指定其 设置宏 为 SaveWorkbook。其供示范之用
模块1代码：
************************************************************************************************
'//此模块创建了一个显示在状态栏的自定义进度条，并可对状态栏的文字进行设置
'//************************************************************************************************
'//——以下声明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主窗口的句柄。Excel2002及以后版本可以直接用Application.hWnd 来取得Excel主窗口的句柄
xlMain = FindWindow("XLMAIN", vbNullString)
'// 取得状态栏的句柄。 状态栏类名："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
'//保存工作薄
ThisWorkbook.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_STANDARD, 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
End With
End Sub
'--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'//将菜单和工具栏上的保存菜单重设为执行自己的过程
Private Sub Workbook_Open()
With Application
.CommandBars("Worksheet Menu Bar").Controls("文件(&F)").Controls("保存(&S)").OnAction = "SaveWorkbook"
.CommandBars("Standard").Controls("保存(&S)").OnAction = "SaveWorkbook"
End With
End Sub
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
说明:
l本范例是一个关于Excel状态栏定制的运用，主要利用 API函数来取得状态栏的句柄及设备场景，后用新的文字样式及颜色代替原来状态栏文字的样式及颜色，再用CreateWindowEX函数在状态栏创建一个带边框的进度条窗体，在进度条运行的过程中插入保存文档的代码，以达到保存文档时进度条运行的伪效果。
注：要使用压缩包内的示例文档请将压缩包内内容解压至同一文档。
YNkumAfi.rar
(18.68 KB, 下载次数: 1206)
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-7-19 12:34
