I want to write VBA code for inserting the image as per the slide name from the folder means after running the VBA it automatically inserts the images as per the slide name
For eg: if the slide contains "Top View" in the text box then by running the VBA script it should automatically pick the picture having name "Top View" from the particular folder.
As shown in the attached images.
Slide having by text box as top view
Folder Path
I have posted one of the question some days ago but I didn't find the exact solution here is the link of my previous question which I have asked
Previous question
One of member has shared one code but its working properly also I modified it little bit though its not working properly if possible pl. help me
Option Explicit
Sub image_insert()
Dim objPresentaion As Presentation
Dim objSlide As Slide
Dim objImageBox As Shape
Dim sSlideTitle As String
Dim sFolder As String
Set objPresentaion = ActivePresentation
sFolder = "C:\Users\mehta\Desktop\Folder for ppt images\Top
View.jpg"
For Each objSlide In objPresentaion.Slides
sSlideTitle = GetTitleText(objSlide)
' WAS there a title on the slide?
If Len(sSlideTitle) > 0 Then
' make sure the image exists
If Len(Dir$(sFolder & sSlideTitle & ".JPG")) > 0 Then
Set objImageBox = objSlide.Shapes.AddPicture(sFolder &
sSlideTitle & ".JPG", _
msoCTrue, msoCTrue, 25, 25)
Else
' Comment this out later
' MsgBox "Image missing: " & sSlideTitle
End If
Else
' comment this out later:
MsgBox "This slide has no title"
End If
Next ' Slide
End Sub
Function GetTitleText(oSl As Slide) As String
Dim sTemp As String
With oSl
' handle errors in case there's no slide title
On Error Resume Next
sTemp = .Shapes.Title.TextFrame.TextRange.Text
If Err.Number <> 0 Then
sTemp = ""
End If
End With
GetTitleText = sTemp
End Function
Regards.
Related
I'm trying to extract few specific slide numbers from each ppt and trying to paste them into a single ppt using VBA.But Im facing this error.Im quite new to VBA ,so it would be of great help how to proceed further.
Tried with the suggestions given in the link https://support.microsoft.com/en-us/help/285472/run-time-error-2147188160-on-activewindow-or-activepresentation-call-i#:~:text=This%20behavior%20is%20caused%20by,code%20will%20cause%20this%20error.
But it is not working
Thanks in Advance
My code is as follows:
Sub sample()
Dim objPresentation As Presentation
On Error GoTo ErrorHandler
Dim sListFileName As String
Dim sListFilePath As String
Dim iListFileNum As Integer
Dim sBuf As String
' EDIT THESE AS NEEDED
' name of file containing files to be inserted
sListFileName = "LIST2.TXT"
' backslash terminated path to folder containing list file:
sListFilePath = "path"
' Do we have a file open already?
If Not Presentations.Count > 0 Then
Exit Sub
End If
' If LIST.TXT file doesn't exist, create it
If Len(Dir$(sListFilePath & sListFileName)) = 0 Then
iListFileNum = FreeFile()
Open sListFilePath & sListFileName For Output As iListFileNum
' get file names
sBuf = Dir$(sListFilePath & "*.PPT")
While Not sBuf = ""
Print #iListFileNum, sBuf
sBuf = Dir$
Wend
Close #iListFileNum
End If
iListFileNum = FreeFile()
Open sListFilePath & sListFileName For Input As iListFileNum
' Process the list
While Not EOF(iListFileNum)
' Get a line from the list file
Line Input #iListFileNum, sBuf
' Verify that the file named on the line exists
If Dir$(sBuf) <> "" Then
Dim SlideArray As Variant
'Set variable to Active Presentation
Set OldPPT = ActivePresentation
'Create a brand new PowerPoint presentation
If PowerPoint.Application.Version >= 9 Then
'window must be visible
PowerPoint.Application.Visible = msoTrue
End If
Set NewPPT = Presentations.Add
InSlides = InputBox("List the slide numbers separated by commas:", "Slides", 2)
SlideArray = Split(InSlides, ",")
For x = 0 To UBound(SlideArray)
sld = CInt(SlideArray(x))
'Set variable to a specific slide
Set Old_sld = OldPPT.Slides(sld)
'Copy Old Slide
y = Old_sld.SlideIndex
Old_sld.Copy
'Paste Slide in new PowerPoint
NewPPT.Slides.Paste
Set New_sld = Application.ActiveWindow.View.Slide
'Bring over slides design
New_sld.Design = Old_sld.Design
'Bring over slides custom color formatting
New_sld.ColorScheme = Old_sld.ColorScheme
'Bring over whether or not slide follows Master Slide Layout (True/False)
New_sld.FollowMasterBackground = Old_sld.FollowMasterBackground
Next x
End If
Wend
Close #iListFileNum
MsgBox "DONE!"
NormalExit:
Exit Sub
ErrorHandler:
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _
vbOKOnly, "Error inserting files")
Resume NormalExit
End Sub
The following VBA code selects textboxes in a word document that contain a specific text. How can I programmatically move every textbox to another page (let's say the first page) preserving it's position relative to the page. The original textboxes are positioned absolute to the page they are on.
Sub searchTexboxes()
'
' searchTexboxes Macro
'
'
Dim shp As Shape
Dim sTemp As String
Dim nrTextboxes As Integer
nrTextboxes = 0
For Each shp In ActiveDocument.Shapes
If shp.Type = msoTextBox Then
shp.Select
Selection.ShapeRange.TextFrame.TextRange.Select
sTemp = Selection.Text
sTemp = Left(sTemp, 1)
If sTemp = "." Then
nrTextboxes = nrTextboxes + 1
End If
End If
Next
MsgBox ("Found " & nrTextboxes & " textboxes.")
End Sub
The following code works for me.
The only way to do this, really (aside from recreating the text box from scratch), is copy/paste. That will carry across all the formatting.
Key aspects about this approach:
Setting the target page: Word doesn't have "page" objects, due to its dynamic layout behavior. Selection.GoTo is the simplest method to get a page. Since the text boxes are formatted relative to the page, it doesn't matter where on the page the anchor is attached. (Unless there's going to be a lot of subsequent editing that could push the anchoring range to a different page.) So this code assigns the first paragraph's range to be the anchor.
Identifying the text box(es) to be copied: It's not necessary to select a text box in order to work with its content. The text can be read from TextFrame.TextRange.Text.
Looping with multiple text boxes: As soon as a text box is created (pasted) in the target range, Word will say "Aha! there's another text box!" and will try to loop that, too, which is not what is wanted. So the code in the question has been modified to add the text boxes which should be copied to an array (shps()). Once all the text boxes that need to be copied have been identified, the code then loops this array, copies each text box and paste it to the target range.
Sub searchTexboxes()
Dim shp As Shape
Dim shps() As Shape
Dim sTemp As String
Dim nrTextboxes As Integer
Dim target As Word.Range
Dim targetPage As Long, i As Long
nrTextboxes = 0
targetPage = 1
Selection.GoTo What:=Word.wdGoToPage, Which:=targetPage
Set target = Selection.Paragraphs(1).Range
For Each shp In ActiveDocument.Shapes
If shp.Type = msoTextBox Then
sTemp = shp.TextFrame.TextRange.Text
sTemp = Left(sTemp, 1)
If sTemp = "." Then
nrTextboxes = nrTextboxes + 1
ReDim Preserve shps(nrTextboxes - 1)
Set shps(nrTextboxes - 1) = shp
End If
End If
Next
For i = LBound(shps) To UBound(shps)
shps(i).Select
Selection.Copy
target.Paste
Next
MsgBox ("Found " & nrTextboxes & " textboxes.")
End Sub
I have a file containing 50 slides. I need to create 50 different files each containing one of the slides. I guess the quickest way includes VBA, but I don't know how to get VBA to create a new file and then get back to the master.
Assuming you meant "create 50 presentations", this will work. Create the destination folder before running the code:
Sub ExportSlides()
For X = 1 To ActivePresentation.Slides.Count
ActivePresentation.Slides(X).Export "c:\temp\slide" & X & ".pptx", "PPTX"
Next X
End Sub
I finally found out this:
Sub ExportSlides()
Dim oTempPres As Presentation
Dim X As Long
For X = 1 To ActivePresentation.Slides.Count
sFileName = "C:\Raw\Slide__" & X & ".pptx"
ActivePresentation.SaveCopyAs sFileName
Set oTempPres = Presentations.Open(sFileName, , , False)
For Y = (X + 1) To oTempPres.Slides.Count
oTempPres.Slides(X + 1).Delete
Next
For Y = 1 To X - 1
oTempPres.Slides(1).Delete
Next
oTempPres.Save
oTempPres.Close
Next X
End Sub
This code I had for a similar project should work to split out each PPT file to its PPT file and save it to the folder that contains the original PPT file.
Some caveats:
it struggles with embedded graphs and sometimes backgrounds.
this strips out all animations assigned to the slides or the template. If you want to keep animations or effects in, just strip out those lines of code
I haven't taken the time to smooth out automating the UserForm showing up automatically, but you can easily run it by going to the Developer tab and running the OnPresentationOpen subroutine from the macros list.
Depending on your environment's security settings, you may also need to set the .pptm containing this VBA as a Trusted Document before it will work.
Option Explicit
Sub OnPresentationOpen()
UserForm1.Show
End Sub
Public Sub ProcessPowerPoint(pptCalled)
Dim pptMainPowerPt As Presentation
Dim slideCount As Long
Dim i As Long
Dim cleanSlide As Slide
Dim newSaveName As String
Set pptMainPowerPt = Presentations.Open(pptCalled)
slideCount = ActivePresentation.Slides.Count
' Removes all animations from entire document first
For Each cleanSlide In ActivePresentation.Slides
For i = cleanSlide.TimeLine.MainSequence.Count To 1 Step -1
'Remove Each Animation
cleanSlide.TimeLine.MainSequence.Item(i).Delete
Next i
Next cleanSlide
Debug.Print "The number of slides is "; slideCount
Debug.Print "The name that is showing is "; pptCalled
Debug.Print ActivePresentation.Name
newSaveName = Left(pptCalled, InStr(pptCalled, ".") - 1)
Debug.Print "Substring name is "; newSaveName
For i = 1 To slideCount
Dim newPresentation As Presentation
Dim newName As String
Dim currentSlide As Slide
newName = newSaveName + "_Slide_" & i & ".pptx"
Set currentSlide = pptMainPowerPt.Slides.Item(i)
Set newPresentation = Application.Presentations.Add
currentSlide.Copy
newPresentation.Slides.Paste
newPresentation.SaveAs (newName)
newPresentation.Close
Next
pptMainPowerPt.Close
End Sub
I have a command button and a text-box in the Slide Master of a PowerPoint presentation. I am trying to retrieve the PowerPoint's properties such as SlideID, SlideIndex and the name of the corresponding file and post them to the text box on the click of the command button.
At the moment I have this code but its giving me an error:
Sub CommandButton1_Click()
Dim Index As Long
Dim SlideId as Long
Dim FileName as String
TextBox1.Text = "SlideIndex:" & Index & "Slide ID:" & SlideId
End Sub
I want page 1 of the power point to read as slideIndex 1 SlideID 1 and the file name. and for slide 2 I want it to say all two's and so on...
Thanks in advance!
You can use a command button if you like; or you can use any PowerPoint shape you want to draw, assign it an Action Setting of Run Macro and choose the macro you want it to run when clicked.
Either way, this should work:
Sub ReportStuff()
Dim oSl As Slide
Dim oSh As Shape
Set oSl = SlideShowWindows(1).View.Slide
' Test to see if the shape's already there:
Set oSh = IsItThere(oSl, "My Text Box")
' If it's not there, add it:
If oSh is Nothing Then
Set oSh = oSl.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 200, 50)
oSh.Name = "My Text Box"
End If
With oSh.TextFrame.TextRange
.Text = "Index: " & oSl.SlideIndex & " ID: " & oSl.SlideID & " File: " & ActivePresentation.FullName
End With
End Sub
Function IsItThere(oSl as Slide, sName as String) as Shape
Dim oSh as Shape
For each oSh in oSl.Shapes
If oSh.Name = sName Then
Set IsItThere = oSh
Exit Function
End If
Next
End Function
I'm working with PowerPoint 2007. I want to use a list to create a table on a slide. The first column of each row will have a hyperlink to a different slide in the presentation (like a summary slide).
I'm having trouble using VBA to insert a hyperlink into a cell. The error message is usually something like "object doesn't support that function".
Here is the offending line:
With pptPres.Slides(2).Shapes("Table Summary").Table.Cell(i - 1, 1).Shape.ActionSettings(ppMouseClick).Hyperlink
.TextToDisplay = ThisWorkbook.Sheets(i).Range("B1")
.SubAddress = pptPres.Slides(i).SlideID
End With
You're almost there.
You need to access TextRange Object if you want to add a Link in the text within a table or shape.
Something like:
Sub marine()
Dim t As Table
Dim pptpres As Presentation
Set pptpres = ActivePresentation
Set t = pptpres.Slides(1).Shapes(1).Table
With t.Cell(2, 1).Shape.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink
.TextToDisplay = "Link to Slide"
.SubAddress = pptpres.Slides(2).SlideNumber _
& ". " & pptpres.Slides(2).Name
End With
End Sub
And also, you cannot use SlideID property as SubAddress.
It should be in this format: <slide number><dot><space><slide name> (eg. #2. Slide2)
To get this done we used SlideNumber and Name property instead. HTH
thanks for the above. Below generates a hyperlinked TOC table for each slide into slide 2
Sub DeckTOC() ' Creates a hyperlinked TOC of each slide in deck
' Tip: add a return-to-TOC hyperlink on Slidemaster default layout
' assumes slide 1 is a cover slide, slides 2 is for TOC
' and #2 already includes a table And (important) no other shapes or title
' with col 1 for slide title and 2nd cloumn for slide no
' TOC can be formatted before/after macro has run
Dim slidecount As Integer
Dim t As Table
Dim TOCrow As Integer
Dim pptpres As Presentation
Set pptpres = ActivePresentation
slidecount = pptpres.Slides.Count
If slidecount < 3 Then Exit Sub ' nothing to do
Set t = pptpres.Slides(2).Shapes(1).Table ' grab= ther toc
TOCrow = 2
For i = 3 To slidecount Step 1 ' get slide references for each slide
If TOCrow > t.Rows.Count Then t.Rows.Add ' add rows on fly as needed
' create text entry in cell, then add hyperlink (doing in one step fails)
With t.Cell(TOCrow, 1).Shape.TextFrame.TextRange
.Text = pptpres.Slides(i).Shapes.Title.TextFrame.TextRange.Characters
End With
With t.Cell(TOCrow, 1).Shape.TextFrame.TextRange.Characters().ActionSettings(ppMouseClick).Hyperlink
.Address = ""
.SubAddress = pptpres.Slides(i).SlideNumber & ". " & pptpres.Slides(i).Name
End With
t.Cell(TOCrow, 2).Shape.TextFrame.TextRange.Text = i
TOCrow = TOCrow + 1
Next
End Sub
ex [enter image description here][1]
[1]: https://i.stack.imgur.com/gaMJK.png