VBATools

Ten prosty przykład uzmysłowi wam jak działa pasek postępu. Elementarnym czynnikiem jest określenie wartości maksymalnej dla paska. W czasie przekazywania kolejnych parametrów, wartość paska będzie “dochodzić” do tej wartości.

Poniżej można znaleźć kod, który otwiera w zadeklarowanym katalogu pliki jakie spełniają określony warunek. Użyta w kodzie metoda FSO pozwala na przekazanie nazwy kolejnego pliku w pętli. Pliki są otwierane i zamykane bez zapisu. Parametr .value jest przekazywany.

Oto prosty przykład jak działa pasek postępu.

rys 1. Pasek postępu przypisany do otwieranych kolejno plików.

Option Explicit
Private Sub UserForm_Initialize()
'Taki sposób nie jest dobry ponieważ kod zacznie działać zanim forma się wyświetli
'Call test_4progres
End Sub

Private Sub CommandButton1_Click()
'to jest dobry sposób - wymuszenie przyciskiem
Call test_4progres
End Sub

Private Sub UserForm_Activate()
'to jest dobry sposób - zadziała zaraz po wywołaniu formy
Call test_4progres
End Sub

Sub test_4progres()
'MVP OShon from VBATools.pl
Const sciezka$ = "C:\Temp"
Dim ob As Object, pliki As Object, plik As Object
Dim folder As Object, r&

Set ob = CreateObject("Scripting.FilesystemObject")
Set folder = ob.GetFolder(sciezka)
Set pliki = ob.GetFolder(folder).Files

ProgressBar1.Value = 0 'zerujemy pasek
ProgressBar1.Max = 9   'określamy maximum postępu, a może być też wyliczony pliki.count 

With Application
 .ScreenUpdating = False
 .EnableEvents = False
 .Calculation = xlCalculationManual
 .DisplayAlerts = False
 For Each plik In pliki
  DoEvents 'kluczowy parametr dzięki któremu będziemy widzieć postęp paska
  If Mid(LCase(plik), InStrRev(plik, ".") + 1, 3) = "xls" Then
    Workbooks.Open Filename:=(sciezka & plik.Name) 'otwieramy tylko pliki XLS, które możemy sprawdzić też tak ob.GetExtensionName(plik)
    ProgressBar1.Value = r 'przekazujemy kolejny parametr
    r = r + 1
    ActiveWorkbook.Close False 'wychodzimy bez zapisu
    If r = 10 Then GoTo przerwij 'albo Exit For jako dupochron
  End If
 Next plik
przerwij:
 .ScreenUpdating = True
 .Calculation = xlCalculationAutomatic
 .EnableEvents = True
End With

Set ob = Nothing 'można też spotkać opinie że zerowanie obiektów nie jest konieczne
Set folder = Nothing
Set pliki = Nothing
End Sub

Taką metodę można zastosować w Excelu, Outlooku, jak i w innych aplikacjach pakietu Office. Opis innych kontrolek i przykłady ich zastosowania znajdziesz tutaj.

(c) Shon Oskar – www.VBATools.pl