Create new folder (on hard drive), and save email to it - Using a listbox / combobox

[ashleyuk1984]

Create new folder (on hard drive), and save email to it - Using a listbox / combobox - Userform might be needed?

Hi,
I have the following code which works perfectly fine as it is... However, I've discovered a problem with it, when it comes to the beginning of a new month.

This is the code:

Sub OpenAndSave()

Dim strNewFolderName As String
Dim save_to_folder As String

strNewFolderName = InputBox("Input Reference Number - For Example 12345")

If Len(Dir("C:\Work Folder\Customer Folder\April 13\" & strNewFolderName, vbDirectory)) = 0 Then
MkDir ("C:\Work Folder\Customer Folder\April 13\" & strNewFolderName)

End If

save_to_folder = "C:\Work Folder\Customer Folder\April 13\" & strNewFolderName

For Each olkMsg In Outlook.ActiveExplorer.Selection
olkMsg.Display
olkMsg.SaveAs save_to_folder & "\" & olkMsg.Subject & ".msg"
olkMsg.Close olDiscard

Next

Set olkMsg = Nothing

End Sub

This code is assigned to a button on my toolbar. Once the button is pressed, it asks me for a reference number... Which then a folder is created - with the reference number that I entered.
Then the email, is saved within that folder.

The problem is.... At the beginning of this month, I was getting jobs that needed to be saved in both March, and April... Which caused a problem with this code, as the code is set for April.

So.... I was thinking, and I have thought of a solution - but I have no idea how to make it happen? :-(

Instead of having the month in the code above, how about if that was removed... and was replaced by a "list" (userform) that would pop up... And the selection in the list was a list of all the months.
When I select the correct month, it would then place the new folder, inside that selected month. I hope that makes sense.

For example, instead of the code looking like this:

save_to_folder = "C:\Work Folder\Customer Folder\April 13\" & strNewFolderName

It would look like this, and it would take the value from the userform:

save_to_folder = "C:\Work Folder\Customer Folder\" & USERFORM_VALUE & "\" & strNewFolderName

I'm pretty sure that would be the easiest solution... I just don't know how to program userforms :-(
Between the two, listbox and combobox... I think I would prefer a listbox.
If you could provide the code for BOTH, that would be excellent, as then I could see which one looked better.

Another solution, would be to simply create another "input box", and manually type the month in... However, it would leave the door open to simple mistypes.

Thank You.

[skatonni]

Try implementing this

http://www.vbaexpress.com/kb/getarticle.php?kb_id=303

[skatonni]

Not what you asked for but you may find this works. You wil find the subject of an email will not necessarily be a valid file name.


Sub OpenAndSave()

Dim save_to_folder As String
Dim strFileName As String

Dim olkObj As Object
Dim olkMsg As MailItem

Dim intCounter As Long

save_to_folder = BrowseForFolder("C:\Work Folder\Customer Folder")

For Each olkObj In Outlook.ActiveExplorer.Selection
If olkObj.Class = olMail Then
Set olkMsg = olkObj
'olkMsg.Display

' Cleanse illegal characters from subject... :/|*?"
' Specific substititions
strFileName = Trim(Replace(olkMsg.Subject, ":", ";"))
strFileName = Replace(strFileName, "", "(")
strFileName = Replace(strFileName, "", ")")
strFileName = Replace(strFileName, """", "'")

' Catch-all for the rest
For intCounter = 1 To Len(strFileName)
If InStr(1, "/|*?", Mid(strFileName, intCounter, 1)) > 0 Then
Mid(strFileName, intCounter, 1) = "-"
End If
Next

olkMsg.SaveAs path:=save_to_folder & "\" & strFileName & ".txt", Type:=olTXT
'olkMsg.Close olDiscard

End If

Next

Set olkMsg = Nothing

End Sub

Private Function BrowseForFolder(Optional OpenAt As Variant) As Variant
' http://www.vbaexpress.com/kb/getarticle.php?kb_id=284
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename (file://servername/sharename). All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False

End Function