Accessing Master Slides for Multiple Themes in a Single Presentation - vba

I've been working on a VBA macro that automatically creates watermark on a master slide for multiple named people and then automatically saves it to separate PDFs. All of this works well now. However, some presentations I may need to watermark, have multiple themes applied to different slides. (eg. first half is using theme 1 and the second half is using theme 2) Each theme has a separate master slide. When I use ActivePresentation.SlideMaster, this only affects the top master slide in the Slide Master view. How would I go about accessing master slides for the other themes?
Edit: Here is the code I have. The xlVariables come from an Excel file. The watermark line refers to the text box that is put furthest back. I searched for a way to access multiple master slides but I couldn't find anything on it.
xlName = Range("A" & CStr(count))
xlCompany = Range("B" & CStr(count))
xlDate = Range("C" & CStr(count))
xlMail = Range("D" & CStr(count))
'Create the watermark
ActivePresentation.SlideMaster.Shapes(1).TextFrame.TextRange.text = "Confidential - Do Not Share" & vbNewLine & "Issued to " _
& xlName & vbNewLine & "on " & xlDate & vbNewLine & xlCompany & " - Internal Use Only"

Here's some sample code that will do something (that you define) to each master (oDes.SlideMaster in the code) and layout (oLay) in a presentation.
Modify DoSomethingWithShapeContainer to do whatever it is you need to do to each master/layout.
Sub AllMastersAndLayouts()
Dim oLay As CustomLayout
Dim oDes As Design
With ActivePresentation
For Each oDes In .Designs
Call DoSomethingWithShapeContainer(oDes.SlideMaster)
For Each oLay In oDes.SlideMaster.CustomLayouts
Call DoSomethingWithShapeContainer(oLay)
Next
Next
End With
End Sub
Sub DoSomethingWithShapeContainer(oShapeContainer As Object)
With oShapeContainer.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 20, 200, 50)
.TextFrame.TextRange.Text = "I did something here"
End With
End Sub

Related

How can I manage the active document reference in word to save and close my newly created output?

I am trying to use VBA in an open .docm file to open a 2nd read only .docx file and then insert -> object -> text from file (a 3rd read only .docx stored within the same folder).
The below code correctly opens and merges the two files but when it comes to saving the output it returns a Run-Time 13 “mismatch” error. My limited understanding leads me to believe that at the point where I am saving, the active document reference is still the original .docm and it is the .docx designation that then causes the conflict.
I am really struggling to manage the active document reference to avoid this. Presumably I am missing something very simple, all assistance is very gratefully received.
Documents.Open ActiveDocument.Path & "\DocA.docx", Visible:=True
Selection.InsertFile FileName:=ActiveDocument.Path & "\DocB.docx", Range:="", _
ConfirmConversions:=False, Link:=False, Attachment:=False
ActiveDocument.SaveAs2 "C:\Users\" & Environ("UserName") & "\DocC" & ".docx", FileFormat:= _
wdFormatXMLDocument
ActiveWindow.Close
Putting flesh on John Korchok's comment:
Sub deleteme3()
Dim oldDoc As Document
Set oldDoc = Documents.Open(ActiveDocument.Path & "\DocA.docx", Visible:=True)
oldDoc.Activate
selection.Collapse Direction:=wdCollapseEnd 'to insert at end of document
selection.Range.InsertBreak Type:=wdPageBreak
Selection.EndKey Unit:=wdStory
Selection.InsertFile FileName:=ActiveDocument.Path & "\DocB.docx", range:="", _
ConfirmConversions:=False, Link:=False, Attachment:=False
oldDoc.SaveAs2 "C:\Users\" & Environ("UserName") & "\DocC" & ".docx", FileFormat:= _
wdFormatXMLDocument
oldDoc.Close
Set oldDoc = Nothing
End Sub
Note this puts the inserted document at the end of the original document. You may want to use a next-page section break instead if there is header/footer differentiation. If you need that, please comment and I will include it.
There are a number of break types. Here is the enumeration of all of them if you are interested. The following types create a page break of one sort or another:
wdPageBreak (the default)
wdSectionBreakNextPage
wdSectionBreakOddPage (starts section on next odd-numbered page - good for chapters)
wdSectionBreakEvenPage (starts section on next even-numbered page - rarely used)
If wanting to preserve headers and footers additional code would be needed.
(Every section in a Word document has three headers and three footers, even if they are not displayed or used.)
' Break Link to Previous in newly added section for all of the headers and footers
Dim oHeaderFooter As HeaderFooter
Dim iCounter As Long
Let iCounter = ActiveDocument.Sections.Count
' break link in headers
For Each oHeaderFooter In ActiveDocument.Sections(iCounter).Headers
Let oHeaderFooter.LinkToPrevious = False
Next oHeaderFooter
' repeat for footers
For Each oHeaderFooter In ActiveDocument.Sections(iCounter).Footers
Let oHeaderFooter.LinkToPrevious = False
Next oHeaderFooter

