Powerpoint: Manually set Slide Name - ms-office

Context:
A PowerPoint slide in C# has a property Slide.Name (usually contains an arbitrary string value).
In my C# application I would like to use this property to identify slides (the slide order is to unreliable).
Question:
How can I manually set the Slide.Name property in the PowerPoint Application?
My problem is very like to the: “How to name an object within a PowerPoint slide?” but just on the slide level.
Any help would be appreciated.

There is no built-in functionality in PowerPoint that allows you to edit the name of a slide. As Steve mentioned, you have to do it using VBA code. The slide name will never change due to inserting more slides, and it will stay the same even if you close PowerPoint; the slide name set in VBA code is persistent. Here's some code I wrote to allow you to easily view the name of the currently selected slide and allow you to rename it:
'------------------------------------------------------------------
' NameSlide()
'
' Renames the current slide so you can refer to this slide in
' VBA by name. This is not used as part of the application;
' it is for maintenance and for use only by developers of
' the PowerPoint presentation.
'
' 1. In Normal view, click on the slide you wish to rename
' 2. ALT+F11 to VB Editor
' 3. F5 to run this subroutine
'------------------------------------------------------------------
Sub NameSlide()
Dim curName As String
curName = Application.ActiveWindow.View.Slide.name
Dim newName As String
retry:
newName = InputBox("Enter the new name for slide '" + curName + "', or press Cancel to keep existing name.", "Rename slide")
If Trim(newName) = "" Then Exit Sub
Dim s As Slide
' check if this slide name already exists
On Error GoTo SlideNotFound
Set s = ActivePresentation.Slides(newName)
On Error GoTo 0
MsgBox "Slide with this name already exists!"
GoTo retry
Exit Sub
SlideNotFound:
On Error GoTo 0
Application.ActiveWindow.View.Slide.name = newName
MsgBox "Slide renamed to '" + newName + "'."
End Sub

You can't manually set the slide name, but with a bit of code, it's simple. In VBA, for example:
Sub NameThatSlide()
ActivePresentation.Slides(1).Name = "Whatever You Like Here"
End Sub

