[原创] 状态栏进度条

丸究阵引

http://club.excelhome.net/viewthread.php?tid=257625&replyID=&skin=0
看到一个状态栏进度条，原理是加载 progressbar 到状态栏，利用发送消息指挥 progressbar 动作。如果看到excel的消息传递，这种用法实在是太奢侈！

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN = 0
Private Declare Function FindWindowA Lib "user32" (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 WindowFromDC Lib "user32" (ByVal hdc As Long) As Long
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long

Private Declare Function GetUpdateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Private Declare Function ValidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any, ByVal bErase As Long) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As RECT, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long

Private Const RDW_ALLCHILDREN = &H80
Private Const RDW_ERASE = &H4
Private Const RDW_ERASENOW = &H200
Private Const RDW_FRAME = &H400
Private Const RDW_INTERNALPAINT = &H2
Private Const RDW_INVALIDATE = &H1
Private Const RDW_NOCHILDREN = &H40
Private Const RDW_NOERASE = &H20
Private Const RDW_NOFRAME = &H800
Private Const RDW_NOINTERNALPAINT = &H10
Private Const RDW_UPDATENOW = &H100
Private Const RDW_VALIDATE = &H8

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
'-------------------
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDCEx Lib "user32" (ByVal hwnd As Long, ByVal hrgnclip As Long, ByVal fdwOptions As Long) As Long
Private Const DCX_LOCKWINDOWUPDATE = &H400&
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
'--------------------
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function ExtTextOut Lib "gdi32" Alias "ExtTextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal wOptions As Long, lpRect As RECT, ByVal lpString As String, ByVal nCount As Long, lpDx As Long) As Long
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size)

'--------------------
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal h As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long

Private Declare Function SetDCBrushColor Lib "gdi32.dll" (ByVal hdc As Long, ByVal colorref As Long) As Long
Private Declare Function GetDCBrushColor Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
Private Const COLOR_BTNFACE = 15
    
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CopyRect Lib "user32" (lpDestRect As RECT, lpSourceRect As RECT) As Long
'--------------------
Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long

Private Const DC_ACTIVE = &H1
Private Const DC_NOTACTIVE = &H2
Private Const DC_ICON = &H4
Private Const DC_TEXT = &H8
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENINNER = &H8
Private Const BDR_INNER = &HC
Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)

Private Const BF_LEFT = &H1                          ' 左边缘
Private Const BF_TOP = &H2                           ' 上边缘
Private Const BF_RIGHT = &H4                         ' 右边缘
Private Const BF_BOTTOM = &H8                        ' 下边缘
Private Const BF_DIAGONAL = &H10                     ' 对角线
Private Const BF_MIDDLE = &H800                      ' 填充矩形内部
Private Const BF_SOFT = &H1000     ' MSDN: Soft buttons instead of tiles.
Private Const BF_ADJUST = &H2000                     ' 调整矩形, 预留客户区
Private Const BF_FLAT = &H4000                       ' 平面边缘
Private Const BF_MONO = &H8000                       ' 一维边缘
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
Private Const BF_DIAGONAL_ENDTOPLEFT = (BF_DIAGONAL Or BF_TOP Or BF_LEFT)
Private Const BF_DIAGONAL_ENDTOPRIGHT = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT)
Private Const BF_DIAGONAL_ENDBOTTOMLEFT = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT)
Private Const BF_DIAGONAL_ENDBOTTOMRIGHT = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT)
'--------------------

Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64

Private Const DEFAULT_PITCH = 0 '默认(值)
Private Const FIXED_PITCH = 1 '固定的
Private Const VARIABLE_PITCH = 2 '可变的

Private Const FF_DECORATIVE = 80 ' 特殊字体
Private Const FF_DONTCARE = 0 ' 无所谓
Private Const FF_MODERN = 48 '具有规定的宽度，衬线可有可无
Private Const FF_ROMAN = 16 ' 字体宽度可变
Private Const FF_SCRIPT = 64 '手稿,
Private Const FF_SWISS = 32 '宽度可变，带衬线

