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

ssPatriots

Member
Outlook version
Outlook 365 64 bit
Email Account
Office 365 Exchange
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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.


saving as pdf is possible -
 

ssPatriots

Member
Outlook version
Outlook 365 64 bit
Email Account
Office 365 Exchange
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

Member
Outlook version
Outlook 365 64 bit
Email Account
Office 365 Exchange
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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

Member
Outlook version
Outlook 365 64 bit
Email Account
Office 365 Exchange
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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


Code:
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

Member
Outlook version
Outlook 365 64 bit
Email Account
Office 365 Exchange
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
this should work- its the lazy way until I have a chance to do it right

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

ssPatriots

Member
Outlook version
Outlook 365 64 bit
Email Account
Office 365 Exchange
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
 
Similar threads
Thread starter Title Forum Replies Date
C Need VBA code to automatically save message outside outlook and add date Outlook VBA and Custom Forms 1
C In need of VBA code to read / parse HTML - Outlook emails Using Outlook 0
R [VBA] complicated(?) outlook events - need help with code Using Outlook 15
C Need Help with Simple Code Correction Using Outlook 11
R Need code to gather value of custom field on addressentry.details dialog box Using Outlook 3
R Need code snippet to read offline PST file Outlook VBA and Custom Forms 1
D Need help with MS Authenticator Using Outlook 4
I Outlook for Mac 2019 using on desktop and laptop IMAP on both need help with folders Using Outlook 1
FryW Need help modifying a VBA script for in coming emails to auto set custom reminder time Outlook VBA and Custom Forms 0
S.Champ Please help? I've imported a random workcalendar I dont even know who's. Can I undo it? and then I need to re-sync the google one again. Its a mess:( Using Outlook 2
B Need to Copy an email to a subfolder Outlook VBA and Custom Forms 2
D Do I need Exchange Add-In? Using Outlook 6
L Need help modifying a VBA script for emails stuck in Outbox Outlook VBA and Custom Forms 6
K Need to convert .mmf file to .pst format Outlook VBA and Custom Forms 7
glnz Moving from Outlook 2003 to MS365 Outlook - need basics Using Outlook 4
J Moved many emails to Outlook external folder, need to delete on Gmail server Using Outlook 14
A Wishlist Arthur workman I need the community's assistance thank you Using Outlook 3
A from Arthur to anyone I need your expertise assistance Using Outlook.com accounts in Outlook 7
Marc2019 Need help please! Cannot Setup my outlook email account on my Mac Outlook 2011 Using Outlook.com accounts in Outlook 2
T Need to backup outlook.com to cloud storage, without desktop software - Testing UpSafe. Are there any similar services? Using Outlook.com accounts in Outlook 8
C need help setting up outlook first time Using Outlook 1
N Need help syncing contacts to iPhone X Using Outlook 8
L Need to import multiple Outlook files to Office 365 Account Using Outlook 4
S Received mail as part of DL, need to auto-CC the same when replying Outlook VBA and Custom Forms 5
S Error using AddressEntry.GetContact - need help Outlook VBA and Custom Forms 2
E Outlook 2010 need help with rules Using Outlook 0
Horsepower Need iCloud mail only Using Outlook 1
O Don't need any add-ins at all? Using Outlook 2
B Need Help - Willing to pay Outlook VBA and Custom Forms 10
A Need to view Outlook calendar in Sharepoint .. Using Outlook 2
J Need Help with Contacts VBA Outlook VBA and Custom Forms 1
L Accidentally merged a calendar with .ics, need to undo! Using Outlook 1
H Need help setting up GetFolderPath-Makro with Vodafone IMAP Mail-Account Outlook VBA and Custom Forms 0
D Need Genuine Office or Outlook 2007 Using Outlook 3
G how to cancel a recurring meeting but not the organizer but all attendees need to know. Using Outlook 1
H I need a developer to customize an Outlook Contact form Outlook VBA and Custom Forms 0
T Need help with finding/updating task Outlook VBA and Custom Forms 1
N Need a case sensitive rule Outlook VBA and Custom Forms 1
C Need rule to alert when an email has not been replied to within 24 hours Using Outlook 1
P Outlook 2003 - Do I need a new profile? Using Outlook 2
F Outbox - Multiple Emails need to be manually opened? Using Outlook 5
Miquela I need to make a calendar to share here at work with 40 other people Using Outlook 1
S Need CC: to show the original To: recip[ients Using Outlook 4
Denis Hi everyone!!! Need some help with Excel to Exchange Calendar??PLEASE>>> Using Outlook 1
D Need to extract a line from a word attachment, and add it to the subject line Outlook VBA and Custom Forms 3
Mary B VBscript: Need to copy every email to a folder & mark that copy as read Outlook VBA and Custom Forms 5
mikecox Desperat; need hands on support Using Outlook 1
E Need Help on Setting up a repeated Reminder on Task with Reoccurence Every Year Using Outlook 6
Glyn Do I Need Outlook.com Using Outlook 1
B Need Help Creating Email Based on Subject w Address in Body Outlook VBA and Custom Forms 1

Similar threads

Top