點擊「保存資料」按鈕後顯示進度條

by chijanzen on 七月 20th, 2008 | View: 1,536 views

Tags

excel

Comments (0)

索引	H0011
主題	點擊“保存資料”按鈕後顯示進度條
版本	>= 10.0(Office 2002)
說明	當使用者點擊“保存資料”按鈕後本範例依程序執行的順序分別規劃了5個階段的進度條百分比,再依各階段的需求各自細分百分比
參考

Code

Sub UpdateProgress(Pct)
    With UserForm1
        .FrameProgress.Caption = Format((Pct / 100), "0%")
        .LabelProgress.Width = (Pct / 100) * (.FrameProgress.Width - 10)
        .Repaint
    End With
End Sub
　

Code

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetSysColor Lib "user32" ( _
        ByVal nIndex As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
        ByVal hwnd As Long, _
        ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" ( _
        ByVal hwnd As Long) As Long
　

Private Sub UserForm_activate()
    Dim nam As String, dat As Date, rng As Range
    Dim iR As Integer, p As Double, n As Integer
    Me.Label1.Caption = "正在保存數據，請稍後...."
    Application.ScreenUpdating = False
    Set rng = Range("C2:C200")
    If [G2] <> "" And [H2] <> "" And Application.WorksheetFunction. _
       CountA(rng) > 0 Then
        nam = [G2]
        dat = [H2]
        With Sheet5
            Set lstcel = .[c65536].End(xlUp).Offset(1, 0)
            iR = lstcel.Row
            Call UpdateProgress(10)    '第一階段 10%
            rng.Copy lstcel
            rng.Offset(0, -1).Copy
            lstcel.Offset(0, 1).PasteSpecial Paste:=xlValues, _
                                Operation:=xlNone, SkipBlanks:= _
                    False, Transpose:=False
            Call UpdateProgress(20)     '第二階段 10%
            rng.Offset(0, -2).Copy
            lstcel.Offset(0, -1).PasteSpecial Paste:=xlValues, _
                                 Operation:=xlNone, SkipBlanks:= _
                    False, Transpose:=False
            Call UpdateProgress(30)     '第三階段 10%

Application.CutCopyMode = False
p = 40 / (.[c65536].End(xlUp).Row - iR + 1) '第四階段 40%

            For i = .[c65536].End(xlUp).Row To iR Step -1
                n = n + 1
                Call UpdateProgress(30 + (p * n))
                If .Cells(i, 3) = "" Then .Rows(i).Delete
            Next
            n = 0
            p = 30 / (.[c65536].End(xlUp).Row - iR + 1)   '第五階段 30%
            For i = iR To .[c65536].End(xlUp).Row
                n = n + 1
                Call UpdateProgress(70 + (p * n))
                .Cells(i, 1) = i - 9
                .Cells(i, 8) = dat
                .Cells(i, 9) = nam
            Next
        End With
    End If
    Sleep 1000   '1秒
    Unload Me
    Application.ScreenUpdating = True
End Sub
　

Private Sub UserForm_Initialize()
    Me.Label1.BackColor = GetSysColor(5)
    Dim hndMe&
    hndMe = FindWindow(vbNullString, Me.Caption)
    SetWindowLong hndMe, -16, &H84080080    '去標頭
    SetWindowLong hndMe, -20, &H40000  '去外框
    DrawMenuBar hndMe
End Sub
　