I am working on generating OFT files that will be e-mailed to customers who will then fill the To: and Subject: in and send them as e-mails to their clients.
My data comes from an Excel Workbook with one sheet containing static data (Books) and another information pasted in by the user (Pins). I've got a basic template that has placeholder text which gets replaced by the data in the aforementioned Excel sheets.
One important part of this is that I need the changed template to get saved to it's own file, so it can be stored for reference later. Originally I had the code below setup to open the template and call .SaveAs myFilename, olTemplate but that just made a broken 3KB file. You will notice I am copying the template to the actual destination file and operating on that instead.
My problem is that if I have the template item call .Display, everything is perfect. I see my image in the right place and all of the text is properly replaced. If I call .Save it saves out a copy of the original OFT template with no changes present.
Can anyone tell me what I'm doing wrong here? I've been searching here and google for hours trying to find some indication of what I'm missing. I'm trying to automate this thing as much as possible. Resaving the new OFT with Outlook's UI is a real time sink for a coworker and I'd like to eliminate that if possible. They're going to be generating dozens of these OFTs every day, so the work seems worth it in my opinion.
UPDATE
I have managed to get this to work but the solution feels like a half-answer. The code below has been updated with changes that properly save the OFT.
Here is my sub:
Sub OutlookTemplate(ByVal pins As Range, ByVal book As Range, ByVal ImageLocation As String)
Dim myolapp As Object
Dim myItem As Object
Set myolapp = CreateObject("Outlook.Application")
'myolapp.Session.Logon
For Each p In pins.Cells
If Not IsEmpty(p.Value) Then
Dim myFilename As String
myFilename = "c:\temp\" & Worksheets("PINS").Range("A2") & "-" & p.Value & ".oft"
FileCopy "c:\template.oft", myFilename
Set myItem = myolapp.CreateItemFromTemplate(myFilename)
myItem.Save <- Added immediate save after creation of myItem
myItem.Attachments.Add ImageLocation, olByValue, 0
myItem.HTMLBody = Replace(myItem.HTMLBody, "THEIMAGE", "<img src='cid:" & book.Cells(2).Value & "'" & "width='154'>")
myItem.HTMLBody = Replace(myItem.HTMLBody, "PINHERE", p.Value)
myItem.HTMLBody = Replace(myItem.HTMLBody, "THETITLE", book.Cells(1).Value)
myItem.HTMLBody = Replace(myItem.HTMLBody, "THESUBTITLE", book.Cells(3).Value)
myItem.HTMLBody = Replace(myItem.HTMLBody, "THEAUTHORS", book.Cells(4).Value)
myItem.HTMLBody = Replace(myItem.HTMLBody, "THEDESCRIPTION", book.Cells(5).Value)
' Leaving the next line off results in a broken image
' when .SaveAs is called
myItem.Display
' This saves all of the changes out to the file properly
' in combination with .Display
' Note: if I call myItem.SaveAs myFilename, olTemplate
' I get the 3KB broken OFT. Omitting ,olTemplate works
myItem.SaveAs myFilename
End If
Next
End Sub
The Save method doesn't propagate changes to the .oft file. It saves the Microsoft Outlook item to the current folder or, if this is a new item, to the Outlook default folder for the item type.
Try to open the existing .oft file without copying it anywhere. Then do the required changes and call the SaveAs method to save it as a template wherever you need.
Related
We will put 100s of Excel worksheets out in the field this year. The code periodically needs to be updated when bugs are found. For last year's effort, I was able to dynamically have workbooks pull updates for .bas files. This year I want to dynamically have workbooks pull updates for the code embedded in the worksheets too.
EXPORT CODE
The export code is pretty simple, but there are artifacts in the .txt files
Sub SaveSoftwareFile(path$, name$, ext$)
ThisWorkbook.VBProject.VBComponents(name).Export path & name & ext
Example Call: SaveSoftwareFile path, "ThisWorkbook", ".txt"
The problem is that the export has a lot of header information that I don't care about (in red). I just want the part in blue. Is there switch that allows me not to save it, or do I have to manually go into the export and remove it myself?
IMPORT CODE
The import code is pretty straight forward too, but it causes the error "Can't enter break mode at this time", and I'm struggling to figure out the right path forward. If I manually try and delete this code, Excel is also unhappy. So maybe my approach is altogether incorrect. Here's the code:
Sub UpgradeSoftwareFile(path$, name$, ext$)
Dim ErrorCode%, dest As Object
On Error GoTo errhandler
Select Case ThisWorkbook.VBProject.VBComponents(name).Type
Case 1, 3 'BAS, FRM
<Not relevant for this discussion>
Case 100 'Worksheets
Set dest = ThisWorkbook.VBProject.VBComponents(name).codemodule
dest.DeleteLines 1, dest.CountOfLines 'Erase existing | Generates breakpoint error
dest.AddFromFile path & name & ext '| Also generates breakpoint error
End Select
Example Call: UpgradeSoftwareFile path, "ThisWorkbook", ".txt"
Thanks in advance for your help
Please, try the next way of exporting and you will not have the problem any more:
Sub SaveSoftwareFile(path$, sheetCodeModuleName$, FileName$)
Dim WsModuleCode As String, sCM As VBIDE.CodeModule, strPath As String, FileNum As Long
Set sCM = ThisWorkbook.VBProject.VBComponents(sheetCodeModuleName).CodeModule
WsModuleCode = sCM.Lines(1, sCM.CountOfLines)
'Debug.Print WsModuleCode
strPath = ThisWorkbook.path & "\" & FileName
FileNum = FreeFile
Open strPath For Output As #FileNum
Print #FileNum, WsModuleCode
Close #FileNum
End Sub
You can use the above Sub as following:
Sub testSaveSheetCodeModule()
Dim strPath As String, strFileName As String, strCodeModuleName As String
strPath = ThisWorkbook.path
strFileName = "SheetCode_x.txt"
strCodeModuleName = Worksheets("Test2").codename 'use here your sheet name
SaveSoftwareFile strPath, strCodeModuleName, strFileName
End Sub
Now, the created text file contains only the code itself, without the attributes saved by exporting the code...
Import part:
"Can't enter break mode at this time" does not mean that it is an error in the code. There are some operations (allowed only if a reference to Microsoft Visual Basic for Applications Extensibility ... exists) in code module manipulation, which cannot simple be run step by step. VBA needs to keep references to its VBComponents and it looks, it is not possible when changes in this area and in this way are made.
The import code is simple and it must run without problems. You must simple run the code and test its output...
The code below is used in other files to send in effect a form for review and approval, but within this workbook for some reason I am getting blank files sent and the content added by the users is lost. I know this isn't a code checking service, but I was wondering have I missed something with this - so I need to have the file 'saved' before it is attached to the e-mail?
'Open e-mail and create a new message
Set OutlookApp = CreateObject("Outlook.Application")
Set OlObjects = OutlookApp.GetNamespace("MAPI")
Set newmsg = OutlookApp.CreateItem(olMailItem)
Dim SubmitEMail As String: SubmitEMail = ws.Range("U1").Value
' set the requirements for the new message
With newmsg
.Recipients.Add SubmitEMail
.CC = ws.Range("U2").Value
.Subject = "New Concession request form submitted"
'use string defined above as the main body of the message
.Body = "Dear " & Location & "," & vbLf & vbLf & "Please find attached: a new Concession request. Please review and indicate Concession number, or provide details of amendments needed." & vbLf & vbLf & "Regards," & vbLf & vbLf & SenderName
.Attachments.Add wb.FullName
.Display
End With
End If
MsgBox "Please review the E-Mail, Adding any additional recipients as required. add your signature and send to complete the submission"
The e-mail sending bit works perfectly, but the attachment is always blank, the data the user has added is lost (if the user saves the workbook first on their local station) the process works perfectly, but I am wanting to avoid asking them to so this - potentially creates 2 versions of a document where I only want one)
If you debug your sub and use Debug.Print wb.FullName without saving wb - you'll get only "Book(n)" name. For your case I may suggest following solution:
Dim fileName As String
' save to temp directory
wb.SaveAs Environ("TEMP") & wb.Name & ".xlsx"
' save the full name to string variable
fileName = wb.FullName
' close the file in order to be able to delete it
wb.Close
'[attach the file
'.Attachments.Add fileName
' and do other stuff you need]
' delete temporary file
Kill fileName
This will also allow you to avoid asking users to save file and they even won't know about this.
You need a saved Workbook to attach. If you want to make sure there are no unneeded duplicates, you can do the following:
Save a copy of the workbook in a temp folder (with SaveCopyAs)
attach this copy to the email and display
delete the copy in the temp folder
We have some Report template documents in Word that are linked to template excel documents with various OLE linked objects from Excel to Word.
Since OLE uses absolute paths vs. relative, copy pasting the two documents to another location (or even moving them) breaks the OLE links.
So, what's the best way to facilitate moving the documents to another location AND moving the Word template and being able to link it to another Excel document in the new location?
I've searched through numerous sites and found some solutions for technical people:
http://www.msofficeforums.com/word/38722-word-fields-relative-paths-external-files.html
https://answers.microsoft.com/en-us/msoffice/forum/all/making-excel-links-in-word-portable-ie-relative/8f67c68e-6406-4ef2-9b97-4d96c43dcb2c,
BUT this needs to be easy enough for non-technical people to use.
I would like to be able to copy and paste BOTH documents (the Word template AND the linked Excel template) to a new location and have them work the same way they did in the original location.
I would also like to be able to copy just the Word template to a new location and link it to an Excel template in that new location.
I ended up writing a solution to a problem that I had a difficult time finding an answer for, so I wanted to share what ended up working for me.
The code looks in the working directory of the word document, finds the first excel document (I only have 1 excel file per folder in my job, so this setup works for me), and changes the source of all OLE objects in the word document to match the excel document, which makes it possible to create a word/excel template pair and move them to different locations.
*NOTE: I've used Windows sepecific objects/functions for I/O, i.e. MyFile, MyFSO, MyFolder... etc., but I don't think it would be terribly difficult to make the I/O platform agnostic.
**NOTE: I also haven't really added any error checking as it's a quick and dirty macro that's used internally to facilitate portability AND I've never used vba before, so garbage cleanup etc. was a just kind of thrown in there, if there's a way to refactor everything and clean it up, please let me know.
Sub UpdateWordLinks()
Dim newFilePath As Variant
Dim excelDocs As Variant
Dim range As Word.range
Dim shape As shape
Dim section As Word.section
excelDocs = GetFileNamesbyExt(ThisDocument.Path, ".xlsx")
'The new file path as a string (the text to replace with)'
newFilePath = ThisDocument.Path & Application.PathSeparator & excelDocs(1)
Call updateFields(ThisDocument.fields, newFilePath)
For Each section In ThisDocument.Sections
Call updateHeaderFooterLinks(section.headers, newFilePath)
Call updateHeaderFooterLinks(section.Footers, newFilePath)
Next
'Update the links
ThisDocument.fields.Update
Set newFilePath = Nothing
Set excelDocs(1) = Nothing
Set excelDocs = Nothing
Set range = Nothing
Set shape = Nothing
Set section = Nothing
End Sub
Function GetFileNamesbyExt(ByVal FolderPath As String, FileExt As String) As Variant
Dim Result As Variant
Dim i As Integer
Dim MyFile As Object
Dim MyFSO As Object
Dim MyFolder As Object
Dim MyFiles As Object
Set MyFSO = CreateObject("Scripting.FileSystemObject")
Set MyFolder = MyFSO.GetFolder(FolderPath)
Set MyFiles = MyFolder.Files
ReDim Result(1 To MyFiles.count)
i = 1
For Each MyFile In MyFiles
If InStr(1, MyFile.Name, FileExt) <> 0 Then
Result(i) = MyFile.Name
i = i + 1
End If
Next MyFile
ReDim Preserve Result(1 To i - 1)
GetFileNamesbyExt = Result
Set MyFile = Nothing
Set MyFSO = Nothing
Set MyFolder = Nothing
Set MyFiles = Nothing
End Function
Function updateHeaderFooterLinks(headersFooters As headersFooters, newFilePath As Variant)
Dim headerFooter As Word.headerFooter
For Each headerFooter In headersFooters
Call updateFields(headerFooter.range.fields, newFilePath)
Next
Set headerFooter = Nothing
End Function
Function updateFields(fields As fields, newFilePath As Variant)
Dim field As field
Dim oldFilePath As Variant
For Each field In fields
If field.Type = wdFieldLink Then
oldFilePath = field.LinkFormat.SourceFullName
field.Code.Text = Replace(field.Code.Text, _
Replace(oldFilePath, "\", "\\"), _
Replace(newFilePath, "\", "\\"))
End If
Next
Set field = Nothing
Set oldFilePath = Nothing
End Function
It works for me by allowing me to copy paste either both a word and excel file together to a new location and run the macro, or by allowing me to copy paste the word document only and run the macro to link it to an excel doc in the new location.
**I should also note that I only needed to look in the body and header/footer stories for the links we use, so this code is not as robust as it could be, but I don' think it would be too tough to add another loop or two to cover off any missing stories
Cheers!
If you are still looking for a way to create portable links between Excel and Word, our Excel-to-Word Document Automation Add-in may help. Unlike native linking through Office you can: rename files, copy/paste and reorganize content, share the linked files, etc. The same Excel document can update multiple destination Word and/or PowerPoint report templates. You only need to set up the links once and they can be updated numerous times. I hope this helps, you can find out more at https://analysisplace.com/Document-Automation
I have been searching for a way to distribute macros to my tech illiterate office in the simplest way I can.
From my research, saving the Macros into a .xlam add-in would seem to be headed in the right direction.
Is it also possible to set up a custom ribbon tab in this manner?
Thus far I have failed to find any guides and our office security may also block certain avenues.
Edit:
Using W-Hit's excellent solution, and setting up the folder structure as indicated, it definitely helps make deploying an update much easier with the DeployAddIn subroutine.
I also found it useful to put the DeployAddIn and InstallAddin subroutines into a custom ribbon tab of their own!
I ran into a problem with the InstallAddin subroutine however: how to format the XML text in VBA without running into syntax errors.
I discovered that Each Element must have mso at the start e.g. <button> becomes <mso:button> and each "speech marked section" in a line must have ""double speech marks".
Perhaps the easiest way to use this install function is to save and edit the code into an active file, then open C:\Users[username]\AppData\Local\Microsoft\Office\Excel.officeUI in Notepad++. Then simply perform a find and replace to add in the extra quotation marks and paste it into the ribbonXML = "insert your text here" section of the code, ensuring it is encapsulated by the final speech marks to mark the entire section as a text string.
I might also look into adding extra functionality here... having an inputbox or userform that allows you to paste the code in at this point rather than have you enter the VBA editor to paste it in.
I currently do this, and it's a somewhat in depth process to setup, but runs smoothly once it is.
1st step is to create a folder structure with testing and production copies of your .xlam files that you are the admin for.
2nd, in the production folder, right click all .xlam files and set the attributes in the properties to Read-only. If you don't you'll never be able to update the addin if anyone else is in it.
3rd, when you make updates to the code in the testing file, just replace the production file with the updated file, and change to Read-only again. Users will only have to close all instances of excel and reopen to have the most up-to-date copy of the add-in.
Below is an admin add-in I use to move testing files to production.
Sub DeployAddIn()
'Author : Ken Puls (www.excelguru.ca)
'Macro Purpose: To deploy finished/updated add-in to a network
' location as a read only file
Dim strAddinDevelopmentPath As String
Dim strAddinPublicPath As String
Dim FSO As New FileSystemObject
'Set development path
ChDrive "R:"
ChDir "R:\addins\PROJECTS"
strAddinDevelopmentPath = Application.GetOpenFilename()
If strAddinDevelopmentPath = "False" Then
Exit Sub
ElseIf InStr(strAddinDevelopmentPath, "\PRODUCTION\") > 1 Then
If MsgBox("You've Selected a Production File To Replace a Production File. Would You Like To Continue Anyway?", vbYesNo) = vbNo Then
Exit Sub
End If
End If
'Get Desitination path
strAddinPublicPath = Replace(strAddinDevelopmentPath, "TESTING", "PRODUCTION")
'Create dir if it doesn't exist
On Error Resume Next
MkDir Left(strAddinPublicPath, InStrRev(strAddinPublicPath, "\") - 1)
On Error GoTo 0
'Turn off alert regarding overwriting existing files
Application.DisplayAlerts = False
'overwrite existing file
On Error Resume Next
SetAttr strAddinPublicPath, vbNormal
On Error GoTo 0
FSO.CopyFile strAddinDevelopmentPath, strAddinPublicPath, True
SetAttr strAddinPublicPath, vbReadOnly
'Resume alerts
Application.DisplayAlerts = True
End Sub
4th, I've also written a macro to change the custom ribbon. The below link, in addition Ron deBruin's site is useful. https://grishagin.com/vba/2017/01/11/automatic-excel-addin-installation.html
Code to automate addin install after you get the right text from the officeUI file
Sub InstallAddin()
'Adapted from https://grishagin.com/vba/2017/01/11/automatic-excel-addin-installation.html
Dim eai As Excel.AddIn
Dim alreadyinstalled As Boolean
Dim ribbonXML As String
'check if already installed
For Each eai In Application.AddIns
If eai.Name = "Main addin.xlam" Then
eai.Installed = False
Exit For
End If
Next
'add and install the addin
Set eai = Application.AddIns.Add("path to Main addin.xlam", False)
eai.Installed = True
'append quick access ribbon xml to add button
ClearCustRibbon
LoadNewRibbon
'have to close addin for it to load properly the first time
Workbooks("Main addin.xlam").Close
End Sub
Sub ClearCustRibbon()
'https://social.msdn.microsoft.com/Forums/vstudio/en-US/abddbdc1-7a24-4664-a6ff-170d787baa5b/qat-changes-lost-when-using-xml-to-modify-ribbon-excel-2016-2016?forum=exceldev
Dim hFile As Long
Dim ribbonXMLString As String
hFile = FreeFile
OfficeUIFilePath = Environ("USERPROFILE") & "\AppData\Local\Microsoft\Office\Excel.officeUI"
ribbonXMLString = "<mso:customUI xmlns:mso=""http://schemas.microsoft.com/office/2009/07/customui"">" & _
"<mso:ribbon>" & _
"<mso:qat>" & _
"<mso:sharedControls>" & _
"</mso:sharedControls>" & _
"</mso:qat>" & _
"</mso:ribbon>" & _
"</mso:customUI>"
Open OfficeUIFilePath For Output Access Write As hFile
Print #hFile, ribbonXMLString
Close hFile
End Sub
Sub LoadNewRibbon()
Dim hFile As Long
hFile = FreeFile
OfficeUIFilePath = Environ("USERPROFILE") & "\AppData\Local\Microsoft\Office\Excel.officeUI"
ribbonXML = "your ribbon text here"
Open OfficeUIFilePath For Output Access Write As hFile
Print #hFile, ribbonXML
Close hFile
End Sub
***IMPORTANT---- If you install the addin manually, make sure you select no when prompted if you want the file saved to the local machine. If you save it to the local machine, it creates a local copy, and will never update if you make changes to the network copy or need to fix an error.
There are more tips, but you'll mostly need to adapt them to fit how you operate. Hope that helps.
I am trying to save attachments from a sub-folder in Outlook to a folder on my C drive using Excel VBA.
For example, in my inbox folder I have a sub-folder called 'data' and in this folder there are emails with different excel attachments of different data but with the same formatting and the same attachment name but with an updated date (Eg: "Attachment name + 28 March").
These emails are sent daily. I want all attachments, not already saved, saved to a folder on my C drive and then open each attachment to extract the relevant data to Excel.
I am able to extract the relevant data once the files are in my C drive but I am unable to set up a path from my Excel to Outlook without Outlook VBA (which I don't want to do).
This is what I have so far: (the comments are for my benefit because I am new to this)
Sub attachmentsave()
Dim olook As Outlook.Application
Dim omailitem As Outlook.mailitem
'whenever dealing with folders we need to define outlook.namespace This is a class that opens the gate for me to access all outlook folders
Dim onamespace As Outlook.Namespace
Dim fol As Outlook.Folder 'we need to tell vba where we have out emails with attachments stored
Dim atmt As Outlook.Attachment '.attachment is a class that will help us deal with emails that have attachments
Set olook = New Outlook.Application
Set omailitem = olook.CreateItem(olmailitem)
'messaging application protocol interface
Set onamespace = olook.GetNameSpace("MAPI")
Set fol = onamespace.GetDefaultFolder(olFolderInbox)
For Each omailitem In fol.items
For Each atmt In omailitem.attachments
atmt.SaveAsFile "C:/" & atmt.FileName
'all attachments in inbox should be save in C drive
Next
Next
End Sub
You need a macro-enabled Excel workbook with a reference to "Microsoft Output nn.n Object Library" where “nn.n” depends on the version of Office you are running. Please do not mix versions; I have never tried but I understand it causes problems.
I am assuming you are familiar with Excel VBA and know how to create a macro-enabled workbook. From your comments, I assume you do not know about references.
Much of the power of VBA is not native but comes from libraries which you can reference if you need their functionality. Open the VBA Editor and click Tools and then References. You will get a long list of available references. Those at the top will be ticked. For example, "Microsoft Excel nn.n Object Library" will be ticked. Without this reference, the compiler would not know what a range or a worksheet was. Note: "nn.n" depends on the version of Office you are using. For me, the value is "16.0" because I am using Office 365.
Unticked references are in alphabetic sequence. Scroll down the list until you find "Microsoft Outlook nn.n Object Library". Click the box to the left to tick this reference. Click "OK". If you click Tools then References again you will see "Microsoft Outlook nn.n Object Library" ticked and near the top. The compiler now has access to the definitions of MailItem, Folder and the rest of the Outlook Object Model.
Copy the code below to a new module:
Option Explicit
Sub ListStores()
' Needs reference to "Microsoft Output nn.n Object Library"
' where "nn.n" depends on the version of Outlook you are using.
Dim AppOut As New Outlook.Application
Dim InxStoreCrnt As Long
Dim FldrInbox As Outlook.Folder
With AppOut
With .Session
Debug.Print "List of stores:"
For InxStoreCrnt = 1 To .Folders.Count
Debug.Print " " & .Folders(InxStoreCrnt).Name
Next
Set FldrInbox = .GetDefaultFolder(olFolderInbox)
Debug.Print "Store for default Inbox: " & FldrInbox.Parent.Name
End With
End With
AppOut.Quit
Set AppOut = Nothing
End Sub
VBA usually has more than one method of achieving a desired effect. You have used “NameSpace” in your code whilst I have used “Session”. The documentation says these two methods are equivalent. If you write your own code, you can pick whichever method you prefer. But if you go looking for useful snippets, you must be ready for other people having different preferences.
Dim AppOut As New Outlook.Application creates an instance of Outlook that will access Outlook’s files on behalf of the macro.
With AppOut
With .Session
: : : :
End With
End With
I can replace : : : : with any Outlook VBA. If an Excel macro tries to access an email, the user will be warned and asked to give permission for the macro to run.
Outlook keeps emails, appointments, tasks and so on in files it calls Stores. You may see these called PST files because most have an extension of PST but an OST file is also a store. You may see them called Accounts because, by default, Outlook creates one store per email account. However, you can create as many extra stores as you want, none of which will be Accounts.
This code will create a list of the stores you can access:
Debug.Print "List of stores:"
For InxStoreCrnt = 1 To .Folders.Count
Debug.Print " " & .Folders(InxStoreCrnt).Name
Next
The output might look something like:
List of stores:
Outlook Data File
Smith John#ISPOne.com
Archive Folders
Backup
John Smith#ISPTwo.com
OutlookOutlook
The above is based on my home installation. A work installation is likely to be somewhat different. The differences will depend on the options chosen during installation. A work installation is also likely to included shared folders which I do not have on my system.
If you look at your folder pane, you will have names with other names indented underneath. The names be will the stores and will match the stores listed by the macro although the sequence will probably be different. The other names in the folder pane will be the folders within each store.
The last bit of my macro is:
Set FldrInbox = .GetDefaultFolder(olFolderInbox)
Debug.Print "Store for default Inbox: " & FldrInbox.Parent.Name
You have similar code to access an Inbox but this may not be the Inbox you want. On my system, this code outputs:
Store for default Inbox: Outlook Data File
“Outlook Data File” is Outlook’s default store. On my system, the calendar and my tasks are held in this store but my emails are not. I have two email accounts and each has their own store.
Try this above macro. Does GetDefaultFolderfind the Inbox you need to access?
Now add this macro:
Sub ListStoresAndFirstEmails()
' Needs reference to "Microsoft Output nn.n Object Library"
' where "nn.n" depends on the version of Outlook you are using.
Dim AppOut As New Outlook.Application
Dim InxFldrCrnt As Long
Dim InxStoreCrnt As Long
Dim FldrInbox As Outlook.Folder
With AppOut
With .Session
Debug.Print "List of stores and first emails:"
For InxStoreCrnt = 1 To .Folders.Count
Debug.Print " " & .Folders(InxStoreCrnt).Name
For InxFldrCrnt = 1 To .Folders(InxStoreCrnt).Folders.Count
If .Folders(InxStoreCrnt).Folders(InxFldrCrnt).Name = "Inbox" Then
Set FldrInbox = .Folders(InxStoreCrnt).Folders(InxFldrCrnt)
If FldrInbox.Items.Count > 0 Then
With FldrInbox.Items(1)
Debug.Print " Subject: " & .Subject
Debug.Print " Received: " & .ReceivedTime
Debug.Print " From: " & .SenderEmailAddress
End With
End If
Exit For
End If
Next
Next
End With
End With
AppOut.Quit
Set AppOut = Nothing
End Sub
This macro is also about investigating your stores. The macro scans down your stores. For each store, it scans down the list of level 1 folders looking for "Inbox". If it finds "Inbox", it assumes the oldest item in it is a MailItem and outputs its subject, received time and sender. If the oldest item is not a MailItem, you will get an error. I almost hope you do get an error to demonstrate the importance of not making assumptions.
Finally add:
Sub ListAttachments()
Dim AppOut As New Outlook.Application
Dim InxAttachCrnt As Long
Dim InxItemCrnt As Long
Dim InxStoreCrnt As Long
Dim FldrData As Outlook.Folder
With AppOut
With .Session
Set FldrData = .Folders("Outlook Data File").Folders("Inbox").Folders("Data")
End With
End With
Debug.Print "List emails with attachments within: ";
Debug.Print " " & FldrData.Name & " of " & FldrData.Parent.Name & _
" of " & FldrData.Parent.Parent.Name
With FldrData
For InxItemCrnt = 1 To FldrData.Items.Count
If .Items(InxItemCrnt).Class = olMail Then
With .Items(InxItemCrnt)
If .Attachments.Count > 0 Then
Debug.Print " Subject: " & .Subject
Debug.Print " Received: " & .ReceivedTime
Debug.Print " From: " & .SenderEmailAddress
For InxAttachCrnt = 1 To .Attachments.Count
Debug.Print " " & InxAttachCrnt & " " & .Attachments(InxAttachCrnt).DisplayName
Next
End If
End With
End If
Next
End With
AppOut.Quit
Set AppOut = Nothing
End Sub
I always keep some junk emails in store "Outlook Data File" for testing purposes.
In Set FldrData = .Folders("Outlook Data File").Folders("Inbox").Folders("Data") you need to replace "Outlook Data File" with the name of the store containing the emails of interest. If I understand correctly, the emails are in folder "Data" under folder "Inbox". If I have misunderstood, notice how I have used a chain of "Folders(xxxx)" to reach the required folder. In earlier emails I have used indices to reach stores and folders. Here I have specified a specific folder.
Within that folder I look for MailItems (showing how to avoid other items) and if they have attachments, list some properties of the email and the names of its attachments.
This is as far as I can go because I do not fully understand your explanation of how attachments are named or where you want attachments saved.