自定义状态栏进度条-自定义Excel
来源:百度文库 编辑:神马文学网 时间:2024/06/13 03:45:52
自定义进度条
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其实都没有保存文件,我把保存文件的这行代码变成备注了!!请注意!点击下载完全代码。
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其实都没有保存文件,我把保存文件的这行代码变成备注了!!请注意!点击下载完全代码。
自定义状态栏进度条-自定义Excel
Excel中怎样自定义函数\自定义排序\隐藏数据\打印工资条
自定义控件
自定义“友谊”
自定义QQ03213
自定义导航
自定义模板
自定义模块
提取Excel不重复值的自定义函数方案
剖析Excel中的自定义数据格式 | 华师傅资讯
Excel 2007中创建或删除自定义数字格式
Excel自定义公式防止输入重复数据,excel教程,excel应用技巧
自定义JSP标签
jsp自定义标签一
jsp 自定义标签 二
jsp 自定义标签 二
自动翻页 自定义规则
QQ自定义表情
自定义指标编写教程
添加Firefox自定义搜索引擎
自定义文件夹图片
symbian自定义控件
自定义QQ秀详细
自定义鼠标类型