'***************************************************

丸究阵引

Private Type LOGFONT
        lfHeight As Long     '字体的高度
        lfWidth As Long   '字体的宽度
        lfEscapement As Long  ' 字体旋转的角度
        lfOrientation As Long
        lfWeight As Long  '字体的轻重
        lfItalic As Byte  '是否为斜体
        lfUnderline As Byte    '是否有下划线
        lfStrikeOut As Byte    '是否有强调线
        lfCharSet As Byte      '字符集
        lfOutPrecision As Byte      '输出精度
        lfClipPrecision As Byte     '剪裁精度
        lfQuality As Byte      '输出质量
        lfPitchAndFamily As Byte    '间距和字体族
        lfFaceName As String * 32
        'lfFaceName(LF_FACESIZE) As Byte  '字体名，如“宋体”
End Type

Private Type RECT
     left As Long
     top As Long
     right As Long
     bottom As Long
End Type

Private Type Size
   cx As Long ' 字体的宽度
   cy As Long ' 字体的高度
End Type

'*****************************************************************************

Private Type User
    
     tLOGFONT  As LOGFONT
     tRECT As RECT
     tRECTExcel4 As RECT
     tRectArr() As RECT
     tSize As Size
    
     intChoose As Integer
     hOldFont As Long '原excel4字体对象
     hDcExcel4 As Long 'excel4 DC
     hWndExcel4 As Long
    
     hBarBrush As Long 'BAR刷子
     lngBarWidth As Long
     lngStep As Long '步长
     lngCounts As Long
    
     strText As String
     lngTextColor As Long
    
     lngBarColor As Long
     lngBarValue As Long '决定显示方块大小
     lngBarMin As Long
     lngBarMax As Long
   
     lngBarBackColor As Long
     lngBarBackWidth As Long
     blnOldStatusBar As Boolean
End Type

Private mt As User

Public Property Let ProBarMove(ByVal lngMove As Long)
   
     On Error Resume Next
    
     If lngMove = mt.lngBarMin Then
          TextBarChoose
          mt.lngCounts = 1
     End If
    
     If mt.intChoose = 0 Then Exit Property

     If lngMove Mod mt.lngStep = 0 Then
         
          LockWindowUpdate 0
         
          FillRect mt.hDcExcel4, mt.tRectArr(mt.lngCounts), mt.hBarBrush
         
          LockWindowUpdate GetParent(mt.hWndExcel4)
         
          DoEvents
         
          mt.lngCounts = mt.lngCounts + 1
         
     End If
   
End Property

Public Sub TextBarChoose()
    
     Dim hExcel4 As Long, lngStart  As Long
    
     If mt.lngBarMax = 0 And mt.intChoose <> 0 Then
          MsgBox "BarMax 为零！必选参数无效！", 0 + 16
          Exit Sub
     End If
    
     lngStart = GetSystemCaption / 2
     '窗口标题的高度作为绘制text的 x 起点
    
     Select Case mt.intChoose
         
          Case 0 '只显示文字
               TextOutText lngStart '按设置创建字体并输出到状态栏 左
          Case 1 '只显示进度条
               DrawBarBack lngStart '绘制进度条背景
               SetBarStepRectBrush
          Case 2 '两者都显示
               TextOutText lngStart '按设置创建字体并输出到状态栏 左
               DrawBarBack lngStart '绘制进度条背景
               SetBarStepRectBrush
     End Select
    
End Sub

'**************************** Bar **********************************************