You can rename a slide manually or with VBA. Once you know how, the door opens to some interesting possibilities, which I will demonstrate with code below.
Manually renaming slides. This ability is hidden in the VBA Editor's Properties pane, but it does not require coding.
If the Developer ribbon is not visible, enable it: File > Options > Customize Ribbon > check the Developer Main Tab.
From the Developer ribbon, click the Visual Basic menu item to open the Visual Basic Editor.
Press the Ctrl+R keys to navigate to the Project Explorer pane.
Expand "Microsoft PowerPoint Objects"
Click on any slide to select it.
Press the F4 key to navigate to the Properties pane.
Edit the (Name) item, and press Enter to apply the name change.
The slide name change may not appear immediately in the VBA Project Explorer pane. As long as the name is correct in the Properties pane, the name changed successfully.
This VBA code will also do the trick (hide slide number 1):
ActivePresentation.Slides(1).SlideShowTransition.Hidden = msoTrue
This code block covers a few ways to manage slide names and answers the main question.
Option Explicit
Public Function RenameSlide(oldName As String, newName As String)
' RenameSlide finds slide oldName and renames it to newName.
' Arguements:
' oldName: current (old) name of existing slide
' newName: new name for slide.
'
Dim tempBool As Boolean
Dim sld As Slide
Dim RetVal(0 To 1) As String
' Check if oldName can be found.
If SlideExists(oldName) Then
Set sld = Application.ActivePresentation.Slides(oldName)
Else
RetVal(0) = 1 'Error 1
RetVal(1) = "Error 1: slide with name " & oldName & " not found. Aborting."
Exit Function
End If
' Check if this slide name newName already exists.
If SlideExists(newName) Then
RetVal(0) = 2 'Error 1
RetVal(1) = "Error 2: slide with name " & newName & " already exists. Aborting."
Exit Function
End If
' Rename the slide
'Application.ActivePresentation.Slides(oldName) = newName
Application.ActivePresentation.Slides(oldName).Select
Application.ActiveWindow.View.Slide.Name = newName 'current slide
RetVal(0) = 0 'Success
RetVal(1) = "Success: slide renamed from '" & oldName & "' to '" & newName & "'."
End Function
Public Sub SetSlideName()
' Prompt user for new name for active slide.
'
Dim oldName As String
Dim newName As String
Dim sld As Slide
Dim msg As String
' Get current name of active slide.
oldName = Application.ActiveWindow.View.Slide.Name
msg = "Enter the new name for slide '" + oldName + "'."
retry:
newName = ""
' Prompt for new slide name. Loop until a name of at least 1 character is provided.
Do While newName = ""
newName = InputBox(msg, "Rename slide")
newName = Trim(newName)
If Len(newName) = 0 Then
msg = "Try again. You must enter a slide name to continue."
ElseIf newName = oldName Or newName = Str(vbCancel) Then
Exit Sub
End If
Loop
' If an existing slide already has name newName, then
' go back and prompt user again.slide name already exists
If SlideExists(newName) Then
msg = "Slide with this name already exists!"
GoTo retry
End If
' Set the new slide name
Application.ActiveWindow.View.Slide.Name = newName
MsgBox "Slide renamed to '" + newName + "'."
End Sub
Public Function SlideExists(SlideName As String) As Boolean
Dim RetVal As Boolean
Dim sld
' Assume slide does not exist.
SlideExists = False
' Try to find slide by name.
' If we error out, the slide does NOT exist.
On Error GoTo NoSlide
Set sld = ActivePresentation.Slides(SlideName)
' If we got this far, the slide DOES exist.
SlideExists = True
Exit Function
NoSlide:
' Error setting slide objects shows
' that slides does NOT exist.
SlideExists = False
End Function
As an aside, I use the slide naming trick and a little VBA to selectively remove certain slides from printing. I added a few extra VBA macros for the sake of populating the Macros list. From any slide: Developer ribbon > Macros > Select Macro > Run button. Use this method to kick off my PresentSlide, DontPresentSlide, PrintSlide and DontPrintSlide macros. Once you have properly tagged your various slides, simply run the PrepToPresentSlides or PrepToPrintSlides macro before you present or print, respectively.
Play around with these macros a bit and read the comments. You will find that I wrote the code extensibly, so you can modify it easily for your needs.
The code below helps me to manage which slides and objects are printed and which are presented on-screen. This is particularly useful when I want to print reference slides but not cover them. It is even more useful when I have slides with animations. Animations don't usually translate print well. So, I choose not to print some animated objects at all. In fact, I can even add in substitute content for the objects to be used just for printing (hidden when presenting) - though I rarely do this. Instead, I will typically hide the animation from printing or create a slide to present and a non-animated copy of it for print. With these macros, it is easy to manage a mix and match of slides and objects for print and slides and objects for presentation. I hope you enjoy.
Option Explicit
' DontPresentSlide - run macro while on a slide you wish to skip while presenting.
' The slide name will be appended with "NoPresent". You still
' need to run PrepToPresent before presenting to hide slide.
' PresentSlide - "NoPresent" will be removed from the slide. You still
' need to run PrepToPresent before presenting to hide slide.
' PrepToPesentSlides() - Unhide slides and objects you want presented and
' hide slides and objects you do NOT want presented.
' ShowNoPressnt() - show slides and shapes marked "NoPresent"
' HideNoPresent() - hide slides and shapes marked "NoPresent"
' DontPrintSlide - run macro while on a slide you wish to skip while presenting.
' The slide name will be appended with "NoPrint". You still
' need to run PrepToPresent before presenting to hide slide.
' PrintSlide - "NoPrint" will be removed from the slide. You still
' need to run PrepToPresent before presenting to hide slide.
' PrepToPrintSlides() - Unhide slides and objects you want printed and
' hide slides and objects you do NOT want printed.
' ShowNoPrint() - show slides and shapes marked "NoPrint"
' HideNoPrint() - hide slides and shapes marked "NoPrint"
' ShowHideSlides() - Hide or Unhide slides based on slide name.
' ShowHideShapes() - Hide or Unhide shapes based on shapes name.
Public Const cjaHide = False
Public Const cjaShow = True
Public Const cjaToggle = 2
Sub ShowHideSlides(NameContains As String _
, Optional LMR As String = "R" _
, Optional ShowSlide As Integer = False)
' Show or Hide slides based on slide name.
' Arguements:
' NameContains (string):
' slides with this string will be modified.
' LMR (string): enter L, M or R to indicate
' searching the Left, Middle or Right of
' the slide name, respectively.
' ShowSlide (integer):
' Show: True (-1)
' Hide: False (0)
' Toggle: 2
'
' To show or hide slides manually:
' Right-click the slide thumbnail, then click Hide Slide
' To rename slides,
' Use this VBA: ActiveWindow.View.Slide.Name = "NewSlideName"
' Or, edit the (Name) property in the VBA Properties window.
'
Dim sldCurrent As Slide
Dim found As Boolean
found = False
LMR = Trim(UCase(LMR))
If LMR <> "L" And LMR <> "M" Then LMR = "R"
'Loop through each slide in presentation.
For Each sldCurrent In ActivePresentation.Slides
'Match shape name left, right or middle as per LMR arguement.
'ActiveWindow.View.Slide.Name or Slide.SlideNumber
found = False
If LMR = "R" And LCase(right(sldCurrent.Name, Len(NameContains))) = LCase(NameContains) Then
found = True
ElseIf LMR = "L" And LCase(left(sldCurrent.Name, Len(NameContains))) = LCase(NameContains) Then
found = True
ElseIf LMR = "M" And InStr(1, LCase(NameContains), LCase(sldCurrent.Name)) Then
found = True
End If
'If match found, then set shape visibility per ShowShape arguement.
If found Then
If ShowSlide = True Then
ActivePresentation.Slides(sldCurrent.SlideNumber).SlideShowTransition.Hidden = msoFalse
ElseIf ShowSlide = False Then
ActivePresentation.Slides(sldCurrent.SlideNumber).SlideShowTransition.Hidden = msoTrue
Else
ActivePresentation.Slides(sldCurrent.SlideNumber).SlideShowTransition.Hidden = Not ActivePresentation.Slides(sldCurrent.SlideNumber).SlideShowTransition.Hidden
End If
End If
Next 'sldCurrent
End Sub
Sub ShowHideShapes(NameContains As String _
, Optional LMR As String = "R" _
, Optional ShowShape As Integer = False)
' Show or Hide shapes/objects based on object name.
' Arguements:
' NameContains (string):
' shapes with this string will be modified.
' LMR (string): enter L, M or R to indicate
' searching the Left, Middle or Right of
' the slide name, respectively.
' ShowSlide (integer):
' Show: True (-1)
' Hide: False (0)
' Toggle: 2
'
' To show, hide and/or rename objects:
' 1. Turn on Selection Pane via: Home Ribbon >
' Select > Selection Pane.
' 2. Double-click a shape name to rename it.
' 3. Click the eye icon to the far right to show/hide a shape.
Dim shpCurrent As Shape
Dim sldCurrent As Slide
Dim found As Boolean
found = False
LMR = Trim(UCase(LMR))
If LMR <> "L" And LMR <> "M" Then LMR = "R"
'Loop through each slide in presentation.
For Each sldCurrent In ActivePresentation.Slides
With sldCurrent
'Loop through each shape on current slide.
For Each shpCurrent In .Shapes
'Match shape name left, right or middle as per LMR arguement.
found = False
If LMR = "R" And right(shpCurrent.Name, Len(NameContains)) = NameContains Then
found = True
ElseIf LMR = "L" And left(shpCurrent.Name, Len(NameContains)) = NameContains Then
found = True
ElseIf LMR = "M" And InStr(1, NameContains, shpCurrent.Name) Then
found = True
End If
'If match found, then set shape visibility per ShowShape arguement.
If found Then
If ShowShape = True Then
shpCurrent.Visible = True
ElseIf ShowShape = False Then
shpCurrent.Visible = False
Else
shpCurrent.Visible = Not shpCurrent.Visible
End If
End If
Next 'sldCurrent
End With 'sldCurrent
Next 'sldCurrent
End Sub
Sub HideNoPrint()
' Hide slides and shapes you do NOT want printed.
'
' Run this macro to hide all slides and shapes that
' end with the string "NoPrint".
' Usage. Assume you have slides that contain animations that
' make the printed slide difficult or impossible to read.
' Let's further suppose you plan to present certain slides
' but not print them.
' 1. Add the"NoPrint" suffix to any shapes that clutter
' the printed page.
' 2. Add the "NoPrint" suffix to slides you don't want to
' print.
' 3. Run this macro to hide shapes and slides.
' 4. Print the slides.
' 5. Optionally, run the ShowNoPrint() macro in preparation
' for presenting the slides.
ShowHideShapes "NoPrint", "R", False
ShowHideSlides "NoPrint", "R", False
End Sub
Sub ShowNoPrint()
' Unhide slides and shapes that were hidden
' to prevent them from being printed in handouts.
'
ShowHideShapes "NoPrint", "P", True
ShowHideSlides "NoPrint", "P", True
End Sub
Sub HideNoPressent()
' Hide objects you do NOT want to present on screen.
'
' Run this macro to hide all slides and shapes that
' end with the string "NoPresent".
'
' Usage. Assume you have slides that contain supporting material
' that you wish to provide as printed handouts but not show.
' You can manually hide those slides and objects of course. I
' prefer to use these macros.
' 1. Add the"NoPresent" suffix to any shapes that you want
' to print to handouts but not show on-screen.
' 2. Add the "NoPresent" suffix to slides you want to
' print but not display on screen, such as reference slides.
' 3. Run this macro to hide the "NoPresent" shapes and slides.
' 4. Present your slides.
' 5. Optionally, run the ShowNoPresent() macro in preparation
' for printing the slides.
'
ShowHideShapes "NoPressent", "R", False
ShowHideSlides "NoPressent", "R", False
End Sub
Sub ShowNoPresent()
' Unhide objects that were hidden to prevent them from
' being presented on screen.
'
ShowHideShapes "NoPressent", "P", True
ShowHideSlides "NoPressent", "P", True
End Sub
Sub PrepToPrintSlides()
' Unhide objects you want printed and
' hide objects you do NOT want printed.
ShowNoPresent
HideNoPrint
End Sub
Sub PrepToPresentSlides()
' Unhide objects you want presented and
' hide objects you do NOT want presented.
ShowNoPrint
HideNoPresent
End Sub
Sub DontPresentSlide()
Dim RetVal, sldName As String
sldName = Application.ActiveWindow.View.Slide.Name
If InStr(1, sldName, "NoPresent", vbBinaryCompare) = 0 Then
RetVal = RenameSlide(sldName, sldName & "-NoPresent")
End If
HideNoPresent
End Sub
Sub PresentSlide()
Dim RetVal, sldName As String, strStart As String, newName As String
'Remove the NoPresent suffix from the current slide.
'get slide name
sldName = Application.ActiveWindow.View.Slide.Name
'Unhide slide
ActivePresentation.Slides(sldName).SlideShowTransition.Hidden = msoFalse
'remove "-NoPresent" from slide name
Do
strStart = InStr(1, sldName, "-NoPresent")
If InStr(1, sldName, "-NoPresent") Then
newName = left(sldName, strStart - 1) & right(sldName, Len(sldName) - strStart - 9)
RetVal = RenameSlide(sldName, newName)
End If
sldName = Application.ActiveWindow.View.Slide.Name
Loop Until InStr(1, sldName, "-NoPresent") = 0
'remove "NoPresent" from slide name
Do
strStart = InStr(1, sldName, "NoPresent")
If InStr(1, sldName, "NoPresent") Then
newName = left(sldName, strStart - 1) & right(sldName, Len(sldName) - strStart - 8)
RetVal = RenameSlide(sldName, newName)
End If
sldName = Application.ActiveWindow.View.Slide.Name
Loop Until InStr(1, sldName, "NoPresent") = 0
End Sub
Sub DontPrintSlide()
Dim RetVal, sldName As String
sldName = Application.ActiveWindow.View.Slide.Name
If InStr(1, sldName, "NoPrint", vbBinaryCompare) = 0 Then
RetVal = RenameSlide(sldName, sldName & "-NoPrint")
End If
HideNoPrint
End Sub
Sub PrintSlide()
Dim RetVal, sldName As String, strStart As String, newName As String
'Remove the NoPrint suffix from the current slide.
'get slide name
sldName = Application.ActiveWindow.View.Slide.Name
'Unhide slide
ActivePresentation.Slides(sldName).SlideShowTransition.Hidden = msoFalse
'remove "-NoPrint" from slide name
Do
strStart = InStr(1, sldName, "-NoPrint")
If InStr(1, sldName, "-NoPrint") Then
newName = left(sldName, strStart - 1) & right(sldName, Len(sldName) - strStart - 7)
RetVal = RenameSlide(sldName, newName)
End If
sldName = Application.ActiveWindow.View.Slide.Name
Loop Until InStr(1, sldName, "-NoPrint") = 0
'remove "NoPrint" from slide name
Do
strStart = InStr(1, sldName, "NoPrint")
If InStr(1, sldName, "NoPrint") Then
newName = left(sldName, strStart - 1) & right(sldName, Len(sldName) - strStart - 6)
RetVal = RenameSlide(sldName, newName)
End If
sldName = Application.ActiveWindow.View.Slide.Name
Loop Until InStr(1, sldName, "NoPrint") = 0
End Sub
Sub HideAllCovers()
' Run this macro to hide all Covers.
ShowHideShapes "Cover", "L", False
End Sub
Sub ShowAllCovers()
' Run this macro to hide all Covers.
ShowHideShapes "Cover", "L", True
End Sub
Sub HideAllAnswers()
' Run this macro to hide all Covers.
ShowHideShapes "Answer", "L", False
End Sub
Sub ShowAllAnswers()
' Run this macro to hide all Covers.
ShowHideShapes "Answer", "L", True
End Sub
Sub HideAllQuestions()
' Run this macro to hide all Covers.
ShowHideShapes "Question", "L", False
End Sub
Sub ShowAllQuestions()
' Run this macro to hide all Covers.
ShowHideShapes "Question", "L", True
End Sub
Sub ShowAll()
' Run this macro to hide all shapes (Covers and Answers).
ShowAllQuestions
ShowAllAnswers
ShowAllCovers
ShowNoPrint
End Sub
Sub HideAll()
' Run this macro to hide all shapes (Covers and Answers).
HideAllQuestions
HideAllAnswers
HideAllCovers
HideNoPrint
End Sub

