Need code to allow defined starting folder and selection from there to drill down

[ssPatriots]

Hi,

I'm new to this forum. I came here because I found Diane Poremsky's code called "SaveMessagesAndAttachments" and need to see if it can be tweaked to allow me to start with a defined file path and once the dialog box opens, give me the opportunity to drill down a couple folders form there to place all the files that are created. Ideally, I would like to have the Outlook "msg" file saved as a "pdf" in stead of "msg". I realize this is a lot, but I've been tinkering with the code since Friday and keep coming up empty. Thanks in advance for any help I can get on this.

Cross posted in this forum, because I didn't know this forum existed at the time.

Public Sub SaveMessagesAndAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim StrFile As String
Dim StrName As String
Dim strTime 'As String
Dim StrFolderPath As String

Dim FSO As Object
Dim oldName

Set FSO = CreateObject("Scripting.FileSystemObject")

On Error Resume Next
Set objOL = Outlook.Application
Set objMsg = objOL.ActiveExplorer.Selection.Item(1)

' remove illegal characters and shorten name
StrName = StripIllegalChar(objMsg.Subject)
StrName = Left(StrName, 40)

strTime = DateValue(objMsg.ReceivedTime) '& TimeValue(objMsg.ReceivedTime)

' I use this to reduce changes of duplicate names
strTime = Format(objMsg.ReceivedTime, "-hhmmss")
Debug.Print strTime
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
Debug.Print strFolderpath
On Error Resume Next
StrFolderPath = StrFolderPath & "\Attachments\" & StrName & strTime & "\"

' create folder if doesn't exist
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If

' Save message and as html and doc file type
objMsg.SaveAs StrFolderPath & StrName & ".msg", olMsg
objMsg.SaveAs StrFolderPath & StrName & ".doc", olRTF
objMsg.SaveAs StrFolderPath & StrName & ".htm", olHTML

'save any attachments also
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count

If lngCount > 0 Then

For i = lngCount To 1 Step -1

StrFile = objAttachments.Item(i).FileName
Debug.Print StrFile
StrFile = StrFolderPath & StrFile
objAttachments.Item(i).SaveAsFile StrFile

Next i
End If

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

 

[Diane Poremsky]

You need to use a folder picker if you want to browse. I have a sample here - you can browse down from the starting folder but not browse up.

How to use Windows File Paths in a Macro

How to choose the file path when you save an Outlook attachment or a message using a VBA macro.

www.slipstick.com

saving as pdf is possible -

Save Outlook Email as a PDF

How to use VBA to save selected Outlook messages as PDF files.

www.slipstick.com

 

[ssPatriots]

Wow, you are genius at this!!! I also took the second code "Save Outlook as a PDF" and inserted your bit about using the "StrFolderPath" in lieu of "MyDocs" and add the "Dim StrFolderPath As String" and it worked like a charm. I putting it in this reply below. Again, thank you so much. I think I will set this up to run the "Save Outlook as a PDF" first and offer a Yes/No message box to give the user the option to save their attachments.

Sub SaveMessageAsPDF()

Dim Selection As Selection
Dim obj As Object
Dim Item As MailItem

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
Set Selection = Application.ActiveExplorer.Selection

For Each obj In Selection

Set Item = obj

Dim FSO As Object, TmpFolder As Object
Dim sName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set tmpFileName = FSO.GetSpecialFolder(2)

sName = Item.Subject
ReplaceCharsForFileName sName, "-"
tmpFileName = tmpFileName & "\" & sName & ".mht"

Item.SaveAs tmpFileName, olMHTML


Set wrdDoc = wrdApp.Documents.Open(Filename:=tmpFileName, Visible:=True)

Dim WshShell As Object
Dim SpecialPath As String
Dim strToSaveAs As String
Dim StrFolderPath As String
Set WshShell = CreateObject("WScript.Shell")
MyDocs = WshShell.SpecialFolders(16)