'设置步长、BAR RECT、 Brush
Private Sub SetBarStepRectBrush()
    
    
     Dim lngRounds As Long, lngDraws As Long
     Dim lngCounts As Long, lngSum As Long
    
     With mt
    
          InflateRect .tRECT, -BarSpace, -1
          '缩小
          .lngBarBackWidth = .tRECT.right - .tRECT.left
          '经过两次 InflateRect 重设进度条背景总长度
          lngRounds = Abs(.lngBarMax - .lngBarMin) + 1
         
          lngDraws = .lngBarValue
         
          If Fix(lngRounds / .lngBarValue) < 2 Then lngDraws = lngRounds
         
          If Fix(.lngBarBackWidth / lngDraws) < BarSpace + 2 Then
               lngDraws = Fix(.lngBarBackWidth / (BarSpace + 2))
          End If
         
          .lngStep = CLng(lngRounds / lngDraws)
          'step值 五舍六入
          lngDraws = GetRounds ' (lngRounds / .lngStep + 0.1) + 1  '
        
          .lngBarWidth = .lngBarBackWidth / lngDraws
         
          SetRectArr lngDraws, lngSum
         
          .hBarBrush = CreateSolidBrush(mt.lngBarColor)
        
     End With
    
     LockWindowUpdate GetParent(mt.hWndExcel4)
    
End Sub

Private Function SetRectArr(ByVal lngDraws As Long, ByRef lngSum As Long)

     Dim lng As Long, lngCom As Long
     Dim lngChange As Long
    
     With mt
    
          lngCom = .lngBarBackWidth - .lngBarWidth * lngDraws
         
          If lngCom > 0 Then '缺少
               .lngBarWidth = .lngBarWidth + Sgn(lngCom)
               lngChange = lngCom
          Else '多出'每个-1
               lngChange = lngDraws + lngCom + 1 '
          End If
                   
          .tRECT.right = .tRECT.left + .lngBarWidth - BarSpace
          '设定标准的BAR宽度
          .lngCounts = 1
         
          For lng = .lngBarMin To .lngBarMax
              
               If lng Mod mt.lngStep <> 0 Then GoTo 100
              
               ReDim Preserve .tRectArr(.lngCounts)
              
               If lngChange = .lngCounts Then
    
                    If lngCom >= 0 Then
                         .lngBarWidth = .lngBarWidth - Sgn(lngCom)
                    Else
                         .lngBarWidth = .lngBarWidth + Sgn(lngCom)
                    End If
    
                    .tRECT.right = .tRECT.left + .lngBarWidth - BarSpace
    
               End If
    
               lngSum = lngSum + .lngBarWidth
    
               CopyRect .tRectArr(.lngCounts), .tRECT
    
               OffsetRect .tRECT, .lngBarWidth, 0
    
               .lngCounts = .lngCounts + 1
            
100
          Next
         
     End With
   
End Function

丸究阵引

'绘制进度条背景
Private Sub DrawBarBack(ByVal lngStart As Long)
    
     Dim rt As RECT
     Dim hBrush As Long
     Dim lngScreenX As Long, lngRight As Long
    
     lngScreenX = GetSystemMetrics(SM_CXSCREEN) - 10
    
     With mt '建立BARBACK矩形
         
          .tRECT.left = lngStart + .tSize.cx + 3 '起点+字符串长度3=调整量
          .tRECT.top = .tRECTExcel4.top + TopY 'Excel4下移2像素
         
          lngRight = .tRECT.left + mt.lngBarBackWidth '=左边界+宽度
         
          If lngRight > lngScreenX Then 'TEXT + barback 不能占满屏幕
               lngRight = lngScreenX 'TEXT + barback
               .lngBarBackWidth = lngRight - .tRECT.left '调整barback长度
          End If
         
          .tRECT.right = lngRight '左边界+宽度
          .tRECT.bottom = .tRECTExcel4.bottom - TopY 'Excel4上移2像素
    
     End With
        
     DrawEdge mt.hDcExcel4, mt.tRECT, EDGE_SUNKEN, BF_RECT
     '凹矩形
    
     InflateRect mt.tRECT, -1, -1 '缩小mt.tRECT
     hBrush = CreateSolidBrush(mt.lngBarBackColor)
     FillRect mt.hDcExcel4, mt.tRECT, hBrush
     '画BARBACK背景
    
     DeleteObject hBrush
    