Updating Headers is screwing up my page orientation and scaling

so I burned a whole day yesterday getting side tracked on a different process for toggling images on and off based on a cell value. The funny thing is it all started from me writing a wee bit of VBA to update the Header and Footer Information automatically prior to printing or saving.
Situation
I have 12 worksheets currently in the workbook.
Sheet1(HEADER AND FOOTER) contains all the information to go into the various header/footer locations.
Sheets 2-7 are the pages that get printed as a group and have the header and footers on them.
Sheets 2-6 are portrait letter pages with multiple pages on each sheet (I cannot force 1 page wide on certain sheets due to their layout).
Sheet 7 is landscape letter page.
If I print /save as pdf prior to writing the code and changing each page separately everything worked nice, all paged printed in their respective page layouts/setups.
When I implemented the VBA code in the beforeprint or beforesave in ThisWorkbook things did not go well. Depending on which variation of the VBA code I tried, either sheet 7 would adopt the portrait orientation and scaling same as the other sheets OR all sheets would be landscape and have the scaling of sheet 7.
OBJECTIVE
Update sheets 2 through 7 with the appropriate header/footer information while maintaining their original assigned page settings. That way when I print, sheets 2-6 are all portrait and sheet 7 is landscape all on letter paper.
What I have tried
I recorded a macro to get the base structure. Originally it had all sheets in one area and modifying them. I figured that the pages were all being made the same because they were all selected at the same time, So instead of selecting all them at once, I thought I would try modifying one sheet at a time. This lead to only one worksheet being printed, so I had to add reselecting all the sheets as the last line of code. This is the VBA code I currently have:
Private Sub WorkbookBeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "HEADER AND FOOTER" And InStr(1, Left(ws.Name, 5), "Table", vbTextCompare) = 0 Then
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.CenterHeader = Sheets(1).Range("B1").Value & Chr(10) & "Load Evaluation"
.RightHeader = _
"Calculated by: " & Sheets(1).Range("B3").Value & " Date: " & Sheets(1).Range("B4").Value & Chr(10) & "Checked By: " & Sheets(1).Range("B5").Value & " Date: " & Sheets(1).Range("B6").Value
.LeftFooter = "Project Number: " & Sheets(1).Range("B2").Value
.CenterFooter = "Page &P/&N"
.RightFooter = "Print Date: " & Sheets(1).Range("B7").Value
End With
End If
Next ws
Sheets(Array("General", "Loads", "Capacity", "Analysis", "POSTING", "SUMMARY")).Select
Sheets("General").Activate
End Sub
I was thinking maybe there is something wrong with the way I implemented the For Each as that is not a form I am familiar with. I was originally thinking about using a For x = 2 to ws.count - UDF_worksheet_count_names_starting_with_tables to loop through the sheets. I thought I would check in here first to see if there is a better approach to this problem.
So first off thanks to D.K. for the suggestion to change from activesheet.page setup to ws.pagesetup. This however did not solve the problem but did make a lot more sense. I then stumbled onto this thread: Excel headers/footers won't change via VBA unless blank. I was wondering what the line
Application.PrintCommunication = False
actually did. When I commented that line out the last sheet's layout no longer got updated/changed to match the other pages and things are working as intended.
This is what the final code looks like:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "HEADER AND FOOTER" And InStr(1, Left(ws.Name, 5), "Table", vbTextCompare) = 0 Then
With ws.PageSetup
.CenterHeader = Sheets(1).Range("B1").Value & Chr(10) & "Load Evaluation"
.RightHeader = _
"Calculated by: " & Sheets(1).Range("B3").Value & " Date: " & Sheets(1).Range("B4").Value & Chr(10) & "Checked By: " & Sheets(1).Range("B5").Value & " Date: " & Sheets(1).Range("B6").Value
.LeftFooter = "Project Number: " & Sheets(1).Range("B2").Value
.CenterFooter = "Page &P/&N"
.RightFooter = "Print Date: " & Sheets(1).Range("B7").Value
End With
End If
Next ws
End Sub

