彈出Excel狀態欄？

Question

我正在開發一個需要很長時間才能運行的excel應用程序，所以如果有一個進度條彈出並給出一些進度指示將會很好。我在看Excel中的Statusbar屬性，它似乎涵蓋了我需要的東西，除非它不是很明顯，即它是左下角的一個小小通知，如果我沒有預料到我不會注意到我覺得這不太令人滿意。

有沒有一種方法可以讓狀態欄在新的MsgBox樣式窗口中彈出，與您在Windows上進行文件傳輸時所期望的類似？實際顯示在excel表中的進度條類型對象（如this example）並不理想，我正在尋找更好的解決方案。

我在Windows上使用Office 2010。

Answer 1

我剛剛爲您創建了4個進度條。請選擇:)

餅圖進度條基於Stephen Bullen's PastePicture code。其餘的進度條很容易創建。我已附加了一個示例文件，您可以下載並測試。

FEW快照

CODE

在Userf ORM

Option Explicit 

Private Sub UserForm_Activate() 
    Dim i As Long, j As Long, k As Long, l As Long, m As Long 

    j = 0: k = 0: l = 500: m = 100 

    For i = 1 To 11 
     '~~> Pie Progressbar Stephen Bullen's PastePicture Function 
     Sheets("Sheet2").Shapes(i).CopyPicture 
     Set Me.Image1.Picture = PastePicture(xlPicture) 
     Me.Caption = "Progress - " & j & " %" 

     '~~> 2nd Progressbar 
     Label1.Width = k 
     Label1.BackColor = &HFF8080 
     TextBox1.Text = j & " %" 

     '~~> 3rd Progressbar 
     Select Case j 
      Case 10: CommandButton1.Visible = True 
      Case 20: CommandButton2.Visible = True 
      Case 30: CommandButton3.Visible = True 
      Case 40: CommandButton4.Visible = True 
      Case 50: CommandButton5.Visible = True 
      Case 60: CommandButton6.Visible = True 
      Case 70: CommandButton7.Visible = True 
      Case 80: CommandButton8.Visible = True 
      Case 90: CommandButton9.Visible = True 
      Case 100: CommandButton10.Visible = True 
     End Select 

     '~~> 4th Progressbar (Reverse) 
     Label2.Width = l 
     Label2.BackColor = &HC000& 
     TextBox2.Text = m & " % Left" 

     Wait 5 

     j = j + 10: k = k + 50 
     l = l - 50: m = m - 10 
    Next i 

    Unload Me 
End Sub 

Private Sub Wait(ByVal nSec As Long) 
    nSec = nSec + Timer 
    While nSec > Timer 
     DoEvents 
    Wend 
End Sub 

在一個模塊（斯蒂芬·布倫的PastePicture功能）

Option Explicit 

'*************************************************************************** 
'* 
'* MODULE NAME:  Paste Picture 
'* AUTHOR & DATE: STEPHEN BULLEN, Office Automation Ltd 
'*     15 November 1998 
'* 
'* CONTACT:   Stephen@oaltd.co.uk 
'* WEB SITE:  http://www.oaltd.co.uk 
'* 
'* DESCRIPTION:  Creates a standard Picture object from whatever is on the clipboard. 
'*     This object can then be assigned to (for example) and Image control 
'*     on a userform. The PastePicture function takes an optional argument of 
'*     the picture type - xlBitmap or xlPicture. 
'* 
'*     The code requires a reference to the "OLE Automation" type library 
'* 
'*     The code in this module has been derived from a number of sources 
'*     discovered on MSDN. 
'* 
'*     To use it, just copy this module into your project, then you can use: 
'*      Set Image1.Picture = PastePicture(xlPicture) 
'*     to paste a picture of whatever is on the clipboard into a standard image control. 
'* 
'* PROCEDURES: 
'* PastePicture The entry point for the routine 
'* CreatePicture Private function to convert a bitmap or metafile handle to an OLE reference 
'* fnOLEError  Get the error text for an OLE error code 
'*************************************************************************** 

Option Compare Text 

''' User-Defined Types for API Calls 

'Declare a UDT to store a GUID for the IPicture OLE Interface 
Private Type GUID 
    Data1 As Long 
    Data2 As Integer 
    Data3 As Integer 
    Data4(0 To 7) As Byte 
End Type 

'Declare a UDT to store the bitmap information 
Private Type uPicDesc 
    Size As Long 
    Type As Long 
    hPic As Long 
    hPal As Long 
End Type 

'''Windows API Function Declarations 

'Does the clipboard contain a bitmap/metafile? 
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long 

'Open the clipboard to read 
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long 

'Get a pointer to the bitmap/metafile 
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long 

'Close the clipboard 
Private Declare Function CloseClipboard Lib "user32"() As Long 

'Convert the handle into an OLE IPicture interface. 
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long 

'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates. 
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long 

'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates. 
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long 

