Hello,
I have a macro called GetEmailAttachments, which I use for downloading all attachments from Inbox to My Documents. I have also created a second one for the purpose of attachments from my Sub Folder. Problem is, that 2nd macro is not downloading all of the attachments from my Sub Folders and I wonder why is that. Additionally, is that possible to enhance the loop for the macro to search all Sub Folders within Sub Folder? Many thanks.
And here's the second macro (the one, which is not downloading all attachments)
I have a macro called GetEmailAttachments, which I use for downloading all attachments from Inbox to My Documents. I have also created a second one for the purpose of attachments from my Sub Folder. Problem is, that 2nd macro is not downloading all of the attachments from my Sub Folders and I wonder why is that. Additionally, is that possible to enhance the loop for the macro to search all Sub Folders within Sub Folder? Many thanks.
Code:
Option Explicit
'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
Dim x As Long
Dim pct As Single
ufProgress.LabelProgress.Width = 0
ufProgress.Show
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
itemsCount = Inbox.Items.Count
If itemsCount = 0 Then
ufProgress.hide
MsgBox "There are no valid 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 Email " & x & " Of " & itemsCount
.LabelProgress.Width = pct * (.FrameProgress.Width)
End With
DoEvents
'=====================
For Each atmt In Item.Attachments
If Right(atmt.fileName, 3) = "pdf" Or Right(atmt.fileName, 3) = "jpg" And atmt.Size > 45000 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
Next Item
If i > 0 Then
MsgBox "There are " & i & " attached files found." & vbCrLf & "They were saved into the Email Attachments folder in My Documents.", vbInformation, "Finished!"
Else
MsgBox "There are no attached files in your Inbox.", vbInformation, "Finished!"
End If
GetAttachments_exit:
Set atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
'Use On Error Resume Next as some of the attachments types might be causing an error
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
And here's the second macro (the one, which is not downloading all attachments)
Code:
Option Explicit
'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 GetEmailAttachments2()
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
Dim x As Long
Dim pct As Single
Dim SubFolder As MAPIFolder
Dim OutlookFolderInInbox As String
ufProgress.LabelProgress.Width = 0
ufProgress.Show
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(olFolderInbox)
i = 0
itemsCount = SubFolder.Items.Count
If itemsCount = 0 Then
ufProgress.hide
MsgBox "There are no messages in the Sub Folders.", vbInformation, "Nothing Found"
Exit Sub
End If
For Each Item In SubFolder.Items
'>> Added This Portion
'=====================
x = x + 1
pct = x / itemsCount
With ufProgress
.LabelCaption.Caption = "Processing Email " & x & " Of " & itemsCount
.LabelProgress.Width = pct * (.FrameProgress.Width)
End With
DoEvents
'=====================
For Each atmt In Item.Attachments
If Right(atmt.fileName, 3) = "pdf" Or Right(atmt.fileName, 3) = "jpg" And atmt.Size > 45000 Then
If fileName = "" Then
Call CreateFolder2
End If
fileName = MyDocs2() & Item.SenderName & " " & atmt.fileName
atmt.SaveAsFile fileName
i = i + 1
End If
Next atmt
If x = itemsCount Then Unload ufProgress
Next Item
If i > 0 Then
MsgBox "There are " & i & " attached files found." & vbCrLf & "They were saved into the Email Attachments folder in My Documents.", vbInformation, "Finished!"
Else
MsgBox "There are no attached files in your Inbox.", vbInformation, "Finished!"
End If
GetAttachments_exit:
Set atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
'Use On Error Resume Next as some of the attachments types might be causing an error
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 MyDocs2() 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 SubFolders\"
MyDocs2 = strStart & strUser & strEnd
End Function
Private Sub CreateFolder2()
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 SubFolders"
If Not fs.FolderExists(destFolder) Then
fs.CreateFolder destFolder
End If
End If
End Sub