L
Legacy 397974
Guest
Hello, I have a macro called GetEmailAttachments, which I use for the purpose of downloading email attachments from my Inbox in Outlook. This macro is working fine and I received all attachments, however I have created the 2nd macro called GetEmailAttachments2 for the purpose of downloading items from the SubFolders. Problem is that the macro is only downloading only part of the attachments from sub folder and I wonder why is that.
I was also wondering is it possible to loop into sub folders of sub folders in Outlook? Will that require additional loop in the code? I'd appreciate some help with this case. Thanks.
Here's the code:
And the 2nd one:
I was also wondering is it possible to loop into sub folders of sub folders in Outlook? Will that require additional loop in the code? I'd appreciate some help with this case. Thanks.
Here's the code:
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 SubAnd the 2nd one:
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