'The API format types we're interested in 
Const CF_BITMAP = 2 
Const CF_PALETTE = 9 
Const CF_ENHMETAFILE = 14 
Const IMAGE_BITMAP = 0 
Const LR_COPYRETURNORG = &H4 

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
''' Subroutine: PastePicture 
''' 
''' Purpose: Get a Picture object showing whatever's on the clipboard. 
''' 
''' Arguments: lXlPicType - The type of picture to create. Can be one of: 
'''       xlPicture to create a metafile (default) 
'''       xlBitmap to create a bitmap 
''' 
''' Date  Developer   Action 
''' -------------------------------------------------------------------------- 
''' 30 Oct 98 Stephen Bullen  Created 
''' 15 Nov 98 Stephen Bullen  Updated to create our own copies of the clipboard images 
''' 

Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture 

'Some pointers 
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long 

'Convert the type of picture requested from the xl constant to the API constant 
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE) 

'Check if the clipboard contains the required format 
hPicAvail = IsClipboardFormatAvailable(lPicType) 

If hPicAvail <> 0 Then 
    'Get access to the clipboard 
    h = OpenClipboard(0&) 

    If h > 0 Then 
     'Get a handle to the image data 
     hPtr = GetClipboardData(lPicType) 

     'Create our own copy of the image on the clipboard, in the appropriate format. 
     If lPicType = CF_BITMAP Then 
      hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG) 
     Else 
      hCopy = CopyEnhMetaFile(hPtr, vbNullString) 
     End If 

     'Release the clipboard to other programs 
     h = CloseClipboard 

     'If we got a handle to the image, convert it into a Picture object and return it 
     If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType) 
    End If 
End If 

End Function 


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
''' Subroutine: CreatePicture 
''' 
''' Purpose: Converts a image (and palette) handle into a Picture object. 
''' 
'''    Requires a reference to the "OLE Automation" type library 
''' 
''' Arguments: None 
''' 
''' Date  Developer   Action 
''' -------------------------------------------------------------------------- 
''' 30 Oct 98 Stephen Bullen  Created 
''' 

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture 

' IPicture requires a reference to "OLE Automation" 
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture 

'OLE Picture types 
Const PICTYPE_BITMAP = 1 
Const PICTYPE_ENHMETAFILE = 4 

' Create the Interface GUID (for the IPicture interface) 
With IID_IDispatch 
    .Data1 = &H7BF80980 
    .Data2 = &HBF32 
    .Data3 = &H101A 
    .Data4(0) = &H8B 
    .Data4(1) = &HBB 
    .Data4(2) = &H0 
    .Data4(3) = &HAA 
    .Data4(4) = &H0 
    .Data4(5) = &H30 
    .Data4(6) = &HC 
    .Data4(7) = &HAB 
End With 

' Fill uPicInfo with necessary parts. 
With uPicInfo 
    .Size = Len(uPicInfo)             ' Length of structure. 
    .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture 
    .hPic = hPic               ' Handle to image. 
    .hPal = IIf(lPicType = CF_BITMAP, hPal, 0)        ' Handle to palette (if bitmap). 
End With 

' Create the Picture object. 
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic) 

' If an error occured, show the description 
If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r) 

' Return the new Picture object. 
Set CreatePicture = IPic 

End Function 

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
''' Subroutine: fnOLEError 
''' 
''' Purpose: Gets the message text for standard OLE errors 
''' 
''' Arguments: None 
''' 
''' Date  Developer   Action 
''' -------------------------------------------------------------------------- 
''' 30 Oct 98 Stephen Bullen  Created 
''' 

Private Function fnOLEError(lErrNum As Long) As String 

'OLECreatePictureIndirect return values 
Const E_ABORT = &H80004004 
Const E_ACCESSDENIED = &H80070005 
Const E_FAIL = &H80004005 
Const E_HANDLE = &H80070006 
Const E_INVALIDARG = &H80070057 
Const E_NOINTERFACE = &H80004002 
Const E_NOTIMPL = &H80004001 
Const E_OUTOFMEMORY = &H8007000E 
Const E_POINTER = &H80004003 
Const E_UNEXPECTED = &H8000FFFF 
Const S_OK = &H0 

Select Case lErrNum 
Case E_ABORT 
    fnOLEError = " Aborted" 
Case E_ACCESSDENIED 
    fnOLEError = " Access Denied" 
Case E_FAIL 
    fnOLEError = " General Failure" 
Case E_HANDLE 
    fnOLEError = " Bad/Missing Handle" 
Case E_INVALIDARG 
    fnOLEError = " Invalid Argument" 
Case E_NOINTERFACE 
    fnOLEError = " No Interface" 
Case E_NOTIMPL 
    fnOLEError = " Not Implemented" 
Case E_OUTOFMEMORY 
    fnOLEError = " Out of Memory" 
Case E_POINTER 
    fnOLEError = " Invalid Pointer" 
Case E_UNEXPECTED 
    fnOLEError = " Unknown Error" 
Case S_OK 
    fnOLEError = " Success!" 
End Select 

End Function 

樣本文件

https://www.dropbox.com/s/evqbp4c872h0pdj/progressbar%20example.xlsm?dl=0

Answer 2

約翰瓦爾肯巴赫在這裏有個不錯的選擇：http://spreadsheetpage.com/index.php/site/tip/displaying_a_progress_indicator/

這是很難得到它準確地反映了完成百分比是正在做的工作總量，但它顯示了進步，這可令您的用戶的Excel仍是活着的人中。進度條很少準確。