Sub changelinkspp()
Dim oshp As Shape
Dim osld As Slide
Const replacethis As_String= _
"file:///C:\Users\admin\Desktop\file%20name%old\"
Const replacewith As String = _
"file:///\\local\new%20folder\file%20name%new"
On Error Resume Next
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.LinkFormat.SourceFullName Like "*admin*" Then
oshp.LinkFormat.SourceFullName = _
Replace(oshp.LinkFormat.SourceFullName, replacethis, replacewith)
it is where the main problem occurs. It does not work.
It seems like replace function in vba does not have an affect on oshp.LinkFormat.SourceFullName
oshp.LinkFormat.Update
End If
Next oshp
Next osld
End Sub
{Steve Rindsberg added:}
Try this as a test:
Sub SimpleTest()
Dim oshp As Shape
Dim osld As Slide
' For test purposes:
Dim sSource As String
sSource = "file:///C:\Users\admin\Desktop\file%20name%old\"
Const replacethis As String = _
"file:///C:\Users\admin\Desktop\file%20name%old\"
Const replacewith As String = _
"file:///\\local\new%20folder\file%20name%new"
On Error Resume Next
If sSource Like "*admin*" Then
Debug.Print Replace(sSource, replacethis, replacewith)
End If
End Sub
Related
I have an issue aligning shapes using VBA on PowerPoint (office 360).
I know I can use .Shapes.Range.Align msoAlignBottom, msoFalse
but I don't understand how to make it work with a specific shape name as I always have an error or nothing is happening.
This is the code in which I would like to implement this action:
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
sn = InputBox("Enter the name of the shape")
On Error Resume Next
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.Name = sn Then
Select Case oSh.PlaceholderFormat.Type
Case 1, 3 'Title
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape ' OR msoAutoSizeNone
Case 2, 7 'Text / Content
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSh.Shapes.Range.Align msoAlignBottom, msoTrue
End Select
End If
Next oSh
Next oSl
End Sub
Thank you very much for your help,
Try this code:
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
'sn = InputBox("Enter the name of the shape")
sn = "Name1" 'debug
'On Error Resume Next
For Each oSl In ActivePresentation.Slides
For i = 1 To oSl.Shapes.Count
Set oSh = oSl.Shapes(i)
If oSh.Name = sn Then
Select Case oSh.Type 'placeholder or not placeholder?
Case msoPlaceholder
' it's a placeholder! check the placeholder's type
If oSh.PlaceholderFormat.Type = ppPlaceholderTitle _
Or oSh.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
'do smth with placeholder
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
End If
Case Else 'it's not a placeholder
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSl.Shapes.Range(i).Align msoAlignBottoms, msoTrue 'align it to bottom of the slide
End Select
End If
Next
Next oSl
End Sub
I also recommend removing the On Error Resume Next statement because it hides errors and you don't get useful information about how the code works.
You have to create a ShapeRange that includes the shapes you want to align. Since you are keying off the name of the shape, the example below shows how a wildcard can be used.
Option Explicit
Sub Test()
LineUpShapes 1, "Rectangle", msoAlignTops
End Sub
Sub LineUpShapes(ByVal SlideNumber As Long, _
ByVal ShapeName As String, _
ByVal alignment As MsoAlignCmd)
Dim sl As Slide
Set sl = ActivePresentation.Slides(SlideNumber)
Dim namedShapes() As Variant
Dim shapeCount As Integer
Dim sh As Shape
For Each sh In sl.Shapes
If sh.Name Like (ShapeName & "*") Then
shapeCount = shapeCount + 1
ReDim Preserve namedShapes(shapeCount) As Variant
namedShapes(shapeCount) = sh.Name
Debug.Print "shape name " & sh.Name
End If
Next sh
Dim shapesToAlign As ShapeRange
Set shapesToAlign = sl.Shapes.Range(namedShapes)
shapesToAlign.Align alignment, msoFalse
End Sub
Thank you so much Алексей!
I have readapted your code and it works perfectly! It is always a placeholder in my case ;)
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
sn = InputBox("Enter the name of the shape")
For Each oSl In ActivePresentation.Slides
For i = 1 To oSl.Shapes.Count
Set oSh = oSl.Shapes(i)
If oSh.Name = sn Then
Select Case oSh.PlaceholderFormat.Type
Case 1, 3 'Title
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape ' OR msoAutoSizeNone
Case 2, 7 'Text / Content
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSl.Shapes.Range(i).Align msoAlignBottoms, msoTrue 'align it to bottom of the slide
End Select
End If
Next
Next oSl
End Sub
I am trying to add a slide, created with the below code, to a specific section called "Index".
Currently it is going two slides below the last one but because the number of slides will be chaining I can't reference using -2 function so I have to resort to section referencing.
Public Function GetLayout( _
LayoutName As String, _
Optional ParentPresentation As Presentation = Nothing) As CustomLayout
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
Dim oLayout As CustomLayout
For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
If oLayout.Name = LayoutName Then
Set GetLayout = oLayout
Exit For
End If
Next
End Function
Sub AddCustomSlide()
Dim oSlides As Slides, oSlide As Slide
Set oSlides = ActivePresentation.Slides
Set oSlide = oSlides.AddSlide(oSlides.Count - 2, GetLayout("Processwindow"))
End Sub
The solution is to use the .MoveToSectionStart method of the Slide object.
In your AddCustomSlide routine, add one line:
Sub AddCustomSlide()
Dim oSlides As Slides, oSlide As Slide
Set oSlides = ActivePresentation.Slides
Set oSlide = oSlides.AddSlide(oSlides.Count - 2, GetLayout("Title Only"))
oSlide.MoveToSectionStart GetSectionNumber("Index")
End Sub
Since you need the section number of the "Index" section, I've written a quick function to return that number:
Private Function GetSectionNumber( _
ByVal sectionName As String, _
Optional ParentPresentation As Presentation = Nothing) As Long
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
GetSectionNumber = -1
With ParentPresentation.SectionProperties
Dim i As Long
For i = 1 To .Count
If .Name(i) = sectionName Then
GetSectionNumber = i
Exit Function
End If
Next i
End With
End Function
I have a macro that creates a new slide at the beginning of a section in my PowerPoint presentation.
Is there a method to replace .MoveToSectionStart that would move the slide to the end?
The method is found in the Sub at the end called Sub AddCustomSlide().
Private Function GetSectionNumber( _
ByVal sectionName As String, _
Optional ParentPresentation As Presentation = Nothing) As Long
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
GetSectionNumber = -1
With ParentPresentation.SectionProperties
Dim i As Long
For i = 1 To .Count
If .Name(i) = sectionName Then
GetSectionNumber = i
Exit Function
End If
Next i
End With
End Function
Public Function GetLayout( _
LayoutName As String, _
Optional ParentPresentation As Presentation = Nothing) As CustomLayout
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
Dim oLayout As CustomLayout
For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
If oLayout.Name = LayoutName Then
Set GetLayout = oLayout
Exit For
End If
Next
End Function
Sub AddCustomSlide()
Dim oSlides As Slides, oSlide As Slide
Dim Shp As Shape
Dim Sld As Slide
Set oSlides = ActivePresentation.Slides
Set oSlide = oSlides.AddSlide(oSlides.Count - 2, GetLayout("Processwindow"))
oSlide.MoveToSectionStart GetSectionNumber("Main Process")
End Sub
Sorry, there's no such method. Here's how to insert one at the end:
Sub AddCustomSlide()
Dim oSlides As Slides, oSlide As Slide
Dim Shp As Shape
Dim Sld As Slide
Dim SecNum As Integer, SlideCount As Integer, FirstSecSlide As Integer
Set oSlides = ActivePresentation.Slides
Set oSlide = oSlides.AddSlide(oSlides.Count - 2, GetLayout("Processwindow"))
SecNum = GetSectionNumber("Main Process")
With ActivePresentation.SectionProperties
SlideCount = .SlidesCount(SecNum)
FirstSecSlide = .FirstSlide(SecNum)
End With
oSlide.MoveTo toPos:=FirstSecSlide + SlideCount - 1
End Sub
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
I am trying to code some vba in powerpoint to search for a word in the slideshow and then go to that slide and format the word in some way so that it stands out. So far I have add an activex textbox and used the below code:
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger,ByVal Shift As Integer)
Dim osld As Slide
Dim oshp As Shape
Dim b_found As Boolean
If KeyCode = 13 Then 'ENTER PRESSED
If Me.TextBox1.Text <> "" Then
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
If InStr(UCase(oshp.TextFrame.TextRange), UCase(Me.TextBox1.Text))>0 Then
SlideShowWindows(1).View.GotoSlide (osld.SlideIndex)
Me.TextBox1.Text = ""
b_found = True
Exit For
End If
End If
End If
Next oshp
If b_found = True Then Exit For
Next osld
End If
If b_found = False Then MsgBox "Not found"
End If
End Sub
This works fine for finding the slide with the word on but doesn't format the word. Any ideas??
Here's an example that you can pick apart and use bits of:
Dim oSl As Slide
Dim oSh As Shape
Dim oTxtRng As TextRange
Dim sTextToFind As String
sTextToFind = "Text"
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
If InStr(oSh.TextFrame.TextRange.Text, sTextToFind) > 0 Then
Set oTxtRng = oSh.TextFrame.TextRange.Characters(InStr(oSh.TextFrame.TextRange.Text, sTextToFind), Len(sTextToFind))
Debug.Print oTxtRng.Text
With oTxtRng
.Font.Bold = True
End With
End If
End If
End If
Next
Next
Basically, the idea is to find the text (as you've already done) then get a range that represents the found text and format the range to suit. In this case, by turning it bold.
Thanks #steverindsberg
In case anyone would like to know what I ended up using, I have amalgamted both codes into:
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim osld As Slide
Dim oshp As Shape
Dim b_found As Boolean
Dim oTxtRng As TextRange
Dim sTextToFind As String
sTextToFind = Me.TextBox1.Text
If KeyCode = 13 Then 'ENTER PRESSED
If Me.TextBox1.Text <> "" Then
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
If InStr(UCase(oshp.TextFrame.TextRange), UCase (Me.TextBox1.Text)) > 0 Then
SlideShowWindows(1).View.GotoSlide (osld.SlideIndex)
Set oTxtRng = oshp.TextFrame.TextRange.Characters(InStr(oshp.TextFrame.TextRange.Text, sTextToFind), Len(sTextToFind))
Debug.Print oTxtRng.Text
With oTxtRng
.Font.Bold = True
End With
b_found = True
Exit For
End If
End If
End If
Next oshp
If b_found = True Then Exit For
Next osld
End If
If b_found = False Then MsgBox "Not found"
End If
End Sub
Thanks for your help!