VBA retrieve hyperlink target sheet?

I'm trying to retrieve the sheet reference location from a hyperlink that's in a cell
The following doesn't seem to work as test doesn't return anything, even though G8 points to Sheet: KO in Cell A19
test = Range("G8").Hyperlinks(3).Address
Now if I run the following:
For Each hl In Sheets("LIST").Hyperlinks
MsgBox "Range " & hl.Range.Address & " addr " & _
hl.Address & " text " & hl.TextToDisplay
Next hl
It cycles through and finds the correct address but I can't seem to work out how to detect the sheet it's pointing. Also the loop is a bit of a mess because it errors out once it has found the first and only hyperlink in this situation. And it's not always specific for G8. I guess I could just throw an if statement in and exit the for loop early.
Regardless of that, I can't find anywhere in stackoverflow, google, microsofts "hyperlinks" docs a way to get the sheet name.
See below sample illustration:
SubAddress is what you want:
Sub Test()
Dim hl As Hyperlink, r As Range
Set hl = ActiveSheet.Hyperlinks(1)
Set r = Application.Evaluate(hl.SubAddress)
Debug.Print "Sheet: '" & r.Parent.Name & "'", "Range:" & r.Address()
End Sub

PowerPoint VBA: How to save a pic in a particular file format & not the whole presentation?

I'm using vba in PowerPoint. I'm trying to compress orginal picture files from a specified folder to a smaller size. I was able to achieve that. However, I want to save the new compressed picture into a destination folder.
The following code will save the presenation or slide with the picture. But I only want the picture. I'm pretty sure I have to use ActivePresentation.SaveAs. But it will only let me save the slide. How can I save the pic alone & not the slide?
Also, I seem to have another problem when I try to save the modified pic. It saves the presentation into a folder in the destination with a filename of "Slide1.bmp". Any idea why & how can I change this?
Dim strSrcPath As String, strDestPath As String
Dim strSrcPic As String
Dim objPic As Shape
Dim x as Integer
strSrcPath = "C:\Temp\Pics\In\"
strDestPath = "C:\Temp\Pics\Out\"
strSrcPic = Dir(strSrcPath)
Do While strSrcPic <> ""
x = x + 1
Set objPic = ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=strSrcPath & strSrcPic, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=100, _
Height:=100)
With objPic
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
End With
objPic.Select
ActivePresentation.SaveAs _
FileName:=strDestPath & "ModPicture(" & x & ").bmp", _
FileFormat:=ppSaveAsBMP, EmbedTrueTypeFonts:=msoFalse
objPic.Delete
strSrcPic = Dir 'Get next entry.
Loop
Thanks #JSRWilson for the following response:
"You do have to right click in View >Object Browser >> Show Hidden Members
Assuming objPic is still a reference to the compressed pic
objPic.Export(strDestPath & "& "ModPicture(" & x & ").bmp", ppSaveAsBMP)"

How to determine Audio file path and availability in PowerPoint 2010

I am duplicating with minor date changes, slideshows created by another user, who constantly forgets to embed audio, but links it instead.
Is there some simple way to determine whether audio is embedded or linked, and what the source file path is, if it is linked? If I could run a macro to just determine this it would help enormously.
Not sure how to approach this, but individually opening dozens of files to determine audio is there defeats everything else that is scripted in this case.
This is the way I would do it:
Sub DetermineAudioLinks()
Dim p As Presentation: Set p = ActivePresentation
Dim s As Slide
Dim sh As Shape
For Each s In p.Slides
For Each sh In s.Shapes
If sh.Type = msoMedia Then
If sh.MediaType = ppMediaTypeSound Then
Debug.Print "Slide " & s.SlideNumber & ":" ; sh.Name
If sh.MediaFormat.IsLinked Then
Debug.Print vbTab & "Is Linked: True"
Debug.Print vbTab & sh.LinkFormat.SourceFullName
End If
End If
End If
Next
Next
End Sub
Note the the MediaFormat property above is PowerPoint 2010 only - it won't work with earlier versions of PowerPoint.