End Sub

Private Function GetRounds() As Long
    
     Dim lng As Long
     Dim n As Long
    
     For lng = mt.lngBarMin To mt.lngBarMax
         If lng Mod mt.lngStep = 0 Then n = n + 1
     Next
    
     GetRounds = n
    
End Function
'***************************** Text *******************************************

'按设置创建字体并输出到状态栏 左
Private Sub TextOutText(ByVal lngStart As Long)
    
     Dim hNewFont As Long, lngTextLen As Long
         
     lngTextLen = LenB(StrConv(mt.strText, vbFromUnicode))
     'text 字符个数
     SetTextColor mt.hDcExcel4, mt.lngTextColor
     'text 颜色
     hNewFont = CreateFontIndirect(mt.tLOGFONT)
     '创建新字体
     SelectObject mt.hDcExcel4, hNewFont
     '将新字体加载到 Excel4
     TextOut mt.hDcExcel4, lngStart, TopY, mt.strText, lngTextLen
     '输出字符串
    
     GetTextExtentPoint32& mt.hDcExcel4, mt.strText, lngTextLen, mt.tSize  '测量
     '测量字符串长度,长度存储 mt.tSize
    
     DeleteObject hNewFont
     '清除hNewFont
     SelectObject mt.hDcExcel4, mt.hOldFont '恢复原字体
    
End Sub

'*****************************************************************************

Public Property Let Choose(ByVal intChoose As Integer)
    mt.intChoose = intChoose
End Property

'*****************************************************************************
'显示内容
Public Property Let Text(strText As String)
    mt.strText = strText
End Property
'字体颜色Text
Public Property Let TextColor(ByVal lngColor As Long)
     mt.lngTextColor = lngColor
End Property
'字体的宽度
Public Property Let TextWidth(ByVal Width As Long)
    mt.tLOGFONT.lfWidth = Width
End Property

'字体的高度
Public Property Let TextHeight(ByVal Height As Long)
    mt.tLOGFONT.lfHeight = Height
End Property
'字体的轻重
Public Property Let TextWeight(ByVal Weight As Long)
    mt.tLOGFONT.lfWeight = Weight
End Property
'是否为斜体
Public Property Let TextItalic(ByVal Italic As Boolean)
    mt.tLOGFONT.lfItalic = Italic
End Property
'字体名
Public Property Let TextFaceName(ByVal FaceName As String)
    mt.tLOGFONT.lfFaceName = FaceName & vbNullChar
End Property

'字体旋转的角度
Public Property Let TextEscapemente(ByVal Escapemente As Long)
    mt.tLOGFONT.lfEscapement = Escapemente
End Property

'间距和字体族
Public Property Let TextPitchAndFamily(ByVal PitchAndFamily As Long)
    mt.tLOGFONT.lfPitchAndFamily = PitchAndFamily
End Property

'-------------------------------------------------------------------

'颜色Bar
Public Property Let BarColor(ByVal lngColor As Long)
     mt.lngBarColor = lngColor
End Property

'进度条被景色
Public Property Let BarBackColor(ByVal lngColor As Long)
     mt.lngBarBackColor = lngColor
End Property
'进度条长度
Public Property Let BarBackWidth(ByVal lngWidth As Long)
     mt.lngBarBackWidth = lngWidth
End Property

'决定显示方块大小
Public Property Let BarValue(ByVal lngValue As Long)
     mt.lngBarValue = lngValue
End Property

Public Property Let BarMin(ByVal lngMin As Long)
     mt.lngBarMin = lngMin
End Property

Public Property Let BarMax(ByVal lngMax As Long)
     mt.lngBarMax = lngMax
End Property
'
Public Property Let Enable(ByVal bln As Boolean)
     EnableWindow ExcelMain(Application.Caption), bln
End Property

'*****************************************************************************

'excel4 hwnd
Private Property Get Excel4(strCaption As String) As Long
     Excel4 = FindWindowEx(ExcelMain(strCaption), ByVal 0&, "EXCEL4", vbNullString)
