Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long

Private Const BIF_RETURNONLYFSDIRS = &H1

'************** Code Start **************
' This code was written by Brett Kinross with help from Outlookcode.com. Thanks to Sue Mosher
' for her book and help. Please note some of the code was written by Terry Kreft as acknowledged.
' Need to create a reference to the Microsoft Scripting Runtime library

'************** Code Start **************
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of
'Terry Kreft

Public Function BrowseFolder(szDialogTitle As String) As String
Dim X As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer

With bi
' .hOwner = hWndAccessApp - doesn't work with it but works without
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With

dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)

If X Then
wPos = InStr(szPath, Chr(0))
BrowseFolder = Left$(szPath, wPos - 1)
Else
BrowseFolder = vbNullString
End If
End Function
'*********** Code End *****************

Function IsFile(strPath As String) As Boolean
Dim oFileSystem As New Scripting.FileSystemObject

If (oFileSystem.FileExists(strPath)) Then
IsFile = True
Else
IsFile = False
End If
Set oFileSystem = Nothing

End Function

Sub Attachment()
Dim objApp As Outlook.Application
Dim objSelItem As Object
Dim objSelection As Selection
Dim Ans As Integer
Dim strPath As String
Dim strMsg As String

Set objApp = CreateObject("Outlook.Application")
Set objSelection = objApp.ActiveExplorer.Selection
numAttach = 0
If objSelection.Count = 0 Then
MsgBox "You have not selected any items. Please try again.", , "No items selected"
GoTo Exit_Attachment
End If
Ans = MsgBox("Would you like to save all the attachments to a folder? Note: If you click no attachments will be permanently removed.", vbYesNoCancel + vbQuestion, "Save attachments to folder...")
Select Case Ans
Case vbCancel
GoTo Exit_Attachment
Case vbYes
blnSaveAttach = True
strPath = BrowseFolder("Choose folder to save attachments to...")
If strPath = "" Then
MsgBox "Unable to complete as no folder chosen. Please try again.", , "Cancelled..."
GoTo Exit_Attachment
End If
For Each objSelItem In objSelection
Call RemoveAttachment(objSelItem, strPath)
Next
Case Else
Ans = MsgBox("Warning: About to permanently delete attachments. Do you want to procede?", vbYesNoCancel + vbCritical, "Permanently Delete Attachments...")
If Ans = vbYes Then
blnSaveAttach = False
For Each objSelItem In objSelection
Call RemoveAttachment(objSelItem)
Next
End If
End Select
Select Case blnSaveAttach
Case True
strMsg = numAttach & " attachments have been saved to the folder."
MsgBox strMsg, , "Process Completed..."
Case False
strMsg = numAttach & " attachments have been permanently removed."
MsgBox strMsg, , "Process Completed..."
End Select

Exit_Attachment:
Set objApp = Nothing
Set objSelItem = Nothing
Set objSelection = Nothing
Exit Sub
Err_Handler:
MsgBox "Error: " & Err.Description & " " & Err.Number, , "Error..."
GoTo Exit_Attachment
End Sub

Sub RemoveAttachment(objItem As Object, Optional strPath As String)
Dim objAtt As Outlook.Attachment
Dim intCount As Integer
Dim i As Integer
Dim strMsg As String
Dim intResAsk As Integer
Dim intResDel As Integer
Dim objSelItem As Object
Dim objApp As Outlook.Application
Dim objSelection As Selection
Dim strFPath As String
Dim strTemp As String
Dim num As Integer
Dim strOtherPath As String
Dim iStrL As Integer
Dim strLeft As String
Dim strRight As String

On Error GoTo Err_Handler

intCount = objItem.Attachments.Count
If intCount > 0 Then
If intCount = 1 Then
If blnSaveAttach = False Then
objItem.Attachments(1).Delete
numAttach = numAttach + 1
Else
strFPath = strPath & "\" & objItem.Attachments(1)
If IsFile(strFPath) = False Then
objItem.Attachments(1).SaveAsFile strFPath
objItem.Attachments(1).Delete
strTemp = "Attachment Removed: " & vbCrLf
objItem.Body = strTemp & objItem.Body
numAttach = numAttach + 1
Else
num = 1
Do
num = num + 1
iStrL = InStrRev(strFPath, ".") - 1
strLeft = Left(strFPath, iStrL)
strRight = Right(strFPath, Len(strFPath) - iStrL)
strOtherPath = strLeft & "(" & num & ")" & strRight
Loop While IsFile(strOtherPath) = True
strFPath = strOtherPath
objItem.Attachments(1).SaveAsFile strFPath
objItem.Attachments(1).Delete
strTemp = "Attachment Removed: " & vbCrLf
objItem.Body = strTemp & objItem.Body
numAttach = numAttach + 1
End If
End If
Else
For i = intCount To 1 Step -1
Set objAtt = objItem.Attachments(i)
strFPath = strPath & "\" & objAtt
If blnSaveAttach Then
If IsFile(strFPath) = False Then
objAtt.SaveAsFile strFPath
objAtt.Delete
strTemp = "Attachment Removed: " & vbCrLf
objItem.Body = strTemp & objItem.Body
numAttach = numAttach + 1
Else
num = 1
Do
num = num + 1
iStrL = InStrRev(strFPath, ".") - 1
strLeft = Left(strFPath, iStrL)
strRight = Right(strFPath, Len(strFPath) - iStrL)
strOtherPath = strLeft & "(" & num & ")" & strRight
Loop While IsFile(strOtherPath) = True
strFPath = strOtherPath
objAtt.SaveAsFile strFPath
objAtt.Delete
strTemp = "Attachment Removed: " & vbCrLf
objItem.Body = strTemp & objItem.Body
numAttach = numAttach + 1
End If
Else
objAtt.Delete
numAttach = numAttach + 1
End If
Next
End If
If objItem.Attachments.Count < intCount Then
objItem.Save
End If
End If
Exit_Procedure:
Set objAtt = Nothing
Exit Sub
Err_Handler:
MsgBox "Error: " & Err.Description & " " & Err.Number, , "Error..."
GoTo Exit_Procedure