View Full Version : [SOLVED] Progress Bar for macro

08-07-2017, 04:58 AM
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. 20017

08-07-2017, 06:18 AM
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
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!"
MsgBox "There Are No Attached Files In Your Mail.", vbInformation, "Finished!"
End If

Set atmt = Nothing
Set item = Nothing
Set ns = Nothing
Exit Sub

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)
MsgBox "Unable To Get The Name", vbExclamation
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

08-07-2017, 06:46 AM
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
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
Next iCurrent
End Sub

Sub Progress(pctCompl As Double)
ProgressBar.ProgressText.Caption = Format(pctCompl, "#0%") & " Completed"
ProgressBar.BarColor.Width = ProgressBar.BarBorder.Width * pctCompl
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

08-07-2017, 07:45 AM
A 'Progress Bar' only slows down your macro even further.
You'd better optimize your code so the performance will be instantaneous.