Enable the "Developer" tab in "File -> Options -> Customize Ribbon" (Details: https://www.addintools.com/documents/powerpoint/where-is-developer-tab.html)
In the developer tab, follow these steps and see the image below (in Portuguese, sorry)
Enter the developer tab
Select the target slide
If you don't have any active X control (buttons, textboxes, etc.) in the slide, add a dummy button from the developer tab
Select this button on the slide and click "properties" at the developer tab
At the top of the properties window, there is a combo box where you can select the slide instead of the button
Select the slide and see its programming properties, including name

I'm not certain that this will enable you to set the Slide.Name property because I'm not a VBA programmer, but anyway AFAIK the easiest way to name slides in PowerPoint 2010 is using Outline view.
If you position your mouse farthest left on a created slide, you can drag rightwards a kind of vertical slide sorter. At the top of that pane, you'll see two tabs: Slides and Outline.
Select Outline, you'll see each slide numbered and a grey grab button which allows you to reorder your slides. If you click to the right of that, you can type in whatever name you like, say Home.
In the main view pane, the slide will then have Home emblazoned across it. You can then either leave it there, or conceal it by altering the font colour to the background or by moving the text outside the presentation frame.
BTW You can use these names in hyperlinks.

used the Sub SplitFile() function to create individual slides from a deck of >100 slides. All went well!! But can anyone tell me what code do I use to rename the file automatically, assuming that each slide has a title in a text box? I want the slide title to be the file name for the new, individual slide created.
Here's the code I used to create individual slides (as individual files), thanks to whoever posted it online.
Sub SplitFile()
Dim lSlidesPerFile As Long
Dim lTotalSlides As Long
Dim oSourcePres As Presentation
Dim otargetPres As Presentation
Dim sFolder As String
Dim sExt As String
Dim sBaseName As String
Dim lCounter As Long
Dim lPresentationsCount As Long ' how many will we split it into
Dim x As Long
Dim lWindowStart As Long
Dim lWindowEnd As Long
Dim sSplitPresName As String
On Error GoTo ErrorHandler
Set oSourcePres = ActivePresentation
If Not oSourcePres.Saved Then
MsgBox "Please save your presentation then try again"
Exit Sub
End If
lSlidesPerFile = CLng(InputBox("How many slides per file?", "Split Presentation"))
lTotalSlides = oSourcePres.Slides.Count
sFolder = ActivePresentation.Path & "\"
sExt = Mid$(ActivePresentation.Name, InStr(ActivePresentation.Name, ".") + 1)
sBaseName = Mid$(ActivePresentation.Name, 1, InStr(ActivePresentation.Name, ".") - 1)
If (lTotalSlides / lSlidesPerFile) - (lTotalSlides \ lSlidesPerFile) > 0 Then
lPresentationsCount = lTotalSlides \ lSlidesPerFile + 1
Else
lPresentationsCount = lTotalSlides \ lSlidesPerFile
End If
If Not lTotalSlides > lSlidesPerFile Then
MsgBox "There are fewer than " & CStr(lSlidesPerFile) & " slides in this presentation."
Exit Sub
End If
For lCounter = 1 To lPresentationsCount
' which slides will we leave in the presentation?
lWindowEnd = lSlidesPerFile * lCounter
If lWindowEnd > oSourcePres.Slides.Count Then
' odd number of leftover slides in last presentation
lWindowEnd = oSourcePres.Slides.Count
lWindowStart = ((oSourcePres.Slides.Count \ lSlidesPerFile) * lSlidesPerFile) + 1
Else
lWindowStart = lWindowEnd - lSlidesPerFile + 1
End If
' Make a copy of the presentation and open it
For Each oSlide In ActiveWindow.Presentation.Slides
strTitles = strTitles _
& "Slide: " _
& CStr(oSlide.SlideIndex) & vbCrLf _
& oSlide.Shapes.Title.TextFrame.TextRange.Text _
& vbCrLf & vbCrLf
Next oSlide
On Error GoTo ErrorHandler
intFileNum = FreeFile
sSplitPresName = sFolder & sBaseName & _
"_" & CStr(lWindowStart) & "-" & CStr(lWindowEnd) & "." & sExt
oSourcePres.SaveCopyAs sSplitPresName, ppSaveAsDefault
Set otargetPres = Presentations.Open(sSplitPresName, , , True)
With otargetPres
For x = .Slides.Count To lWindowEnd + 1 Step -1
.Slides(x).Delete
Next
For x = lWindowStart - 1 To 1 Step -1
.Slides(x).Delete
Next
.Save
.Close
End With
Next ' lpresentationscount
NormalExit:
Exit Sub
ErrorHandler:
MsgBox "Error encountered"
Resume NormalExit
End Sub

Related

Vba, Programatically assign a macro to a "Shape" inside shapegroup

Thanks in advance, not sure why this wouldn't work.
I want to assign a macro to each button inside a shape group on load.
Inside Module:
Private Const SideNavName As String = "SideNav"
Public Sub SetSideNavigationOnAllSheets()
Dim ws As Worksheet
Dim oShape As Shape
For Each ws In ActiveWorkbook.Sheets
'check to see if sidenav shape/group exists in sheet
If Common.ShapeExists(ws, SideNavName) Then
' get side nav
For Each oShape In ws.Shapes(SideNavName).GroupItems
' only need the nav buttons not container
If Left(oShape.Name, 3) = "Nav" Then
Debug.Print ws.Name, oShape.Name
oShape.TextFrame.Characters.Text = "btn 1" ' pull from DB
oShape.OnAction = "'" & ActiveWorkbook.Name & "'!FolderSelectorButton" ' ERRORS OUT HERE
End If
'
Next
End If
Next
End Sub
Public Sub FolderSelectorButton()
Debug.Print 1
End Sub
Seems VBA doesn't like setting the OnAction property for Shapes that have been grouped. Solution is to store details of the group, ungroup it, update the OnAction property then re-create the group.
Replace your two lines setting the TextFrame and OnAction of the oShape object with the following:
' save then ungroup the Shapes
Dim oShpGrp As Shape, sShapeNames() As String, i As Long
Set oShpGrp = ws.Shapes(SideNavName)
ReDim sShapeNames(1 To oShpGrp.GroupItems.Count)
For i = 1 To oShpGrp.GroupItems.Count
sShapeNames(i) = oShpGrp.GroupItems.Item(i).Name
Next i
oShpGrp.Ungroup
' update Shape
oShape.TextFrame.Characters.Text = "btn 1" ' pull from DB
oShape.OnAction = "'" & ActiveWorkbook.Name & "'!FolderSelectorButton" ' ERRORS OUT HERE
' re-group the Shapes
Set oShpGrp = oShpGrp.Parent.Shapes.Range(sShapeNames).Group
oShpGrp.Name = SideNavName
This assumes that the group is a single-level group (ie it is not a group embedded within another group)

How to make an Excel macro run when the file is updated?

I have a PowerApp which updates a cell in an Excel file hosted in OneDrive. The Excel file contains a macro that is supposed to run when the PowerApp changes the Excel file. However, it doesn't do that. If I update a cell manually, the macro works just fine. It's just not activated when the file is updated by PowerApps.
Is there a different function I can use that will be triggered when PowerApp changes the file?
If that is not possible, could I use a Flow to activate the macro?
Here is the current script that works with manual changes, but not the automatic PowerApps changes.
Private Sub Worksheet_Change(ByVal Target As Range)
Call InsertImageTest
End Sub
Here is the macro that I want to trigger using the code above.
Sub InsertImageTest()
' This macro inserts an image from a set location to a set cell.
Dim ws As Worksheet
Dim imagePath As String
Dim cell As String
Dim posText As String
Dim imgLeft As Double
Dim imgTop As Double
Dim rngX As Range
Dim activeSheetName As String
' Customizable variables
imagePath = ActiveWorkbook.Path & Range("$B$2").Value
posText = "Signature"
activeSheetName = "Data" ' Set to "Data" by default, but will change to the Active sheets name, if the active sheet is not called "Data"
' For i = 1 To Sheets.Count
' If CStr(Sheets(i).Name) Is CStr(activeSheetName) Then
' Debug.Print "Code can be executed! Data tab was found"
' End If
' Next i
cell = "$A$1"
Set ws = ActiveSheet
Set rngX = Worksheets(activeSheetName).Range("A1:Z1000").Find(posText, lookat:=xlPart)
If Not rngX Is Nothing Then
cell = rngX.Address
Debug.Print cell
Debug.Print rngX.Address & " cheating"
Worksheets(activeSheetName).Range(cell).Value = ""
Debug.Print rngX.Address & " real"
imgLeft = Range(cell).Left
imgTop = Range(cell).Top
' Width & Height = -1 means keep original size
ws.Shapes.AddPicture _
Filename:=imagePath, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=imgLeft, _
Top:=imgTop, _
Width:=-1, _
Height:=-1
End If
' The code beaneath will resize the cell to fit the picture
For Each Picture In ActiveSheet.DrawingObjects
PictureTop = Picture.Top
PictureLeft = Picture.Left
PictureHeight = Picture.Height
PictureWidth = Picture.Width
For N = 2 To 256
If Columns(N).Left > PictureLeft Then
PictureColumn = N - 1
Exit For
End If
Next N
For N = 2 To 65536
If Rows(N).Top > PictureTop Then
PictureRow = N - 1
Exit For
End If
Next N
Rows(PictureRow).RowHeight = PictureHeight
Columns(PictureColumn).ColumnWidth = PictureWidth * (54.29 / 288)
Picture.Top = Cells(PictureRow, PictureColumn).Top
Picture.Left = Cells(PictureRow, PictureColumn).Left
Next Picture
End Sub
Unfortunately the server opens Excel through APIs and Excel doesn't fire macros in this way. It seems flow has the same. I would consider implement the macro function logic in PowerApps. Customize the edit form of the column which supposes to trigger the macro, depends what the macro should do. Possibly unlock a data card if the macro trys to alter a value of another column.

Pivot Chart Title to Display Multiple Selected Items

I have a pivotchart that when the selected filter (work center) is changed, it updates the chart title to display that work center name. However, if I check the box to allow multiple selections, the chart title simply shows "All" instead of showing each of the actual selected items. I haven't found a way to get it to show what I'm looking for. Below is the code that I'm using to update the chart title as well as the code for the filter change event that fires it off
Option Explicit
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
On Error Resume Next
Application.Run "'Prod_Tools.xlam'!gPTWCChange", Target.PivotFields("WorkCenter").CurrentPage
On Error GoTo 0
End Sub
Sub gPTWCChange(ByVal WC As String)
Dim wb1 As Workbook
Dim CPWB1 As Workbook
For Each wb1 In Workbooks
If InStr(1, wb1.Name, "Capacity Planning Rep", vbTextCompare) > 0 Then
Set CPWB1 = Workbooks(wb1.Name)
Exit For
End If
Next wb1
On Error Resume Next
CPWB1.Charts("Workcenter By Week").ChartTitle.Text = "Work Center: " & WC
On Error GoTo 0
End Sub
What I would like is when multiple items are selected, have the chart title look like "Data for: Workcenter_A, Workcenter_B, Workcenter_F"
Here's your adapted sub. Notice that its parameter has changed.
Public Sub gPTWCChange(ByVal pfWC As Excel.PivotField)
Const sSEPARATOR As String = ", "
Dim sChartTitle As String
Dim oPivotItem As Excel.PivotItem
Dim lVisibleCount As Long
'... Your original code ...
Dim wb1 As Workbook
Dim CPWB1 As Workbook
For Each wb1 In Workbooks
If InStr(1, wb1.Name, "Capacity Planning Rep", vbTextCompare) > 0 Then
Set CPWB1 = Workbooks(wb1.Name)
Exit For
End If
Next wb1
'... New code to compute the chart title ...
If pfWC.EnableMultiplePageItems Then
'Build the chart title from the visible items in the PivotField.
lVisibleCount = 0
For Each oPivotItem In pfWC.PivotItems
If oPivotItem.Visible Then
lVisibleCount = lVisibleCount + 1
sChartTitle = sChartTitle & sSEPARATOR & oPivotItem.Caption
End If
Next
'Drop the leading separator.
sChartTitle = Mid$(sChartTitle, Len(sSEPARATOR) + 1)
'Manage plural.
sChartTitle = "Work Center" & IIf(lVisibleCount > 1, "s", "") & ": " & sChartTitle
Else
sChartTitle = "Work Center: " & pfWC.CurrentPage
End If
'... Your original code ...
On Error Resume Next
CPWB1.Charts("Workcenter By Week").ChartTitle.Text = sChartTitle
On Error GoTo 0
End Sub
And call your sub as follows:
Application.Run "'Prod_Tools.xlam'!gPTWCChange", Target.PivotFields("WorkCenter")
The principle is to send your sub a reference to the PivotField object, and from there, check its EnableMultiplePageItems property.

Copy hyperlink from outlook email body and export to excel or notepad

Here is what I am looking for:
I have 20 different folders in outlook, each has same email body structure and format.
each email body has 3 to 7 hyperlinks
i want to export one of these hyperlinks (its easy to identify as it has a same starting/a specific word within - it doesn't matter if we export this specific hyperlink or all of them because we can later edit them within excel).
I want these hyperlinks to be exported into cells in excel sheet
WHAT I AM DOING RIGHT NOW:
I am using a clipboard to go to each email. right click copy link and then pasting into a notepad or excel.
let me know if you guys have any suggestions. This will really simplify my work.. and surely of any other who may look for similar solutions.
regards,
AA
You can export to excel, but before copying to excel,
->You have to select emails in which hyperlinks are present. By selecting emails righclick and select send to one-note.
-> One-note will open. Flip through the page tabs in this section (on the right-hand side)of One-note . select all the mails(pages) and rightclick->copy.
Now you can paste the copied items in notepad.
Now u can copy all contents in notepad to excel.
you can find or apply filter, filter->textfilter->contains required word or phrase (its easy to identify as it has a same starting/a specific word within).
If u directly copy from onenote to excel means all tables, attachment and others will be pasted, then it will be difficult to filter or find required hyperlinks.
since you are saying 20 folders it is not possible to send folders to onenote, u need to open 20 folder then u can select any number of emails in each folder.
:)
I cannot fit my solution in a single answer because it exceeds the size limit. This is part 2 of my answer. It contains a block of code described in part 1. Read Part 1 first.
Option Explicit
Public Type MAPIFolderDtl
NameParent As String
Folder As MAPIFolder
NumMail As Long
NumMeet As Long
End Type
' -----------------------------------------------------------------------
' ## Insert other routines here
' -----------------------------------------------------------------------
Sub FindInterestingFolders(ByRef IntFolderList() As MAPIFolderDtl, _
WantMail As Boolean, WantMeet As Boolean, _
NameSep As String, _
ParamArray NameFullList() As Variant)
' * Return a list of interesting folders.
' * To be interesting a folder must be named or be a subfolder of a named
' folder and contain mail and or meeting items if wanted.
' * Note: a top level folder cannot be returned as interesting because such
' folders are not of type MAPIFolder.
' * IntFolders() The list of interesting folders. See Type MAPIFolderDtl for
' contents.
' * WantMail True if a folder containing mail items is to be classified
' as interesting.
' * WantMeet True if a folder containing meeting items is to be classified
' as interesting.
' * NameSep SubFolder Names in NameList are of the form:
' "Personal Folders" & NameSep & "Inbox"
' NameSep can be any character not used in a folder name. It
' appears any character could be used in a folder name including
' punctuation characters. If in doubt, try Tab.
' * NameFullList One or more full names of folders which might themselves be
' interesting or might be the parent an interesting folders.
Dim InxTLFList() As Long
Dim InxIFLCrnt As Long
Dim InxNFLCrnt As Long
Dim InxTLFCrnt As Variant
Dim NameFullCrnt As String
Dim NamePartFirst As String
Dim NamePartRest As String
Dim Pos As Long
Dim TopLvlFolderList As Folders
InxIFLCrnt = 0 ' Nothing in IntFolderList()
Set TopLvlFolderList = CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
For InxNFLCrnt = LBound(NameFullList) To UBound(NameFullList)
NameFullCrnt = NameFullList(InxNFLCrnt) ' Get next name
' Split name into first part and the rest. For Example,
' "Personal Folders|NHSIC|Commisioning" will be split into:
' NamePartFirst: Personal Folders
' NamePartRest: NHSIC|Commissioning
Pos = InStr(1, NameFullCrnt, NameSep)
If Pos = 0 Then
NamePartFirst = NameFullCrnt
NamePartRest = ""
Else
NamePartFirst = Mid(NameFullCrnt, 1, Pos - 1)
NamePartRest = Mid(NameFullCrnt, Pos + 1)
End If
' Create list of indices into TopLvlFolderList in
' ascending sequence by folder name
Call SimpleSortFolders(TopLvlFolderList, InxTLFList)
' NamePartFirst should be the name of a top level
' folder or empty. Ignore if it is not.
For Each InxTLFCrnt In InxTLFList
If NamePartFirst = "" Or _
TopLvlFolderList.Item(InxTLFCrnt).Name = NamePartFirst Then
' All subfolders are a different type so they
' are handled by FindInterestingSubFolder
Call FindInterestingSubFolders(IntFolderList, InxIFLCrnt, _
"", TopLvlFolderList.Item(InxTLFCrnt), WantMail, _
WantMeet, NameSep, NamePartRest)
End If
Next
Next
If InxIFLCrnt = 0 Then
' No folders found
ReDim IntFolderList(0 To 0)
Else
ReDim Preserve IntFolderList(1 To InxIFLCrnt) ' Discard unused entries
'For InxIFLCrnt = 1 To UBound(IntFolderList)
' Debug.Print IntFolderList(InxIFLCrnt).NameParent & "|" & _
' IntFolderList(InxIFLCrnt).Folder.Name & " " & _
' IntFolderList(InxIFLCrnt).NumMail & " " & _
' IntFolderList(InxIFLCrnt).NumMeet
'Next
End If
End Sub
Sub FindInterestingSubFolders(ByRef IntFolderList() As MAPIFolderDtl, _
InxIFLCrnt As Long, NameParent As String, _
MAPIFolderCrnt As MAPIFolder, WantMail As Boolean, _
WantMeet As Boolean, NameSep As String, _
NameChild As String)
' * NameFull = ""
' MAPIFolderCrnt and all its subfolders are potentially of interest
' * NameFull <> ""
' Look further down hierarchy for subfolders of potential interest
' This routine can be called repeately by a parent routine to explore different parts
' of the folder hierarchy. It calls itself recursively to work down the hierarchy.
' IntFolderList ' Array of interesting folders.
' InxIFLCrnt ' On the first call, InxIFLCrnt will be zero and the state of
' IntFolderList will be undefined.
' NameParent ' ... Grandparent & NameSep & Parent
' MAPIFolderCrnt ' The current folder that is to be explored.
' WantMail ' True if a folder has to contain mail to be interesting
' WantMeet ' True if a folder has to contain meeting items to be interesting
' NameSep ' The name separator character
' NameChild ' Suppose the original path was xxx|yyy|zzz. For each recurse down
' a name is removed from the start of NameChild and added to the end
' of NameParent. When NameChild is blank, the target folder has
' been reached.
Dim InxSFList() As Long
Dim InxSFCrnt As Variant
Dim NameCrnt As String
Dim NamePartFirst As String
Dim NamePartRest As String
Dim NumMail As Long
Dim NumMeet As Long
Dim Pos As Long
Pos = InStr(1, NameChild, NameSep)
If Pos = 0 Then
NamePartFirst = NameChild
NamePartRest = ""
Else
NamePartFirst = Mid(NameChild, 1, Pos - 1)
NamePartRest = Mid(NameChild, Pos + 1)
End If
If NameParent = "" Then
' This folder has no parent. It cannot be interesting.
NameCrnt = MAPIFolderCrnt.Name
Else
' This folder has a parent. It could be interesting.
NameCrnt = NameParent & NameSep & MAPIFolderCrnt.Name
If NamePartFirst = "" Then
If FolderHasRequiredItems(MAPIFolderCrnt, WantMail, _
WantMeet, NumMail, NumMeet) Then
' Debug.Print NameCrnt & " interesting"
If InxIFLCrnt = 0 Then
ReDim IntFolderList(1 To 100)
End If
InxIFLCrnt = InxIFLCrnt + 1
If InxIFLCrnt > UBound(IntFolderList) Then
ReDim Preserve IntFolderList(1 To 100 + UBound(IntFolderList))
End If
IntFolderList(InxIFLCrnt).NameParent = NameParent
Set IntFolderList(InxIFLCrnt).Folder = MAPIFolderCrnt
IntFolderList(InxIFLCrnt).NumMail = NumMail
IntFolderList(InxIFLCrnt).NumMeet = NumMeet
Else
' Debug.Print NameCrnt & " not interesting"
End If
End If
End If
If MAPIFolderCrnt.Folders.Count = 0 Then
' No subfolders
Else
Call SimpleSortMAPIFolders(MAPIFolderCrnt, InxSFList)
For Each InxSFCrnt In InxSFList
If NamePartFirst = "" Or _
MAPIFolderCrnt.Folders(InxSFCrnt).Name = NamePartFirst Then
Select Case NamePartFirst
' Ignore folders that can cause problems
Case "Sync Issues"
Case "RSS Feeds"
Case "Public Folders"
Case Else
' Recurse to analyse next level down
Call FindInterestingSubFolders(IntFolderList, InxIFLCrnt, NameCrnt, _
MAPIFolderCrnt.Folders(InxSFCrnt), WantMail, _
WantMeet, NameSep, NamePartRest)
End Select
End If
Next
End If
End Sub
Function FolderHasRequiredItems(MAPIFolderCrnt As MAPIFolder, WantMail As Boolean, _
WantMeet As Boolean, ByRef NumMail As Long, _
ByRef NumMeet As Long) As Boolean
' Return True if folder is interested. That is: at least one of the following is true:
' WantMail = True And NumMail > 0
' WantMeet = True And NumMeet > 0
' Values for NumMail and NumMeet are set whether or not the folder is interesting
Dim FolderItem As Object
Dim FolderItemClass As Long
Dim InxItemCrnt As Long
NumMail = 0
NumMeet = 0
' Count mail and meeting items in folder
For InxItemCrnt = 1 To MAPIFolderCrnt.Items.Count
Set FolderItem = MAPIFolderCrnt.Items.Item(InxItemCrnt)
' This seems to avoid syncronisation errors
FolderItemClass = 0
On Error Resume Next
FolderItemClass = FolderItem.Class
On Error GoTo 0
Select Case FolderItemClass
Case olMail
NumMail = NumMail + 1
Case olMeetingResponsePositive, olMeetingRequest, olMeetingCancellation, _
olMeetingResponseNegative, olMeetingResponseTentative
NumMeet = NumMeet + 1
End Select
Next
If WantMail And NumMail > 0 Then
FolderHasRequiredItems = True
Exit Function
End If
If WantMeet And NumMeet > 0 Then
FolderHasRequiredItems = True
Exit Function
End If
FolderHasRequiredItems = False
End Function
Sub SimpleSortMAPIFolders(MAPIFolderList As MAPIFolder, _
ByRef InxArray() As Long)
' On exit InxArray contains the indices into MAPIFolderList sequenced by
' ascending name. The sort is performed by repeated passes of the list
' of indices that swap adjacent entries if the higher come first.
' Not an efficient sort but adequate for short lists.
Dim InxIACrnt As Long
Dim InxIALast As Long
Dim NoSwap As Boolean
Dim TempInt As Long
Debug.Assert MAPIFolderList.Folders.Count >= 1 ' Must be at least one folder
ReDim InxArray(1 To MAPIFolderList.Folders.Count) ' One entry per folder
' Fill array with indices
For InxIACrnt = 1 To UBound(InxArray)
InxArray(InxIACrnt) = InxIACrnt
Next
' Each repeat of the loop movest the folder with the highest name
' to the end of the list. Each repeat checks one less entry.
' Each repeats partially sorts the leading entries and may result
' in the list being sorted before all loops have been performed.
For InxIALast = UBound(InxArray) To 1 Step -1
NoSwap = True
For InxIACrnt = 1 To InxIALast - 1
If MAPIFolderList.Folders(InxArray(InxIACrnt)).Name > _
MAPIFolderList.Folders(InxArray(InxIACrnt + 1)).Name Then
NoSwap = False
' Move higher entry one slot towards the end
TempInt = InxArray(InxIACrnt)
InxArray(InxIACrnt) = InxArray(InxIACrnt + 1)
InxArray(InxIACrnt + 1) = TempInt
End If
Next
If NoSwap Then
Exit For
End If
Next
End Sub
I cannot fit my solution in a single answer because it exceeds the size limit. This is part 1 of my answer. I have moved one block of code to a second answer.
This is a VBA solution. You give a good specification so I believe this will be close to your requirement. I hope I have included enough comments to allow you to make final adjustments. If not, ask.
This first block of code contains sub-routines written by me for me. They perform tasks I find useful. They include comments but they are comments written to remind me what they do not to help someone else understand them. The macros I have written for you use them and I explain how to use them. For the moment I suggest you do not worry about how these sub-routines do what they do.
I should perhaps warn you that I rarely use the error handling functionality in my own macros because I do not want them to fail gracefully; I want them to stop on the problem statement so I can understand and correct the cause.
Within Outlook, open the VBA Editor, insert a module and copy this first block of code into it. You will also need to click Tools then References. Is "Microsoft Excel nn.n Object Library" near the top and is it ticked? If it is not ticked, you must scroll done the list, find this reference and tick it. The value of "nn.n" will depend on the version of Excel you use. Only if you have more than one version of Excel installed will you have a choice.
Answer continued below code.
This code moved to the second part of the answer.
Below are four macros. The first three are tutorials and the fourth is my solution.
If your Outlook installation is like mine you will have folders Personal Folders, Archive Folders and perhaps others. Within Personal Folders you will have the standard folders Inbox, Outbox and so on. You may have added your own folders within these standard folders or you may have added them to Personal Folders. On my own system I have a variety of folders including !Family and !Tony. Each contains sub-folders and one of the sub-folders within !Tony is Amazon.
In the first macro, the statement you most need to understand it:
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
FindInterestingFolders is one of the sub-routines included in the code above. The second line of this statement specifies, in a style I find convenient, the names of the two folders I mentioned. The macro FindInterestingFolders returns information about these two folders and any sub-folders or sub-sub-folders they may have. You will have to replace these two names with the folders you want searched. If the 20 folders are all under one parent, you can specify that single parent. If the 20 folders are scattered you might have to specify the names of all twenty.
The first macro outputs to the Immediate Window the names of all the folders found by FindInterestingFolders. On my system, it outputs:
Personal Folders|!Family|Chloe & Euan
Personal Folders|!Family|Geoff
Personal Folders|!Family|Lucy & Mark
Personal Folders|!Tony|Amazon
Personal Folders|!Tony|Amazon|Trueshopping Ltd
Copy this macro into the module you created above and play with it until you get it to create a list of the 20 folders you want searched.
Answer continued below code.
Sub ExtractHyperLinks1()
' Outputs a sorted list of interesting folders to the Immediate Window.
Dim FolderList() As MAPIFolderDtl
Dim InxFL As Long
' Set FolderList to a list of interesting folders.
' The True means a folder has to containing mail items to be interesting.
' The False means I am uninterested in meeting items.
' The "|" defines the name separator used in the list of folder names
' that follow.
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
For InxFL = LBound(FolderList) To UBound(FolderList)
With FolderList(InxFL)
Debug.Print .NameParent & "|" & .Folder.Name
End With
Next
End Sub
Hope that was not too difficult. You will have to copy your amended call of FindInterestingFolders into the following macros.
Macro 2 builds on macro 1. It searches the interesting folders for mail items with Html bodies. For each Html body, it searches for anchor tags and outputs to the Immediate Window each tag and the next 58 characters. The Immediate Window only shows the last 200 or so rows so you may only see the bottom of the output. This doesn't matter; the idea is to give you a first look at what the macro can see. On my system, the output ends:
Tony Dallimore 13/02/2012 15:42:00 RE: Product details enquiry from Amazon customer ...
<A HREF="mailto:16dhtcxlxwbh7fx#marketplace.amazon.co.uk">ma
<A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht
<A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht
Trueshopping Ltd - Amazon Marketplace 14/02/2012 09:08:39 RE: Product details enquiry ...
<A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht
<A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht
The header lines contain the Sender, ReceivedTime and Subject of the mail item.
Add this macro to the module, copy the amended call of FindInterestingFolders over the top of my call and run it. Almost immediately, you will be warned that a macro is accessing emails. You will have to give permission for the macro to continue and select a period for it to continue. I am assuming you have the security level set to Medium which is standard. If you have set it to something different, you will get different options.
Answer continued below code.
Sub ExtractHyperLinks2()
' Gets a list of interesting folders.
' Searches the list for mail items with Html bodies that contain an anchor.
' For each such mail item it outputs to the Immediate Window:
' Name of folder (if not already output for an earlier mail item)
' Sender ReceivedTime Subject
' First 60 characters of first anchor
' First 60 characters of second anchor
' First 60 characters of third anchor
Dim FolderList() As MAPIFolderDtl
Dim FolderNameOutput As Boolean
Dim InxFL As Long
Dim InxItem As Long
Dim PosAnchor As Long
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
For InxFL = LBound(FolderList) To UBound(FolderList)
FolderNameOutput = False
With FolderList(InxFL).Folder
For InxItem = 1 To .Items.Count
With .Items.Item(InxItem)
If .Class = olMail Then
If .HtmlBody <> "" Then
' This mail item has an Html body so might have a hyperlink.
If InStr(1, LCase(.HtmlBody), "<a ") <> 0 Then
' It has at least one anchor
If Not FolderNameOutput Then
Debug.Print FolderList(InxFL).NameParent & "|" & _
FolderList(InxFL).Folder.Name
FolderNameOutput = True
End If
Debug.Print " " & .SenderName & " " & _
.ReceivedTime & " " & .Subject
PosAnchor = InStr(1, LCase(.HtmlBody), "<a ")
Do While PosAnchor <> 0
Debug.Print " " & Mid(.HtmlBody, PosAnchor, 60)
PosAnchor = InStr(PosAnchor + 1, LCase(.HtmlBody), "<a ")
Loop
End If
End If
End If
End With
Next
End With
Next
End Sub
Again I hope that was easy. I am not sure how useful the next macro is. It was a step in my development but it contains nothing of importance that is not also within the final macro. It may be worth you studying it because the final macro will have two important changes from Macro 2.
What Macro 3 does is extract the URLs from the anchor tag and discard those that start "mailto:". Html allows more variation than I have allowed for because I have never seen an email that took advantage of that flexibility. It is possible you will have to enhance my code if your emails differ from what I expect. You only want one of the URLs from each email so you might want to add the code to discard the others.
Again, add this macro to the module, copy the amended call of FindInterestingFolders over the top of my call and run it. On my system the last few line of the output are:
Tony Dallimore 13/02/2012 15:42:00 RE: Product details enquiry from ...
http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=11081621
http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=3149571
Trueshopping Ltd - Amazon Marketplace 14/02/2012 09:08:39 RE: Product ...
http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=11081621
http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=3149571
Answer continued below code.
Sub ExtractHyperLinks3()
' Gets a list of interesting folders.
' Searches the list for mail items with Html bodies that contain an
' acceptable anchor. An acceptable anchor is one for which the url
' does not start "mailto:".
' For each acceptable anchor it outputs to the Immediate Window:
' Name of folder (if not already output for an earlier mail item)
' Sender ReceivedTime Subject (if not already output)
' Url from acceptable anchor
Dim FolderList() As MAPIFolderDtl
Dim FolderNameOutput As Boolean
Dim InxFL As Long
Dim InxItem As Long
Dim ItemHeaderOutput As Boolean
Dim LcHtmlBody As String
Dim PosAnchor As Long
Dim PosTrailingQuote As Long
Dim PosUrl As Long
Dim Quote As String
Dim Url As String
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
For InxFL = LBound(FolderList) To UBound(FolderList)
FolderNameOutput = False
With FolderList(InxFL).Folder
For InxItem = 1 To .Items.Count
ItemHeaderOutput = False
With .Items.Item(InxItem)
If .Class = olMail Then
If .HtmlBody <> "" Then
' This mail item has an Html body so might contain hyperlinks.
LcHtmlBody = LCase(.HtmlBody)
If InStr(1, LcHtmlBody, "<a ") <> 0 Then
' It has at least one anchor
PosAnchor = InStr(1, LCase(.HtmlBody), "<a ")
Do While PosAnchor <> 0
PosUrl = InStr(PosAnchor, LcHtmlBody, "href=")
PosUrl = PosUrl + 5
Quote = Mid(LcHtmlBody, PosUrl, 1) ' Extract quote used in html
PosUrl = PosUrl + 1
PosTrailingQuote = InStr(PosUrl, LcHtmlBody, Quote)
Url = Mid(.HtmlBody, PosUrl, PosTrailingQuote - PosUrl)
If Left(LCase(Url), 7) <> "mailto:" Then
' I am interested in this url
If Not FolderNameOutput Then
Debug.Print FolderList(InxFL).NameParent & "|" & _
FolderList(InxFL).Folder.Name
FolderNameOutput = True
End If
If Not ItemHeaderOutput Then
Debug.Print " " & .SenderName & " " & _
.ReceivedTime & " " & .Subject
ItemHeaderOutput = True
End If
Debug.Print " " & Url
End If
PosAnchor = InStr(PosTrailingQuote, LCase(.HtmlBody), "<a ")
Loop
End If
End If
End If
End With
Next
End With
Next
End Sub
For the final macro I created a worksheet in one of the workbooks I use for developing answers.
Within the final macro you will find the statement:
Const WkBkPathFile As String = "C:\DataArea\Play\Combined 10 V02.xls"
You need to replace this with the path and file name of your workbook.
You will also find this statement:
Const WkShtName As String = "URLs"
I have used worksheet URLs. I suggest you start by creating a worksheet like mine. Once you have got the final macro working, you can adapt it to your requirements.
I have four columns in my worksheet: Folder Name, Sender Name, Received Time and URL. The third column holds the full date and time but I formatted it to only display a short date. There is nothing in your question to suggest you want these extra columns. I thought it was worth demonstrating what you could do and leave you to delete the code if it is not interesting.
I do think you will need to do something with Received Time. Unless you move processed emails out of the 20 folders, each run of the macro will add the full set of URLs again. There are many techniques for not processing emails again. For example, you could add a user category to processed emails. However, I suspect the easiest approach is:
Add a hidden worksheet to the workbook.
Set cell A1 of this worksheet to "Latest processed email" and set B1 to 1-Jan-2000.
Add to the code which discards uninteresting emails, a test for the Received time being after this date/time.
Record the latest Received time of any processed email.
Write the latest Received time of any processed email to cell B1 of the hidden worksheet.
I have included a lot of comments in the final macro explaining how I accumulate data and write it to the worksheet so I will not repeat myself here. I wish you luck and repeat the instruction at the beginning to ask if anything is unclear.
Again, add this macro to the module, copy the amended call of FindInterestingFolders over the top of my call. This time you will also have to update one or both of the constant statements before running the macro.
Sub ExtractHyperLinks()
' Open destination workbook.
' Find last used row in destination worksheet.
' Gets a list of interesting folders.
' Searches the list for mail items with Html bodies that contain an
' acceptable anchor. An acceptable anchor is one for which the url
' does not start "mailto:".
' For each acceptable anchor it outputs to the workbook:
' Column 1 := Name of folder
' Column 2 := Sender
' Column 3 := ReceivedTime
' Column 4 := Url
Dim ExcelWkBk As Excel.Workbook
Dim FolderList() As MAPIFolderDtl
Dim FolderName As String
Dim InterestingURL As Boolean
Dim InxOutput As Long
Dim InxFL As Long
Dim InxItem As Long
Dim ItemCrnt As MailItem
Dim LcHtmlBody As String
Dim OutputValue(1 To 50, 1 To 4)
Dim PosAnchor As Long
Dim PosTrailingQuote As Long
Dim PosUrl As Long
Dim Quote As String
Dim RowNext As Long
Dim TargetAddr As String
Dim Url As String
' Replace constant value with path and file name of your workbook.
Const WkBkPathFile As String = "C:\DataArea\Play\Combined 10 V02.xls"
Const WkShtName As String = "URLs"
Set ExcelWkBk = Application.CreateObject("Excel.Application"). _
Workbooks.Open(WkBkPathFile)
With ExcelWkBk
.Application.Visible = True ' Slows the macro but helps during testing
With .Worksheets(WkShtName)
' Find last used row in destination worksheet by going to bottom of sheet
' then moving up until a non-empty row is found then going down one.
' .End(xlUp) is VBA equivalent of Ctrl+Up.
RowNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
End With
End With
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
InxOutput = 0
For InxFL = LBound(FolderList) To UBound(FolderList)
FolderName = FolderList(InxFL).NameParent & "|" & FolderList(InxFL).Folder.Name
With FolderList(InxFL).Folder
For InxItem = 1 To .Items.Count
With .Items.Item(InxItem)
If .Class = olMail Then
If .HtmlBody <> "" Then
' This mail item has an Html body so might contain hyperlinks.
LcHtmlBody = LCase(.HtmlBody)
If InStr(1, LcHtmlBody, "<a ") <> 0 Then
' It has at least one anchor
PosAnchor = InStr(1, LCase(.HtmlBody), "<a ")
Do While PosAnchor <> 0
PosUrl = InStr(PosAnchor, LcHtmlBody, "href=")
PosUrl = PosUrl + 5
Quote = Mid(LcHtmlBody, PosUrl, 1) ' Extract quote used in html
PosUrl = PosUrl + 1
PosTrailingQuote = InStr(PosUrl, LcHtmlBody, Quote)
Url = Mid(.HtmlBody, PosUrl, PosTrailingQuote - PosUrl)
InterestingURL = True ' Assume interesting until find otherwise
If Left(LCase(Url), 7) = "mailto:" Then
InterestingURL = False
End If
' **********************************************************
' Set InterestingURL = False for any other urls you want
' to reject. If you can tell a URL is ininteresting by
' looking at it, you can use code like mine.
' **********************************************************
If InterestingURL Then
' This URL and supporting data is to be output to the
' workbook.
' Rather than output data to the workbook cell by cell,
' which can be slow, I build it up in the array
' OutputValue(1 to 50, 1 To 4). It is normal in a 2D array
' for the first dimension to be for columns and the second
' for rows. Arrays to be read from or written to a worksheet
' are the other way round. You can resize the second
' dimension of a dynamic array but not the first so you
' cannot resize an array being built for a workbook. I
' cannot resize the array so I have fixed its size at
' compile time.
' This code fills the array, writes it out to the workbook
' and resets the array index. I have 50 rows because I
' wanted to test the filling and refilling of the array. I
' would suggest you make it bigger.
InxOutput = InxOutput + 1
If InxOutput > UBound(OutputValue, 1) Then
' Array is fill. Output it to workbook
TargetAddr = "A" & RowNext & ":D" & _
RowNext + UBound(OutputValue, 1) - 1
ExcelWkBk.Worksheets(WkShtName). _
Range(TargetAddr).Value = OutputValue
RowNext = RowNext + 50
InxOutput = 1
End If
OutputValue(InxOutput, 1) = FolderName
OutputValue(InxOutput, 2) = .SenderName
OutputValue(InxOutput, 3) = .ReceivedTime
OutputValue(InxOutput, 4) = Url
End If
PosAnchor = InStr(PosTrailingQuote, LCase(.HtmlBody), "<a")
Loop
End If
End If
End If
End With
Next
End With
Next
ExcelWkBk.Save ' Save changes over the top of the original file.
ExcelWkBk.Close (False) ' Don't save changes
Set ExcelWkBk = Nothing ' Release resource
End Sub
Guys I am using codetwo outlook exporter to perform this task. I somehow stumbled upon it.. Thanks Marc nd Expfresh! your solutions are great but i found another way before even trying them.. This is great that this forum has helpful people. Just for people facing the same problem: USE CODETWO outlook Exporter. - Does the job. regards - Addy

How to copy Outlook mail message into excel using VBA or Macros

I'm a newbie in VBA and Macros. If someone helps me with VBA code and macros, it will be helpful.
Daily I'll receive around 50-60 mails with one standard subject: "Task Completed". I have created a rule to all those mail to move to a specific folder: "Task Completed".
Reading all 50-60 mails a day and updating all mails is very much time consuming.
All 50-60 mails coming to my inbox will have same subject but from different users.
Body of mail will vary.
I'm using Outlook 2010 and Excel 2010.
Since you have not mentioned what needs to be copied, I have left that section empty in the code below.
Also you don't need to move the email to the folder first and then run the macro in that folder. You can run the macro on the incoming mail and then move it to the folder at the same time.
This will get you started. I have commented the code so that you will not face any problem understanding it.
First paste the below mentioned code in the outlook module.
Then
Click on Tools~~>Rules and Alerts
Click on "New Rule"
Click on "start from a blank rule"
Select "Check messages When they arrive"
Under conditions, click on "with specific words in the subject"
Click on "specific words" under rules description.
Type the word that you want to check in the dialog box that pops up and click on "add".
Click "Ok" and click next
Select "move it to specified folder" and also select "run a script" in the same box
In the box below, specify the specific folder and also the script (the macro that you have in module) to run.
Click on finish and you are done.
When the new email arrives not only will the email move to the folder that you specify but data from it will be exported to Excel as well.
CODE
Const xlUp As Long = -4162
Sub ExportToExcel(MyMail As MailItem)
Dim strID As String, olNS As Outlook.Namespace
Dim olMail As Outlook.MailItem
Dim strFileName As String
'~~> Excel Variables
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
'~~> Establish an EXCEL application object
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
'~~> Show Excel
oXLApp.Visible = True
'~~> Open the relevant file
Set oXLwb = oXLApp.Workbooks.Open("C:\Sample.xls")
'~~> Set the relevant output sheet. Change as applicable
Set oXLws = oXLwb.Sheets("Sheet1")
lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).Row + 1
'~~> Write to outlook
With oXLws
'
'~~> Code here to output data from email to Excel File
'~~> For example
'
.Range("A" & lRow).Value = olMail.Subject
.Range("B" & lRow).Value = olMail.SenderName
'
End With
'~~> Close and Clean up Excel
oXLwb.Close (True)
oXLApp.Quit
Set oXLws = Nothing
Set oXLwb = Nothing
Set oXLApp = Nothing
Set olMail = Nothing
Set olNS = Nothing
End Sub
FOLLOWUP
To extract the contents from your email body, you can split it using SPLIT() and then parsing out the relevant information from it. See this example
Dim MyAr() As String
MyAr = Split(olMail.body, vbCrLf)
For i = LBound(MyAr) To UBound(MyAr)
'~~> This will give you the contents of your email
'~~> on separate lines
Debug.Print MyAr(i)
Next i
New introduction 2
In the previous version of macro "SaveEmailDetails" I used this statement to find Inbox:
Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
I have since installed a newer version of Outlook and I have discovered that it does not use the default Inbox. For each of my email accounts, it created a separate store (named for the email address) each with its own Inbox. None of those Inboxes is the default.
This macro, outputs the name of the store holding the default Inbox to the Immediate Window:
Sub DsplUsernameOfDefaultStore()
Dim NS As Outlook.NameSpace
Dim DefaultInboxFldr As MAPIFolder
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderInbox)
Debug.Print DefaultInboxFldr.Parent.Name
End Sub
On my installation, this outputs: "Outlook Data File".
I have added an extra statement to macro "SaveEmailDetails" that shows how to access the Inbox of any store.
New introduction 1
A number of people have picked up the macro below, found it useful and have contacted me directly for further advice. Following these contacts I have made a few improvements to the macro so I have posted the revised version below. I have also added a pair of macros which together will return the MAPIFolder object for any folder with the Outlook hierarchy. These are useful if you wish to access other than a default folder.
The original text referenced one question by date which linked to an earlier question. The first question has been deleted so the link has been lost. That link was to Update excel sheet based on outlook mail (closed)
Original text
There are a surprising number of variations of the question: "How do I extract data from Outlook emails to Excel workbooks?" For example, two questions up on [outlook-vba] the same question was asked on 13 August. That question references a variation from December that I attempted to answer.
For the December question, I went overboard with a two part answer. The first part was a series of teaching macros that explored the Outlook folder structure and wrote data to text files or Excel workbooks. The second part discussed how to design the extraction process. For this question Siddarth has provided an excellent, succinct answer and then a follow-up to help with the next stage.
What the questioner of every variation appears unable to understand is that showing us what the data looks like on the screen does not tell us what the text or html body looks like. This answer is an attempt to get past that problem.
The macro below is more complicated than Siddarth’s but a lot simpler that those I included in my December answer. There is more that could be added but I think this is enough to start with.
The macro creates a new Excel workbook and outputs selected properties of every email in Inbox to create this worksheet:
Near the top of the macro there is a comment containing eight hashes (#). The statement below that comment must be changed because it identifies the folder in which the Excel workbook will be created.
All other comments containing hashes suggest amendments to adapt the macro to your requirements.
How are the emails from which data is to be extracted identified? Is it the sender, the subject, a string within the body or all of these? The comments provide some help in eliminating uninteresting emails. If I understand the question correctly, an interesting email will have Subject = "Task Completed".
The comments provide no help in extracting data from interesting emails but the worksheet shows both the text and html versions of the email body if they are present. My idea is that you can see what the macro will see and start designing the extraction process.
This is not shown in the screen image above but the macro outputs two versions on the text body. The first version is unchanged which means tab, carriage return, line feed are obeyed and any non-break spaces look like spaces. In the second version, I have replaced these codes with the strings [TB], [CR], [LF] and [NBSP] so they are visible. If my understanding is correct, I would expect to see the following within the second text body:
Activity[TAB]Count[CR][LF]Open[TAB]35[CR][LF]HCQA[TAB]42[CR][LF]HCQC[TAB]60[CR][LF]HAbst[TAB]50 45 5 2 2 1[CR][LF] and so on
Extracting the values from the original of this string should not be difficult.
I would try amending my macro to output the extracted values in addition to the email’s properties. Only when I have successfully achieved this change would I attempt to write the extracted data to an existing workbook. I would also move processed emails to a different folder. I have shown where these changes must be made but give no further help. I will respond to a supplementary question if you get to the point where you need this information.
Good luck.
Latest version of macro included within the original text
Option Explicit
Public Sub SaveEmailDetails()
' This macro creates a new Excel workbook and writes to it details
' of every email in the Inbox.
' Lines starting with hashes either MUST be changed before running the
' macro or suggest changes you might consider appropriate.
Dim AttachCount As Long
Dim AttachDtl() As String
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim FolderTgt As MAPIFolder
Dim HtmlBody As String
Dim InterestingItem As Boolean
Dim InxAttach As Long
Dim InxItemCrnt As Long
Dim PathName As String
Dim ReceivedTime As Date
Dim RowCrnt As Long
Dim SenderEmailAddress As String
Dim SenderName As String
Dim Subject As String
Dim TextBody As String
Dim xlApp As Excel.Application
' The Excel workbook will be created in this folder.
' ######## Replace "C:\DataArea\SO" with the name of a folder on your disc.
PathName = "C:\DataArea\SO"
' This creates a unique filename.
' #### If you use a version of Excel 2003, change the extension to "xls".
FileName = Format(Now(), "yymmdd hhmmss") & ".xlsx"
' Open own copy of Excel
Set xlApp = Application.CreateObject("Excel.Application")
With xlApp
' .Visible = True ' This slows your macro but helps during debugging
.ScreenUpdating = False ' Reduces flash and increases speed
' Create a new workbook
' #### If updating an existing workbook, replace with an
' #### Open workbook statement.
Set ExcelWkBk = xlApp.Workbooks.Add
With ExcelWkBk
' #### None of this code will be useful if you are adding
' #### to an existing workbook. However, it demonstrates a
' #### variety of useful statements.
.Worksheets("Sheet1").Name = "Inbox" ' Rename first worksheet
With .Worksheets("Inbox")
' Create header line
With .Cells(1, "A")
.Value = "Field"
.Font.Bold = True
End With
With .Cells(1, "B")
.Value = "Value"
.Font.Bold = True
End With
.Columns("A").ColumnWidth = 18
.Columns("B").ColumnWidth = 150
End With
End With
RowCrnt = 2
End With
' FolderTgt is the folder I am going to search. This statement says
' I want to seach the Inbox. The value "olFolderInbox" can be replaced
' to allow any of the standard folders to be searched.
' See FindSelectedFolder() for a routine that will search for any folder.
Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
' #### Use the following the access a non-default Inbox.
' #### Change "Xxxx" to name of one of your store you want to access.
Set FolderTgt = Session.Folders("Xxxx").Folders("Inbox")
' This examines the emails in reverse order. I will explain why later.
For InxItemCrnt = FolderTgt.Items.Count To 1 Step -1
With FolderTgt.Items.Item(InxItemCrnt)
' A folder can contain several types of item: mail items, meeting items,
' contacts, etc. I am only interested in mail items.
If .Class = olMail Then
' Save selected properties to variables
ReceivedTime = .ReceivedTime
Subject = .Subject
SenderName = .SenderName
SenderEmailAddress = .SenderEmailAddress
TextBody = .Body
HtmlBody = .HtmlBody
AttachCount = .Attachments.Count
If AttachCount > 0 Then
ReDim AttachDtl(1 To 7, 1 To AttachCount)
For InxAttach = 1 To AttachCount
' There are four types of attachment:
' * olByValue 1
' * olByReference 4
' * olEmbeddedItem 5
' * olOLE 6
Select Case .Attachments(InxAttach).Type
Case olByValue
AttachDtl(1, InxAttach) = "Val"
Case olEmbeddeditem
AttachDtl(1, InxAttach) = "Ebd"
Case olByReference
AttachDtl(1, InxAttach) = "Ref"
Case olOLE
AttachDtl(1, InxAttach) = "OLE"
Case Else
AttachDtl(1, InxAttach) = "Unk"
End Select
' Not all types have all properties. This code handles
' those missing properties of which I am aware. However,
' I have never found an attachment of type Reference or OLE.
' Additional code may be required for them.
Select Case .Attachments(InxAttach).Type
Case olEmbeddeditem
AttachDtl(2, InxAttach) = ""
Case Else
AttachDtl(2, InxAttach) = .Attachments(InxAttach).PathName
End Select
AttachDtl(3, InxAttach) = .Attachments(InxAttach).FileName
AttachDtl(4, InxAttach) = .Attachments(InxAttach).DisplayName
AttachDtl(5, InxAttach) = "--"
' I suspect Attachment had a parent property in early versions
' of Outlook. It is missing from Outlook 2016.
On Error Resume Next
AttachDtl(5, InxAttach) = .Attachments(InxAttach).Parent
On Error GoTo 0
AttachDtl(6, InxAttach) = .Attachments(InxAttach).Position
' Class 5 is attachment. I have never seen an attachment with
' a different class and do not see the purpose of this property.
' The code will stop here if a different class is found.
Debug.Assert .Attachments(InxAttach).Class = 5
AttachDtl(7, InxAttach) = .Attachments(InxAttach).Class
Next
End If
InterestingItem = True
Else
InterestingItem = False
End If
End With
' The most used properties of the email have been loaded to variables but
' there are many more properies. Press F2. Scroll down classes until
' you find MailItem. Look through the members and note the name of
' any properties that look useful. Look them up using VB Help.
' #### You need to add code here to eliminate uninteresting items.
' #### For example:
'If SenderEmailAddress <> "JohnDoe#AcmeSoftware.co.zy" Then
' InterestingItem = False
'End If
'If InStr(Subject, "Accounts payable") = 0 Then
' InterestingItem = False
'End If
'If AttachCount = 0 Then
' InterestingItem = False
'End If
' #### If the item is still thought to be interesting I
' #### suggest extracting the required data to variables here.
' #### You should consider moving processed emails to another
' #### folder. The emails are being processed in reverse order
' #### to allow this removal of an email from the Inbox without
' #### effecting the index numbers of unprocessed emails.
If InterestingItem Then
With ExcelWkBk
With .Worksheets("Inbox")
' #### This code creates a dividing row and then
' #### outputs a property per row. Again it demonstrates
' #### statements that are likely to be useful in the final
' #### version
' Create dividing row between emails
.Rows(RowCrnt).RowHeight = 5
.Range(.Cells(RowCrnt, "A"), .Cells(RowCrnt, "B")) _
.Interior.Color = RGB(0, 255, 0)
RowCrnt = RowCrnt + 1
.Cells(RowCrnt, "A").Value = "Sender name"
.Cells(RowCrnt, "B").Value = SenderName
RowCrnt = RowCrnt + 1
.Cells(RowCrnt, "A").Value = "Sender email address"
.Cells(RowCrnt, "B").Value = SenderEmailAddress
RowCrnt = RowCrnt + 1
.Cells(RowCrnt, "A").Value = "Received time"
With .Cells(RowCrnt, "B")
.NumberFormat = "#"
.Value = Format(ReceivedTime, "mmmm d, yyyy h:mm")
End With
RowCrnt = RowCrnt + 1
.Cells(RowCrnt, "A").Value = "Subject"
.Cells(RowCrnt, "B").Value = Subject
RowCrnt = RowCrnt + 1
If AttachCount > 0 Then
.Cells(RowCrnt, "A").Value = "Attachments"
.Cells(RowCrnt, "B").Value = "Inx|Type|Path name|File name|Display name|Parent|Position|Class"
RowCrnt = RowCrnt + 1
For InxAttach = 1 To AttachCount
.Cells(RowCrnt, "B").Value = InxAttach & "|" & _
AttachDtl(1, InxAttach) & "|" & _
AttachDtl(2, InxAttach) & "|" & _
AttachDtl(3, InxAttach) & "|" & _
AttachDtl(4, InxAttach) & "|" & _
AttachDtl(5, InxAttach) & "|" & _
AttachDtl(6, InxAttach) & "|" & _
AttachDtl(7, InxAttach)
RowCrnt = RowCrnt + 1
Next
End If
If TextBody <> "" Then
' ##### This code was in the original version of the macro
' ##### but I did not find it as useful as the other version of
' ##### the text body. See below
' This outputs the text body with CR, LF and TB obeyed
'With .Cells(RowCrnt, "A")
' .Value = "text body"
' .VerticalAlignment = xlTop
'End With
'With .Cells(RowCrnt, "B")
' ' The maximum size of a cell 32,767
' .Value = Mid(TextBody, 1, 32700)
' .WrapText = True
'End With
'RowCrnt = RowCrnt + 1
' This outputs the text body with NBSP, CR, LF and TB
' replaced by strings.
With .Cells(RowCrnt, "A")
.Value = "text body"
.VerticalAlignment = xlTop
End With
TextBody = Replace(TextBody, Chr(160), "[NBSP]")
TextBody = Replace(TextBody, vbCr, "[CR]")
TextBody = Replace(TextBody, vbLf, "[LF]")
TextBody = Replace(TextBody, vbTab, "[TB]")
With .Cells(RowCrnt, "B")
' The maximum size of a cell 32,767
.Value = Mid(TextBody, 1, 32700)
.WrapText = True
End With
RowCrnt = RowCrnt + 1
End If
If HtmlBody <> "" Then
' ##### This code was in the original version of the macro
' ##### but I did not find it as useful as the other version of
' ##### the html body. See below
' This outputs the html body with CR, LF and TB obeyed
'With .Cells(RowCrnt, "A")
' .Value = "Html body"
' .VerticalAlignment = xlTop
'End With
'With .Cells(RowCrnt, "B")
' .Value = Mid(HtmlBody, 1, 32700)
' .WrapText = True
'End With
'RowCrnt = RowCrnt + 1
' This outputs the html body with NBSP, CR, LF and TB
' replaced by strings.
With .Cells(RowCrnt, "A")
.Value = "Html body"
.VerticalAlignment = xlTop
End With
HtmlBody = Replace(HtmlBody, Chr(160), "[NBSP]")
HtmlBody = Replace(HtmlBody, vbCr, "[CR]")
HtmlBody = Replace(HtmlBody, vbLf, "[LF]")
HtmlBody = Replace(HtmlBody, vbTab, "[TB]")
With .Cells(RowCrnt, "B")
.Value = Mid(HtmlBody, 1, 32700)
.WrapText = True
End With
RowCrnt = RowCrnt + 1
End If
End With
End With
End If
Next
With xlApp
With ExcelWkBk
' Write new workbook to disc
If Right(PathName, 1) <> "\" Then
PathName = PathName & "\"
End If
.SaveAs FileName:=PathName & FileName
.Close
End With
.Quit ' Close our copy of Excel
End With
Set xlApp = Nothing ' Clear reference to Excel
End Sub
Macros not included in original post but which some users of above macro have found useful.
Public Sub FindSelectedFolder(ByRef FolderTgt As MAPIFolder, _
ByVal NameTgt As String, ByVal NameSep As String)
' This routine (and its sub-routine) locate a folder within the hierarchy and
' returns it as an object of type MAPIFolder
' NameTgt The name of the required folder in the format:
' FolderName1 NameSep FolderName2 [ NameSep FolderName3 ] ...
' If NameSep is "|", an example value is "Personal Folders|Inbox"
' FolderName1 must be an outer folder name such as
' "Personal Folders". The outer folder names are typically the names
' of PST files. FolderName2 must be the name of a folder within
' Folder1; in the example "Inbox". FolderName2 is compulsory. This
' routine cannot return a PST file; only a folder within a PST file.
' FolderName3, FolderName4 and so on are optional and allow a folder
' at any depth with the hierarchy to be specified.
' NameSep A character or string used to separate the folder names within
' NameTgt.
' FolderTgt On exit, the required folder. Set to Nothing if not found.
' This routine initialises the search and finds the top level folder.
' FindSelectedSubFolder() is used to find the target folder within the
' top level folder.
Dim InxFolderCrnt As Long
Dim NameChild As String
Dim NameCrnt As String
Dim Pos As Long
Dim TopLvlFolderList As Folders
Set FolderTgt = Nothing ' Target folder not found
Set TopLvlFolderList = _
CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
' Split NameTgt into the name of folder at current level
' and the name of its children
Pos = InStr(NameTgt, NameSep)
If Pos = 0 Then
' I need at least a level 2 name
Exit Sub
End If
NameCrnt = Mid(NameTgt, 1, Pos - 1)
NameChild = Mid(NameTgt, Pos + 1)
' Look for current name. Drop through and return nothing if name not found.
For InxFolderCrnt = 1 To TopLvlFolderList.Count
If NameCrnt = TopLvlFolderList(InxFolderCrnt).Name Then
' Have found current name. Call FindSelectedSubFolder() to
' look for its children
Call FindSelectedSubFolder(TopLvlFolderList.Item(InxFolderCrnt), _
FolderTgt, NameChild, NameSep)
Exit For
End If
Next
End Sub
Public Sub FindSelectedSubFolder(FolderCrnt As MAPIFolder, _
ByRef FolderTgt As MAPIFolder, _
ByVal NameTgt As String, ByVal NameSep As String)
' See FindSelectedFolder() for an introduction to the purpose of this routine.
' This routine finds all folders below the top level
' FolderCrnt The folder to be seached for the target folder.
' NameTgt The NameTgt passed to FindSelectedFolder will be of the form:
' A|B|C|D|E
' A is the name of outer folder which represents a PST file.
' FindSelectedFolder() removes "A|" from NameTgt and calls this
' routine with FolderCrnt set to folder A to search for B.
' When this routine finds B, it calls itself with FolderCrnt set to
' folder B to search for C. Calls are nested to whatever depth are
' necessary.
' NameSep As for FindSelectedSubFolder
' FolderTgt As for FindSelectedSubFolder
Dim InxFolderCrnt As Long
Dim NameChild As String
Dim NameCrnt As String
Dim Pos As Long
' Split NameTgt into the name of folder at current level
' and the name of its children
Pos = InStr(NameTgt, NameSep)
If Pos = 0 Then
NameCrnt = NameTgt
NameChild = ""
Else
NameCrnt = Mid(NameTgt, 1, Pos - 1)
NameChild = Mid(NameTgt, Pos + 1)
End If
' Look for current name. Drop through and return nothing if name not found.
For InxFolderCrnt = 1 To FolderCrnt.Folders.Count
If NameCrnt = FolderCrnt.Folders(InxFolderCrnt).Name Then
' Have found current name.
If NameChild = "" Then
' Have found target folder
Set FolderTgt = FolderCrnt.Folders(InxFolderCrnt)
Else
'Recurse to look for children
Call FindSelectedSubFolder(FolderCrnt.Folders(InxFolderCrnt), _
FolderTgt, NameChild, NameSep)
End If
Exit For
End If
Next
' If NameCrnt not found, FolderTgt will be returned unchanged. Since it is
' initialised to Nothing at the beginning, that will be the returned value.
End Sub

Resources