Progress Bar for macro

[geomano]

Hi, I have a macro called GetAttach in Module1 of attached workbook, for which I'd like to have progress bar indicating the macro progress. I have already added the user form, but I am quite unsure on how to assign this ProgressBar to my macro. I'd appreciate some help, thanks. workbook.xlsm

[YasserKhalil]

Hello
I have created new workbook and copied your code and added some lines to make progress bar work on your file
I have deleted all comments and added new comments '>> Added at those lines added to the code

'References : Microsoft Outlook 16.0 Object Library
'--------------------------------------------------


Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Const NoError = 0


Sub GetEmailAttachments()
    On Error Resume Next


    Dim ns              As Namespace
    Dim inbox           As MAPIFolder
    Dim item            As Object
    Dim atmt            As Attachment
    Dim fileName        As String
    Dim i               As Long
    Dim itemsCount      As Long                 '>> Added
    Dim x               As Long                 '>> Added
    Dim pct             As Single               '>> Added
    
    ufProgress.LabelProgress.Width = 0          '>> Added
    ufProgress.Show                             '>> Added




    Set ns = GetNamespace("MAPI")
    Set inbox = ns.GetDefaultFolder(olFolderInbox)
    i = 0
    itemsCount = inbox.Items.Count              '>> Added


    If itemsCount = 0 Then
        MsgBox "There Are No Messages In The Inbox.", vbInformation, "Nothing Found"
        Exit Sub
    End If
    
    For Each item In inbox.Items
        '>> Added This Portion
        '=====================
        x = x + 1
        pct = x / itemsCount
        
        With ufProgress
            .LabelCaption.Caption = "Processing Row " & x & " Of " & itemsCount
            .LabelProgress.Width = pct * (.FrameProgress.Width)
        End With
        DoEvents
        '=====================
        For Each atmt In item.Attachments
            If Right(atmt.fileName, 3) = "xls" Or Right(atmt.fileName, 3) = "pdf" Or Right(atmt.fileName, 3) = "txt" Then
                If fileName = "" Then
                    Call CreateFolder
                End If


                fileName = MyDocs() & item.SenderName & " " & atmt.fileName
                atmt.SaveAsFile fileName
                i = i + 1
            End If
        Next atmt


        If x = itemsCount Then Unload ufProgress  '>> Added
    Next item


    If i > 0 Then
        MsgBox "There Are " & i & " Attached Files." & vbCrLf & "They Were Saved Into The Email Attachments Folder In My Documents.", vbInformation, "Finished!"
    Else
        MsgBox "There Are No Attached Files In Your Mail.", vbInformation, "Finished!"
    End If
    
GetAttachments_exit:
    Set atmt = Nothing
    Set item = Nothing
    Set ns = Nothing
    Exit Sub


GetAttachments_err:
    MsgBox "An Unexpected Error Has Occurred." _
         & vbCrLf & "Please Note And Report The Following Information." _
         & vbCrLf & "Macro Name: GetEmailAttachments" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume GetAttachments_exit
End Sub


Function GetUserName()
    Const lpnLength     As Integer = 255
    Dim status          As Integer
    Dim lpName          As String
    Dim lpUserName      As String


    lpUserName = Space$(lpnLength + 1)
    status = WNetGetUser(lpName, lpUserName, lpnLength)


    If status = NoError Then
        lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
    Else
        MsgBox "Unable To Get The Name", vbExclamation
        End
    End If
    
    GetUserName = lpUserName
End Function


Function MyDocs() As String
    Dim strStart        As String
    Dim strEnd          As String
    Dim strUser         As String


    strUser = GetUserName()
    strStart = "C:\Documents and Settings\"
    strEnd = "\My Documents\Email Attachments\"


    MyDocs = strStart & strUser & strEnd
End Function


Private Sub CreateFolder()
    Dim wsh             As Object
    Dim fs              As Object
    Dim destFolder      As String
    Dim myDocPath       As String


    If destFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        
        myDocPath = wsh.SpecialFolders.item("mydocuments")
        destFolder = myDocPath & "\Email Attachments"
        
        If Not fs.FolderExists(destFolder) Then
            fs.CreateFolder destFolder
        End If
    End If
End Sub

Hope that helps you

[Paul_Hossler]

In addition, I just added the bare bones code to show the methods behind a progress bar.
I wasn't sure where you wanted to measure progress, so I just did a simple driver

In standard module

Option Explicit

Sub Driver()
Dim iCurrent As Long, iTotal As Long, j As Integer, pctCompl As Double
Sheet1.Cells.Clear
Load ProgressBar
ProgressBar.Show vbModeless
iTotal = 137
For iCurrent = 1 To iTotal
     For j = 1 To 1000
         Cells(iCurrent, 1).Value = j
     Next j
     pctCompl = CDbl(iCurrent) / iTotal
     Progress pctCompl
     ProgressBar.Repaint
Next iCurrent
End Sub

Sub Progress(pctCompl As Double)
 ProgressBar.ProgressText.Caption = Format(pctCompl, "#0%") & " Completed"
 ProgressBar.BarColor.Width = ProgressBar.BarBorder.Width * pctCompl
 DoEvents
End Sub

Added to Userform

Private Sub UserForm_Initialize()

ProgressBar.BarColor.Top = ProgressBar.BarBorder.Top
ProgressBar.BarColor.Left = ProgressBar.BarBorder.Left
ProgressBar.BarColor.Height = ProgressBar.BarBorder.Height
Progress 0

End Sub

Edited to show another concept / idea about varying max and real % completes

[snb]

A 'Progress Bar' only slows down your macro even further.
You'd better optimize your code so the performance will be instantaneous.