' Get the BrowseForFolder function How to use Windows File Paths in a Macro
StrFolderPath = BrowseForFolder("D:\My Stuff\Email Attachments\")

strToSaveAs = StrFolderPath & "\" & sName & ".pdf"

' check for duplicate filenames
' if matched, add the current time to the file name
If FSO.FileExists(strToSaveAs) Then
sName = sName & Format(Now, "hhmmss")
strToSaveAs = MyDocs & "\" & sName & ".pdf"
End If

wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strToSaveAs, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, From:=0, To:=0, Item:= _
wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False

Next obj
wrdDoc.Close
wrdApp.Quit
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set WshShell = Nothing
Set obj = Nothing
Set Selection = Nothing
Set Item = Nothing

End Sub

' This function removes invalid and other characters from file names
Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
sName = Replace(sName, "&", sChr)
sName = Replace(sName, "%", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, " ", sChr)
sName = Replace(sName, "{", sChr)
sName = Replace(sName, "[", sChr)
sName = Replace(sName, "]", sChr)
sName = Replace(sName, "}", sChr)
sName = Replace(sName, "!", sChr)
End Sub

 

[ssPatriots]

Sorry, I have one more question. You have the "check for duplicate filenames" in the "SaveMessageAsPDF" code. How would I make that work in the "SaveAttachmentstoFolder" code? I tried adding the bit below from the "SaveMessageAsPDF" code, but it doesn't seem to do anything. I even added the "Set FSO = CreateObject("Scripting.FileSystemObject")" part before the place I inserted the code to look for duplicates.

' check for duplicate filenames
' if matched, add the current time to the file name
If FSO.FileExists(StrFile) Then

StrFile = StrFolderPath & "\" & StrFile & "-" & Format(Now, "hhmmss")
objAttachments.Item(i).SaveAsFile StrFile

End If

 

[Diane Poremsky]

Do you get any error messages? if you have any error handlers - on error resume next for example, comment it out so error comes up.

 

[ssPatriots]

Do you get any error messages? if you have any error handlers - on error resume next for example, comment it out so error comes up.

It skips right over the part where it checks to see if the file exist in the folder.

If FSO.FileExists(StrFile) Then

StrFile = StrFolderPath & "\" & StrFile & "-" & Format(Now, "hhmmss") <------Skips this line
objAttachments.Item(i).SaveAsFile StrFile <------Skips this line as well.

End If

Public Sub SaveAttachmentstoFolder()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim StrFile As String
Dim strPath As String
Dim StrFolderPath As String
Dim strDeletedFiles As String
Dim sFileType As String


Dim FSO As Object, TmpFolder As Object
Dim sName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set tmpFileName = FSO.GetSpecialFolder(2)

'On Error Resume Next

Set objOL = CreateObject("Outlook.Application")
Set objMsg = objOL.ActiveExplorer.Selection.Item(1)

' Get the BrowseForFolder function http://slipstick.me/u1a2d
StrFolderPath = BrowseForFolder("G:\Delaware\PROJECTS\")


Set objAttachments = objMsg.Attachments



lngCount = objAttachments.Count

If lngCount > 0 Then

For i = lngCount To 1 Step -1

StrFile = objAttachments.Item(i).Filename
'StrFile = StrFolderPath & "\" & StrFile


' check for duplicate filenames
' if matched, add the current time to the file name
If FSO.FileExists(StrFile) Then

StrFile = StrFolderPath & "\" & StrFile & "-" & Format(Now, "hhmmss")
objAttachments.Item(i).SaveAsFile StrFile

End If



StrFile = StrFolderPath & "\" & StrFile




objAttachments.Item(i).SaveAsFile StrFile

Next i
End If

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

 

[Diane Poremsky]

This part half works - the file extension needs fixed - the initial code had a bad path -
C:\Delaware\PROJECTS\C:\Delaware\PROJECTS\Package from Amazon.ics-001836

The code below fixes the path - but the extension needs fixed. I have code samples on slipstick that fix it but its past my bedtime - i;ll look at it tomorrow.

C:\Delaware\PROJECTS\Package from Amazon.ics-002034

If lngCount > 0 Then

For i = lngCount To 1 Step -1

StrFile = objAttachments.Item(i).Filename
StrFile = StrFolderPath & "\" & StrFile

' check for duplicate filenames
' if matched, add the current time to the file name
If FSO.FileExists(StrFile) Then
  StrFile = StrFile & "-" & Format(Now, "hhmmss")
Debug.Print StrFile

End If

objAttachments.Item(i).SaveAsFile StrFile

Next i
End If

ExitSub:

 

[ssPatriots]

I see what you are saying about the extension and I think I even found the code you have on slipstick. I played with it for while and just made it worse, than where I started.

 

[Diane Poremsky]

this should work- its the lazy way until I have a chance to do it right

If FSO.FileExists(StrFile) Then
strFile = Format(Now, "hhmmss") & objAttachments.Item(i).FileName
StrFile = StrFolderPath & "\" & StrFile

 

[ssPatriots]

Thank you, I will give it a try

 

[ssPatriots]

Makes sense, I can probably just put that time stamp and add a date in front of all the attachments in that case in order to sort easily by date/time. Thanks