End Property

Private Property Get ExcelMain(strCaption As String)
     ExcelMain = FindWindowA("XLMAIN", strCaption)
End Property

Private Property Get WindowFromDCX() As Long
     WindowFromDCX = WindowFromDC(mt.hDcExcel4)
End Property

'---------------------------------------

'窗口标题的高度作为绘制text的 x
Private Property Get TopY() As Long
     TopY = 4
End Property

'Bar间隔
Private Property Get BarSpace() As Long
     BarSpace = 2
End Property

'窗口标题的高度
Private Property Get GetSystemCaption() As Long
     Const SM_CYCAPTION = 4
     GetSystemCaption = GetSystemMetrics(SM_CYCAPTION)
End Property

丸究阵引

Private Sub Class_Terminate()
    
     LockWindowUpdate 0
    
     ReleaseDC mt.hWndExcel4, mt.hDcExcel4
    
     DeleteObject mt.hBarBrush 'bar 刷子
         
     If IsWindowEnabled(GetParent(mt.hWndExcel4)) = False Then
          EnableWindow GetParent(mt.hWndExcel4), True
     End If
        
     InvalidateRect mt.hWndExcel4, mt.tRECTExcel4, True
     Application.StatusBar = False
     Application.DisplayStatusBar = mt.blnOldStatusBar
    
End Sub

Private Sub Class_Initialize()
    
     With mt
          .lngTextColor = &HFF& '红色 TEXT 默认
          .lngBarColor = &HFF0000  '&HFF000 '蓝色 BAR 默认
          .lngBarBackColor = &HFFFFFF '白色进度条背景色默认
          .lngBarBackWidth = GetSystemCaption * 6
          .lngBarValue = 30 '决定显示方块大小
          .intChoose = 2
     End With
    
     InitializeX
   
End Sub

'获取原StatusBar的字体信息填充到mt.tLOGFONT 清除EXCEL4背景
Private Sub InitializeX()
    
    
     Const SYSTEM_FONT = 13
     Const OEM_FIXED_FONT = 10
    
     mt.blnOldStatusBar = Application.DisplayStatusBar
     Application.DisplayStatusBar = True
     Application.StatusBar = ""
     '1、清除原字符2、令excel停止自动更新状态栏3、令excel加载原状态栏dc
    
     mt.hWndExcel4 = Excel4(Application.Caption)
    
     Application.StatusBar = ""
     '1、清除原字符2、令excel停止自动更新状态栏3、令excel加载原状态栏dc
    
     mt.hDcExcel4 = GetDC(mt.hWndExcel4)  'GetDCEx(hExcel4, 0, DCX_LOCKWINDOWUPDATE)  dc Excel4
    
     mt.hOldFont = SelectObject(mt.hDcExcel4, GetStockObject(SYSTEM_FONT))
     GetObject mt.hOldFont, Len(mt.tLOGFONT), mt.tLOGFONT
     ''获取原字体信息 将原字体信息存入tLOGFONT
    
     GetClientRect mt.hWndExcel4, mt.tRECTExcel4
     '采集excel4.rect
    
     Dim hBrush As Long
     hBrush = GetSysColorBrush(COLOR_BTNFACE)
     FillRect mt.hDcExcel4, mt.tRECTExcel4, hBrush
     DeleteObject hBrush
     '清除EXCEL4背景
    
End Sub

丸究阵引

GfWAwz04.rar (44.67 KB, 下载次数: 1538)

2007-8-25 10:21 上传

点击文件名下载附件
[原创] 状态栏进度条

DJFN

真不错，学习中，谢了

变成精华了！呵

Aeolian-Vox

下载学习。谢谢。

ldy888

[em17]牛人！！

下了学习。

abcd321abcd

谢谢提供，学习中。。。。。。

LWQHLWQH

请问如果状态栏中的文字同时显示进度百分比，又该如何更改代码？