Sorry, I'm using Outlook 2003 and the security mode is "Default".
When I ran my code it prompted me to enable macros and I ticked
"Always trust from this publisher" box.
My code is as follows which is copied straight into a macro into the
"ThisOutlookSession" section...
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260
' *** Add a REFERENCE to MICROSOFT SHELL CONTROlS AND AUTOMATION for
the directory browser
Function BrowseFolder(Optional Caption As String, _
Optional InitialFolder As String) As String
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Dim WshShell As Object
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS,
InitialFolder)
Set WshShell = CreateObject("WScript.Shell")
If Not F Is Nothing Then
'Special folders don't always return their full path that is
why we check the title first
Select Case F.Title
Case "Desktop"
BrowseFolder = WshShell.SpecialFolders("Desktop")
Case "My Documents"
BrowseFolder = WshShell.SpecialFolders("MyDocuments")
Case "My Computer"
MsgBox "Invalid selection", vbCritical + vbOKOnly,
"Error"
Exit Function
Case "My Network Places"
MsgBox "Invalid selection", vbCritical + vbOKOnly,
"Error"
Exit Function
Case Else
BrowseFolder = F.Items.Item.Path
End Select
End If
'Cleanup
Set SH = Nothing
Set F = Nothing
Set WshShell = Nothing
End Function
Sub FileEmails_Click()
' This uses an existing instance if available (default Outlook
behavior).
Dim oApp As New Outlook.Application
Dim oExp As Outlook.Explorer
Dim oSel As Outlook.Selection ' You need a selection
object for getting the selection.
Dim oItem As Object ' You don't know what type
it is yet
Dim oMail As Outlook.MailItem ' Holds the email
Dim oAttachment As Outlook.Attachment ' Holds the email
attachment
Dim strMsgName As String ' Holds name of msessage
Dim strFileName As String ' Holds name of any
attachments
Dim strDir As String ' Holds the directory to
save the items
Set oExp = oApp.ActiveExplorer ' Get the ActiveExplorer.
Set oSel = oExp.Selection ' Get the selection.
' Set initial directory
'strDir = "C:\"
strDir = "\\W2kserver\rtt data\NewCo\PROJECTS"
' Make the user the folder selection dialog
Dim FolderPath As String
FolderPath = BrowseFolder("Select destination folder for emails",
strDir)
If FolderPath = "" Then
Response = MsgBox("Please select a folder. No items were
saved", vbExclamation, MyApplName)
Exit Sub
End If
For i = 1 To oSel.Count ' Loop through all the
currently .selected items
Set oItem = oSel.Item(i) ' Get a selected item.
'DisplayInfo oItem
Set oMailItem = oItem
strMsgName = Mid(oMailItem.ReceivedTime, 7, 2) & "-" &
Mid(oMailItem.ReceivedTime, 4, 2) & "-" & Mid(oMailItem.ReceivedTime,
1, 2) & " [" & Right(oMailItem.ReceivedTime, 8) & "]" & " - FROM; " &
oMailItem.SenderName & " - " & oMailItem.Subject ' Create a unique
name for the message
strMsgName = Replace(strMsgName, ":", "")
strMsgName = Replace(strMsgName, "/", "-")
If oMailItem.Attachments.Count > 0 Then
For Each oAttachment In oMailItem.Attachments
'Set oAttachment = oMailItem.Attachments
strFileName = strMsgName & " [Filename] " &
oAttachment
oAttachment.SaveAsFile "" & FolderPath & "\" &
strFileName & ""
Next oAttachment
strMsgName = strMsgName & " [" &
oMailItem.Attachments.Count & " attachment(s)]"
End If
strMsgName = strMsgName & ".msg"
oMailItem.SaveAs "" & FolderPath & "\" & strMsgName & ""
Next i
MsgBox "Filing Complete!", vbOKOnly, "Done!" ' Inform user
proceedure is finished
End Sub
