Option Explicit
Public strFolders As String
'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 z As Long
Dim itemsCount As Long
Dim x As Long
Dim pct As Single
Dim SubFolder As MAPIFolder
Dim OutlookFolderInInbox As String
Dim olStartFolder As Outlook.MAPIFolder
Dim olSession As Outlook.NameSpace
Dim olApp As Outlook.Application
Dim lCountOfFound As Long
Dim olNewFolder As Outlook.MAPIFolder
Dim olTempFolder As Outlook.MAPIFolder
Dim olTempFolderPath As String
Dim CurrentFolder As Outlook.MAPIFolder
Dim olCount As Long
lCountOfFound = 0
i = 0
itemsCount = olTempFolder.Items.Count
Set olApp = New Outlook.Application
Set olSession = olApp.GetNamespace("MAPI")
Set SubFolder = olSession.PickFolder
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
'Set SubFolder = Inbox.Folders(olFolderInbox)
'ufProgress.LabelProgress.Width = 0
'ufProgress.Show
For z = SubFolder.Folders.Count To 1 Step -1
Set olTempFolder = SubFolder.Folders(z)
olTempFolderPath = olTempFolder.FolderPath
' Get the count of items in the folder
z = 0
olCount = SubFolder.Folders(z).Items.Count
For Each olTempFolder In SubFolder.Folders
For Each Item In olTempFolder.Items
'>> Added This Portion
'=====================
'x = x + 1
'pct = x / itemsCount
'With ufProgress
'.LabelCaption.Caption = "Processing Email " & x & " Of " & olCount
'.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 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
Next Item
lCountOfFound = lCountOfFound + 1
Next
Next
'If x = itemsCount Then Unload ufProgress
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 Sub Folders.", vbInformation, "Finished!"
End If
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
