I want to create macro that will add to the end of the selected slides' titles numbering in format (1/5).
I have manage to write that part with adding numbering. I am not able to prepare vba for looking for and replacing existing numbering. It is needed when, for whatever reason, the slide order will be changed and needs to be updated.
Sub SlideNumbering()
Dim shp As shape
Dim sld As Slide
Dim SldAll As Single
Dim SldNr As Single
SldAll = Application.ActiveWindow.Selection.SlideRange.Count
SldNr = SldAll
For s = SldAll To 1 Step -1
ActivePresentation.Slides(s).Shapes.Title.TextFrame.TextRange.InsertAfter " (" & SldNr & "/" & SldAll & ")"
SldNr = SldNr - 1
Next
End Sub
Here's a macro to delete the existing numbering. This uses a regex pattern to find a sequence of a space, a bracket, any number, a backslash, any number and a closing bracket:
Sub DeleteNumbering()
Dim regX As Object
Dim oSlide As Slide
Dim oShape As Shape
Dim Foundb As Boolean
Dim NewText$
Set regX = CreateObject("vbscript.regexp")
With regX
.Global = True
.Pattern = " \(\d(/)\d\)"
End With
ReplaceWord = ""
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Type = msoPlaceholder Then
If (oShape.PlaceholderFormat.Type = ppPlaceholderCenterTitle _
Or oShape.PlaceholderFormat.Type = ppPlaceholderTitle) _
And oShape.TextFrame.HasText Then
Foundb = regX.Test(oShape.TextFrame.TextRange.Text)
If Foundb = True Then
NewText$ = regX.Replace(oShape.TextFrame.TextRange.Text, "")
oShape.TextFrame.TextRange.Text = NewText$
End If
End If
End If
Next oShape
Next oSlide
End Sub
Related
I want to scan thorough a slide deck for text boxes containing a search string and leave the active presentation with Active selected slides.
*** I can search ok...>> Creating a list of slides with my text on
Function FindSlidesWithText(ByVal Owner As String) As String
Dim oSl As Slide
Dim oShp As Shape
Dim strSearch As String
Dim i As Integer
Dim slideList As String
If Owner = "" Then
strSearch = InputBox("Enter the text to search for:")
Else
strSearch = Owner
End If
Dim SomeoneSlides As String
SomeoneSlides = ""
SomeoneSlides = ""
For Each oSl In ActivePresentation.Slides
For Each oShp In oSl.Shapes
If oShp.HasTextFrame Then
If InStr(1, oShp.TextFrame.TextRange.Text, strSearch, vbTextCompare) > 0 Then
slideList = slideList & "Slide " & oSl.SlideNumber & ": " & oShp.TextFrame.TextRange.Text & vbCrLf
SomeoneSlides = SomeoneSlides & oSl.SlideNumber & ","
End If
End If
Next
Next
'we now have "search" unique slides.
MsgBox slideList
End Function
*** I note the following works as I want - leaving my in power points seeing highlight boxes around the slides 1,2,5
Dim r1 As SlideRange
Set r1 = ActivePresentation.Slides.Range(Array(1,2, 5)) 'this works
r1.Select
*** However, when i try to create this programmatically i fail (only highlighting the last slide in the array)
'Call SelectSlides("1,2,") '(output from the search)
Sub SelectSlides(YourSlideList As String)
Dim slideArr() As String
'Dim slideNum As Integer
Dim selAry As String
ActiveWindow.ViewType = PpViewType.ppViewNormal
ActiveWindow.Panes(1).Activate
slideArr = Split(YourSlideList, ",")
Dim r1 As SlideRange
For i = 0 To (UBound(slideArr) - 1)
slideNum = CInt(slideArr(i))
selAry = selAry & slideNum
'For all slides selected - modify as needed....
With ActivePresentation.Slides.Range(slideNum)
'Ignore the default background settings.
.FollowMasterBackground = False
'And add a new background color and effect.
.Background.Fill.PresetGradient msoGradientHorizontal, 1, msoGradientDaybreak
End With
Set r1 = ActivePresentation.Slides.Range(Array(slideNum)) 'this works
Next
r1.Select
End Sub
'///this is now working
Sub SelectSlides(YourSlideList As String)
Dim slideArr() As String
'Dim slideNum As Integer
Dim selAry As String
Dim selAry2(99) As Long
ActiveWindow.ViewType = PpViewType.ppViewNormal
ActiveWindow.Panes(1).Activate
slideArr = Split(YourSlideList, ",")
' slideArr2() = Split(YourSlideList, ",")
For i = 0 To (UBound(slideArr) - 1)
slideNum = CInt(slideArr(i))
selAry = selAry & slideNum
selAry2(i) = slideNum
'For all slides selected - modify as needed....
With ActivePresentation.Slides.Range(slideNum)
'Ignore the default background settings.
.FollowMasterBackground = False
'And add a new background color and effect.
.Background.Fill.PresetGradient msoGradientHorizontal, 1, msoGradientDaybreak
End With
Next
Dim r1 As SlideRange
Set r1 = ActivePresentation.Slides.Range(selAry2)
r1.Select
End Sub
I'm investigating how to automatically update a visio file created with one mastershape (v1.0.vssx) to the next version of the mastershape (v1.1.vssx). When updating each master shape, use Master.Name as the key.
With the code below, I was able to open the vsdx file and vssx and open their respective Masters.
vssx_Master = vssxMaster
vsdx_shape.master = vssx_Master
I wondered if I could update the master shape with the code, but unfortunately vssxMaster is the same as vssxMaster.Name and its type is String.
Is there a way to replace the Master of one shape with another?
not work...
Sub Visio_Update(ByRef VISIOpath As String, ByRef except_sheets() As String, ByRef VSSXpath As String)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim vsoApp As Visio.Application
Dim vsoDoc As Visio.Document
Dim vsoPage As Visio.Page
Dim vsoItemsCnt As Long
Dim vsoShape As Visio.Shape
Dim FileName As String
Dim FileText As String
FileName = Dir(VISIOpath)
FileName = Replace(FileName, ".vsdx", "")
ChDir ThisWorkbook.path
Set vsoApp = CreateObject("Visio.Application")
Call vsoApp.Documents.OpenEx(VISIOpath, visOpenRW)
Set vsoDoc = vsoApp.Documents.Item(1)
vsoItemsCnt = vsoApp.Documents.Count
Call vsoApp.Documents.OpenEx(VSSXpath, visOpenRW)
Set vssxDoc = vsoApp.Documents.Item(vsoItemsCnt + 1)
Set vssxMasters = vssxDoc.Masters
For Each vsoPage In vsoDoc.Pages
For Each vsoShape In vsoPage.Shapes
If Not (vsoShape.Master Is Nothing) Then
On Error Resume Next
mastername = vsoShape.Master.Name
vsoShape.ReplaceShape vssxMasters.Item(vsoShape.Master.Name)
If Err.Number = 0 Then
Debug.Print ("Masters.Item")
Debug.Print "updated succeeded : ", mastername
Err.Clear
Else
Debug.Print ("Masters.Item")
Debug.Print Err.Description
Err.Clear
End If
End If
Next
Next
vsoDoc.SaveAs ThisWorkbook.path & "\data\" & FileName & "_updated_.vsdx"
Application.ScreenUpdating = True
End Sub
Sub test()
choosed_path = "C:\Users\11665307\Desktop\data\vs1.vsdx"
Update_Template = "C:\Users\11665307\Documents\test.vssx"
Call Visio_Update(choosed_path, except_sheets, (Update_Template))
End Sub
I wondered if I could update the master shape with the code
You dont need iterate all masters into stencil :)
For Each vsoPage In doc.Pages
For Each vsoShape In vsoPage.Shapes
If Not (vsoShape.Master Is Nothing) Then
vsoShape.ReplaceShape vssxMasters.Item(vsoShape.Master.Name)
End If
Next
Next
You must iterate through all the shapes on the page. If the shape was created based on the master from stencil v.1.0, then replace it with the corresponding master v.1.1. using the ReplaceShape method
Sub ttt()
Dim sh As Shape
For Each sh In ActivePage.Shapes
If sh.Master.NameU = "Circle" Then sh.ReplaceShape Application.Documents.Item("BLOCK_M.vssx").Masters.ItemU("Diamond")
Next
End Sub
I have an existing piece of code (see below) for importing a batch of photos and creating a slide show. At present, the code is creating these slides on a blank background with a title only. How can I modify it so it will choose a specific slide layout from the Master slides? I know it has something to do with this line in the code:
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
I looked here and tried some ideas but I just keep getting bugs: Applying layout to a slide from specific Master
Here's the full program:
Sub ImportStuffFromTextFile()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim fs As Object
Dim f As Object
Dim PicDesc() As String
Dim strFile As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Text Files", "*.txt"
.AllowMultiSelect = False
.InitialFileName = ActivePresentation.Path
If .Show = -1 Then
strFile = .SelectedItems.Item(1)
End If
If strFile = "" Then Exit Sub
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strFile, 1, 0)
Do While Not f.AtEndOfStream
PicDesc = Split(f.readline, Chr(9))
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
Set oPic = oSld.Shapes.AddPicture(FileName:=PicDesc(0), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0)
If oSld.Shapes.HasTitle Then
oSld.Shapes.Title.TextFrame.TextRange.Text = PicDesc(1)
With oPic
.Height = 469.875
.Width = 626.325
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = oSld.Shapes.Title.Top + oSld.Shapes.Title.Height + 7
End With
End If
Set oPic = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub
When you say you keep getting bugs, what do you mean?
Are you getting error messages? If so, what are the error numbers/descriptions? Where does the code break?
If not, and you're getting 'bugs', what should the final output look like and how does this differ from that?
I would say that one big unknown here is the text file input. According to your code, it seems as though it needs to have a series of filenames and corresponding picture descriptions on each line of the text file, separated by a tab. Critically, it must be a tab and not 2 spaces or 4 spaces or 10 spaces or a hyphen ... it must be a tab. Is that the structure of the text file you're using as input?
PowerPoint treats built-in layouts differently than custom ones. You can't call a custom layout by name. Instead, you have to loop through each custom layout to find the one that has the right name, then use it:
Sub AddSlideFromCustomLayout()
Dim oLayout As CustomLayout
Dim oSlide As Slide
For Each oLayout In ActivePresentation.SlideMaster.CustomLayouts
If oLayout.Name = "Custom Layout Name" Then
Set oSlide = ActivePresentation.Slides.AddSlide(ActivePresentation.Slides.Count + 1, oLayout)
End If
Next oLayout
End Sub
Here's your listing with the code replacing the Set oSld line:
Sub ImportStuffFromTextFile()
Dim oLayout As CustomLayout
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim fs As Object
Dim f As Object
Dim PicDesc() As String
Dim strFile As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Text Files", "*.txt"
.AllowMultiSelect = False
.InitialFileName = ActivePresentation.Path
If .Show = -1 Then
strFile = .SelectedItems.Item(1)
End If
If strFile = "" Then Exit Sub
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strFile, 1, 0)
Do While Not f.AtEndOfStream
PicDesc = Split(f.readline, Chr(9))
For Each oLayout In ActivePresentation.SlideMaster.CustomLayouts
If oLayout.Name = "Custom Layout Name" Then
Set oSld = ActivePresentation.Slides.AddSlide(ActivePresentation.Slides.Count + 1, oLayout)
End If
Next oLayout
Set oPic = oSld.Shapes.AddPicture(FileName:=PicDesc(0), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0)
If oSld.Shapes.HasTitle Then
oSld.Shapes.Title.TextFrame.TextRange.Text = PicDesc(1)
With oPic
.Height = 469.875
.Width = 626.325
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = oSld.Shapes.Title.Top + oSld.Shapes.Title.Height + 7
End With
End If
Set oPic = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub
I am trying to delete ppt slides using specific keywords.my code is given below:
Private Sub CommandButton1_Click()
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
Dim ppMaster
Dim sText As Variant
strFolderName = "D:\Shaon_Paul\pptss"
strFileName = Dir(strFolderName & "\*.pptx*")
sText = InputBox("Give me some input")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
Dim oSld As Slide
Dim oShp As Shape
Dim L As Long
For L = ActivePresentation.Slides.Count To 1 Step -1
Set oSld = ActivePresentation.Slides(L)
For Each oShp In oSld.Shapes
On Error Resume Next
If oShp.HasTextFrame Then
If UBound(Split(oShp.TextFrame.TextRange, sText)) > 0 Then
PP.Slides(L).Delete
End If
End If
Next oShp
Next L
Set ppMaster = PP.SlideMaster
With ppMaster
If UBound(Split(.HeadersFooters.Footer.Text, sText)) > 0 Or UBound(Split(.HeadersFooters.Header.Text, sText)) > 0 Then
PP.Slides(L).Delete
End If
End With
PP.Save
PP.Close
strFileName = Dir
Loop
End Sub
Now this code will open a input box where I have to give my keywords and It will delete the slides in a ppt available in the folder where I have mentioned the path name.
Unfortunately while debugging the code
If UBound(Split(oShp.TextFrame.TextRange, sText)) > 0 Then
PP.Slides(L).Delete
End If
it will jump without executing this code above and unable to delete the slide by giving specific keyword name. Need help to resolve this issue.
I have a folder with 10 PowerPoint presentations. Each presentation has 20-25 slides.
Suppose I have a keyword "CX404","AR50". The macro should delete all slides having that keyword in the 10 presentations.
Public Sub DoFiles()
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
'set default directory here if needed
strFolderName = "D:\Users\Desktop\Shaon\pptss"
strFileName = Dir(strFolderName & "\*.pptx*")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'your code
Dim oSld As Slide
Dim oShp As Shape
Dim L As Long
For L = ActivePresentation.Slides.Count To 1 Step -1
Set oSld = ActivePresentation.Slides(L)
For Each oShp In oSld.Shapes
If oShp.HasTextFrame Then
Select Case UCase(oShp.TextFrame.TextRange)
Case Is = "CX400", "AR50"
oSld.Delete
Case Else
'not found
End Select
End If
Next oShp
Next L
PP.Close
strFileName = Dir
Loop
End Sub
I can open all ppts in the folder. I am not be able to delete slides using my specific keywords.
I have slightly modified your listing and it works for me:
Option Explicit
Public Sub DoFiles()
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
Dim sText As String
strFolderName = "D:\111\"
strFileName = Dir(strFolderName & "\*.pptx*")
sText = "TEST"
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
Dim oSld As Slide
Dim oShp As Shape
Dim L As Long
For L = ActivePresentation.Slides.Count To 1 Step -1
Set oSld = ActivePresentation.Slides(L)
For Each oShp In oSld.Shapes
On Error Resume Next
If oShp.HasTextFrame Then
If UBound(Split(oShp.TextFrame.TextRange, sText)) > 0 Then
PP.Slides(L).Delete
End If
End If
Next oShp
Next L
PP.Save
PP.Close
strFileName = Dir
Loop
End Sub