I want my emails saved to different folders on my hard drive based on what the email is about. Some emails should be saved in two or more folders.
The designated hard drive folders are created as they should, and files are saved with the right filenames, but all emails are saved in all folders.
If there is only one keyword from one 'category' present in the mail body. It seems like the script somehow 'remembers' the previously found keywords, even in the following If-Then statements - resulting in the email being saved in all folders.
I have edited the code based on your comments. It now gives
error 450: Wrong number of arguments.
Private WithEvents InboxItems As Outlook.Items
Option Explicit
Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Set xNameSpace = Outlook.Application.Session
Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
'Define variables
Dim FSO
Dim xFilePath As String
Dim xFilePathAgro As String
Dim xFilePathGras As String
Dim xFilePathIndustrie As String
Dim xFilePathActief As String
Dim xFilePathOppTech As String
Dim xMailItem As Outlook.MailItem
Dim xRegEx
Dim xFileName As String
'Create directories if not existing
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
xFilePathAgro = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePathAgro = xFilePath & "\WBSO 13-01A Agro-reststromen"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePathAgro) = False Then
FSO.CreateFolder (xFilePathAgro)
End If
xFilePathGras = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePathGras = xFilePath & "\WBSO 13-01B Grassen"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePathGras) = False Then
FSO.CreateFolder (xFilePathGras)
End If
'Change filenames of emails to save
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?" 'Is vereist om de onderwerptitel op te nemen in bestandsnaam
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = xRegEx.Replace(xMailItem.Subject, "")
xFileName = xRegEx.Replace(xMailItem.Subject, ":", "")
xFileName = xRegEx.Replace(xMailItem.Subject, "/", "_")
xFileName = xRegEx.Replace(xMailItem.Subject, "\", "")
xFileName = xRegEx.Replace(xMailItem.Subject, "<", "")
xFileName = xRegEx.Replace(xMailItem.Subject, ">", "")
xFileName = xRegEx.Replace(xMailItem.Subject, ";", "")
xFileName = Format(xMailItem.ReceivedTime, "YYYYMMDD hhmm") & " " & xFileName
'saving emails that contain the searchwords in the right folders
If InStr(1, xMailItem.Body, "Agro", vbTextCompare) > 0 Then
MsgBox "Opgeslagen in Agro"
'xMailItem.SaveAs xFilePathAgro & "\" & xFileName & ".msg"
End If
If InStr(1, xMailItem.Body, "Gras", vbTextCompare) > 0 Then
MsgBox "opgeslagen in Gras"
'xMailItem.SaveAs xFilePathGras & "\" & xFileName & ".msg"
End If
End If
End Sub
Related
I would like to find a way to save selected Outlook emails using a UNC path to a shared drive as a .msg file.
I have code that does exactly what I am looking to do (below), however it uses a folder picker, and I would just like to hard-code the UNC path instead
Example "\\ent.core.company.com\emails\".
Public Sub SaveMessageAsMsg123() 'This works, but with folder picker
'http://www.vbaexpress.com/forum/showthread.php?64358-Saving-Multiple-Selected-Emails-As-MSG-Files-In-Bulk-In-Outlook
Dim xShell As Object
Dim xFolder As Object
Dim strStartingFolder As String
Dim xFolderItem As Object
Dim xMail As MailItem
Dim xObjItem As Object
Dim xPath As String
Dim xFileName As String
Dim xName As String
Dim xDtDate As Date
Set xShell = CreateObject("Shell.Application")
''Set xFolder = CreateObject("WScript.Shell").specialfolders(16)
On Error Resume Next
' Bypass error when xFolder is nothing on Cancel
Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, strStartingFolder)
'' xFolder = "\\ent.core.company.com\emails\"
'Remove error bypass as soon as the purpose is served
On Error GoTo 0
Debug.Print xFolder
If Not TypeName(xFolder) = "Nothing" Then
Set xFolderItem = xFolder.Self
xFileName = xFolderItem.Path
' missing path separator
If Right(xFileName, 1) <> "\" Then xFileName = xFileName & "\"
Else
xFileName = ""
Exit Sub
End If
For Each xObjItem In ActiveExplorer.Selection
If xObjItem.Class = olMail Then
Set xMail = xObjItem
xName = CleanFileName(xMail.Subject)
Debug.Print xName
xDtDate = xMail.ReceivedTime
xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(xDtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & xName & ".msg"
xPath = xFileName & xName
xMail.SaveAs xPath, olMsg
End If
Next
End Sub
Public Function CleanFileName(strFileName As String) As String
' http://windowssecrets.com/forums/sho...Charaters-(VBA)
Dim Invalids
Dim e
Dim strTemp As String
Invalids = Array("?", "*", ":", "|", "<", ">", "[", "]", """", "/")
strTemp = strFileName
For Each e In Invalids
strTemp = Replace(strTemp, e, " ")
'strTemp = Replace(strTemp, e, "")
Next
CleanFileName = strTemp
End Function
I figured it out!
Public Sub SaveMessageAsMsg
Dim xShell As Object
Dim xFolder As Object
Dim strStartingFolder As String
Dim xFolderItem As Object
Dim strFolderpath As String
Dim xMail As MailItem
Dim xObjItem As Object
Dim xPath As String
Dim xFileName As String
Dim xName As String
Dim xDtDate As Date
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").specialfolders(16)
' Instantiate an Outlook Application object.
Set objOL = Application
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = "\\ent.core.medtronic.com\mit-msp01\CVG US Field Inventory\Lookup_Data\TransportationDelayEmails\"
xFileName = strFolderpath
' missing path separator
If Right(xFileName, 1) <> "\" Then xFileName = xFileName & "\"
For Each xObjItem In ActiveExplorer.Selection
If xObjItem.Class = olMail Then
Set xMail = xObjItem
xName = CleanFileName(xMail.Subject)
Debug.Print xName
xPath = xFileName & xName
xMail.SaveAs xPath & ".msg" ', olMsg ' & ".msg"
End If
Next
End Sub
This is my code for this task. The issue is with the invalid characters in Windows. I can replace them fine on files but on folders in doesn't seem to work.
Dim xFSO As Scripting.FileSystemObject
Sub CopyOutlookFldStructureToWinExplorer()
ExportAction "Copy"
End Sub
Sub ExportAction(xAction As String)
Dim xFolder As Outlook.Folder
Dim xFldPath As String
xFldPath = SelectAFolder()
If xFldPath = "" Then
MsgBox "You did not select a folder. Export cancelled.", vbInformation + vbOKOnly, "Kutools for Outlook"
Else
Set xFSO = New Scripting.FileSystemObject
Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder
ExportOutlookFolder xFolder, xFldPath
End If
Set xFolder = Nothing
Set xFSO = Nothing
End Sub
Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String)
Dim xSubFld As Outlook.Folder
Dim xItem As Object
Dim xPath As String
Dim xFilePath As String
Dim xSubject As String
Dim xFilename As String
On Error Resume Next
xPath = xFldPath & "\" & OutlookFolder.Name
'?????????,??????
If Dir(xPath, 16) = Empty Then MkDir xPath
For Each xItem In OutlookFolder.Items
xItem = ReplaceInvalidCharacters(xItem.Item)
xSubject = ReplaceInvalidCharacters(xItem.Subject)
xSubFld = ReplaceInvalidCharacters(xItem.SubFld)
xFldPath = ReplaceInvalidCharacters(xItem.FldPath)
xPath = ReplaceInvalidCharacters(xItem.Path)
xSubject = ReplaceInvalidCharacters(xItem.Subject)
xFilename = xSubject & ".msg"
xFilename = ReplaceInvalidCharacters(xItem.FileName)
xFilePath = xPath & "\" & xFilename
xFilePath = ReplaceInvalidCharacters(xItem.FilePath)
If xFSO.FileExists(xFilePath) Then
xCounter = xCounter + 1
xFilename = xSubject & " (" & xCounter & ").msg"
xFilePath = xPath & "\" & xFilename
xFilePath = ReplaceInvalidCharacters(xItem.FilePath)
End If
xItem.SaveAs xFilePath, olMSG
Next
For Each xSubFld In OutlookFolder.Folders
ExportOutlookFolder xSubFld, xPath
Next
Set OutlookFolder = Nothing
Set xItem = Nothing
End Sub
Function SelectAFolder() As String
Dim xSelFolder As Object
Dim xShell As Object
On Error Resume Next
Set xShell = CreateObject("Shell.Application")
Set xSelFolder = xShell.BrowseForFolder(0, "Select a folder", 0, 0)
If Not TypeName(xSelFolder) = "Nothing" Then
SelectAFolder = xSelFolder.self.Path
End If
Set xSelFolder = Nothing
Set xShell = Nothing
End Function
Function ReplaceInvalidCharacters(Str As String) As String
Dim xRegEx
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
ReplaceInvalidCharacters = xRegEx.Replace(Str, "_")
End Function
Always use Option Explicit at the very top of every module, before any function. This will tell you if you have not Dim'med any variables. In this case there is an issue with xCount and xCounter, which should have only one name.
I think the problem may come from the function ExportOutlookFolder, this line:
xPath = xFldPath & "\" & OutlookFolder.Name
Try replacing it with:
xPath = xFldPath & "\" & ReplaceInvalidCharacters(OutlookFolder.Name)
I have the following VBA code macro to save all selected e-mails in .msg format to any folder but it doesn't save emails with meeting invitations. How do I also save mails with meeting invitations? Do I have to include any special objects? Below is the code that I am using to save the e-mails in .msg format:
Option Explicit
Public Sub SaveMessageAsMsg()
Dim xShell As Object
Dim xFolder As Object
Dim strStartingFolder As String
Dim xFolderItem As Object
Dim xMail As MailItem
Dim xObjItem As Object
Dim xPath As String
Dim xFileName As String
Dim xName As String
Dim xDtDate As Date
Set xShell = CreateObject("Shell.Application")
On Error Resume Next
' Bypass error when xFolder is nothing on Cancel
Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, strStartingFolder)
' Remove error bypass as soon as the purpose is served
On Error GoTo 0
If Not TypeName(xFolder) = "Nothing" Then
Set xFolderItem = xFolder.Self
xFileName = xFolderItem.Path
' missing path separator
If Right(xFileName, 1) <> "\" Then xFileName = xFileName & "\"
Else
xFileName = ""
Exit Sub
End If
For Each xObjItem In ActiveExplorer.Selection
If xObjItem.Class = olMail Then
Set xMail = xObjItem
xName = Left(CleanFileName(xMail.Subject), 100)
Debug.Print xName
xDtDate = xMail.ReceivedTime
xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & "-" & xName & ".msg"
xPath = xFileName & xName
xMail.SaveAs xPath, olMSG
End If
Next
End Sub
Public Function CleanFileName(strFileName As String) As String
Dim Invalids
Dim e
Dim strTemp As String
Invalids = Array("?", "*", ":", "|", "<", ">", "[", "]", """", "/", "\")
strTemp = strFileName
For Each e In Invalids
strTemp = Replace(strTemp, e, " ")
'strTemp = Replace(strTemp, e, "")
Next
CleanFileName = strTemp
End Function
In the code posted above only mail items are handled:
If xObjItem.Class = olMail Then
There are various object types in Outlook, see OlObjectClass enumeration for more information.
Basically, you need to handle also meeting items:
Dim xMail As Object
If xObjItem.Class = olMail Or xObjItem.Class = olMeetingRequest Then
I have the following code to save emails from Outlook to a folder on the desktop.
I would like to name the files with the email subjects exactly the way they are in Outlook. I do not want to strip any characters.
I have played around with the macro but I can't fix it. Also would like to remove the time stamp date etc.
Option Explicit
Dim StrSavePath As String
Sub SaveAllEmails_ProcessAllSubFolders()
Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrReceived As String
Dim StrFolder As String
Dim StrSaveFolder As String
Dim StrFolderPath As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
'GoTo ExitSub:
End If
BrowseForFolder StrSavePath
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & "\" & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\#\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, _
StoreID As Collection, Fld As MAPIFolder)
Dim SubFolder As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(StrSavePath As String, _
Optional OpenAt As String) As String
Dim objShell As Object
Dim objFolder ' As Folder
Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", _
0, enviro & "C:\Temp\Folders")
StrSavePath = objFolder.self.Path
On Error Resume Next
On Error GoTo 0
ExitFunction:
Set objShell = Nothing
End Function
an alternative approach if you absolutely want to retain the original email unaltered is to create a new email message to yourself with the original email saved as an attachment. Save the new email with a corrected subject to avoid windows naming errors, it will retain a link to the unaltered original.
It's a few extra steps but you should be able to automate those if you insist on retaining the original email unaltered.
Its bad idea like Tim said, but if that is what you want to do then modify your j loop to something like this...
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrSubject = mItem.Subject
StrSubject = StrSaveFolder & StrSubject & ".msg"
mItem.SaveAs StrSubject, 3
Next j
Good Luck...
Closed. This question does not meet Stack Overflow guidelines. It is not currently accepting answers.
This question does not appear to be about a specific programming problem, a software algorithm, or software tools primarily used by programmers. If you believe the question would be on-topic on another Stack Exchange site, you can leave a comment to explain where the question may be able to be answered.
Closed 7 years ago.
Improve this question
I am curious to know how to move emails from a specific subfolder to my hard drive. Basically, my inbox has about 20 subfolders. I want to be able to move all the emails from subfolder1 to my hard drive.
Is there a macro to specifically go to that folder and move all the emails onto my hard drive? Granted I do want to keep all the emails in .msg rather than being a .txt file.
I bielive you can develop a VBA macro or add-in to get the job done. See Getting Started with VBA in Outlook 2010 to get started.
The SaveAs method of the MailItem class saves the Microsoft Outlook item to the specified path and in the format of the specified file type. If the file type is not specified, the MSG format (.msg) is used. The file type to save can be one of the following OlSaveAsType constants: olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT, olVCal, olVCard, olICal, or olMSGUnicode. For example:
Sub SaveAsMSG()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".msg", olMSG
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
This should allow you to select outlook folder and hard drive folder, All emails in that folder and all sub folders will be saved to your HD
Option Explicit
Sub SaveMsgToFolders()
Dim i, j, n As Long
Dim sSubject As String
Dim sName As String
Dim sFile As String
Dim sReceived As String
Dim sPath As String
Dim sFolder As String
Dim sFolderPath As String
Dim SaveFolder As String
Dim Prompt As String
Dim Title As String
Dim iNameSpace As NameSpace
Dim olApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim olmItem As MailItem
Dim FSO, ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set olApp = Outlook.Application
Set iNameSpace = olApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder ' // Chose Outlook Folder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"
sPath = BrowseForFolder
If sPath = "" Then
GoTo ExitSub:
End If
If Not Right(sPath, 1) = "\" Then
sPath = sPath & "\"
End If
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
sFolder = StripIllegalChar(Folders(i))
n = InStr(3, sFolder, "\") + 1
sFolder = Mid(sFolder, n, 256)
sFolderPath = sPath & sFolder & "\"
SaveFolder = Left(sFolderPath, Len(sFolderPath) - 1) & "\"
If Not FSO.FolderExists(sFolderPath) Then
FSO.CreateFolder (sFolderPath)
End If
Set SubFolder = olApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set olmItem = SubFolder.Items(j)
sReceived = ArrangedDate(olmItem.ReceivedTime)
sSubject = olmItem.Subject
sName = StripIllegalChar(sSubject)
sFile = SaveFolder & sReceived & "_" & sName & ".msg"
sFile = Left(sFile, 256)
olmItem.SaveAs sFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\#\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Function ArrangedDate(sDateInput)
Dim sFullDate As String
Dim sFullTime As String
Dim sAMPM As String
Dim sTime As String
Dim sYear As String
Dim sMonthDay As String
Dim sMonth As String
Dim sDay As String
Dim sDate As String
Dim sDateTime As String
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
If Not Left(sDateInput, 2) = "10" And _
Not Left(sDateInput, 2) = "11" And _
Not Left(sDateInput, 2) = "12" Then
sDateInput = "0" & sDateInput
End If
sFullDate = Left(sDateInput, 10)
If Right(sFullDate, 1) = " " Then
sFullDate = Left(sDateInput, 9)
End If
sFullTime = Replace(sDateInput, sFullDate & " ", "")
If Len(sFullTime) = 10 Then
sFullTime = "0" & sFullTime
End If
sAMPM = Right(sFullTime, 2)
sTime = sAMPM & "-" & Left(sFullTime, 8)
sYear = Right(sFullDate, 4)
sMonthDay = Replace(sFullDate, "/" & sYear, "")
sMonth = Left(sMonthDay, 2)
sDay = Right(sMonthDay, Len(sMonthDay) - 3)
If Len(sDay) = 1 Then
sDay = "0" & sDay
End If
sDate = sYear & "-" & sMonth & "-" & sDay
sDateTime = sDate & "_" & sTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(sDateTime, "-")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
Dim SubFolder As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select
ExitFunction:
Set ShellApp = Nothing
End Function