I have a problem regarding a linked Excel File to a Powerpoint presentation.
The Excel file is hosted on an external server which is assigned to a drive letter on all the PC´s in the company. The problem is that the link to the Excel file will randomly changed to where it is located on the external server.
I put a workaround in a Macro :
Global fso As New FileSystemObject
Public Sub MaakKoppelingenRelatief()
Dim i As Integer
Dim sld As Slide, shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = 3 Then
Dim path As String, fname As String
path = shp.LinkFormat.SourceFullName
fname = GetFilenameFromPath(path)
shp.LinkFormat.SourceFullName = fname
i = i + 1
End If
Next
Next
If i > 0 Then
MsgBox "Changed: " & CStr(i) & " Links", vbOK
Else
MsgBox "Couldn't find a linked file.", vbOK
End If
End Sub
Function GetFilenameFromPath(ByVal strPath As String) As String
Dim text1 As String
text1 = "N:\"
If Right$(strPath, 13) <> "\\tsclient\N\" And Len(strPath) > 0 Then
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
If Left$(strPath, 3) <> text1 And Len(strPath) > 0 Then
GetFilenameFromPath = text1 + strPath
End If
End Function
The problem I'm having is in this piece of code :
If Left$(strPath, 3) <> text1 And Len(strPath) > 0 Then
GetFilenameFromPath = text1 + strPath
End If
It keeps adding text1 to my path, while it only should do so when text1 is currently not in the first 3 characters of the path.
Can someone help me figure out what I have done wrong?
Thanks in advance!
Text comparison in VBA is kind of irritating sometimes. Instead of using
if Left$(strPath, 3) <> text1
try this:
If StrComp(Left$(StrPath,3),text1) <> 0
And if that doesn't work, try this one:
If InStr(1,Left$(StrPath,3),text1) = 0
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
Here is a macro, which allows to replace hyperlinks across images.
(How to use it: copy some images to document, then add hyperlinks to each of them, for example, www.google.com, and then, using this macro, you can replace these hyperlinks to something different, for example www.stackoverflow.com. Test file uploaded here: https://ufile.io/qbdcp).
At first, I tried to use
If .Type = msoHyperlinkInlineShape
but for some reason, it doesn't work for inline images, which were copied from file manager (Ctrl-C in file manager, Ctrl-V in Word).
Then, I replaced it to
If .Type = msoHyperlinkShape
and now it works.
But I still wondering why I was forced to change msoHyperlinkInlineShape to msoHyperlinkShape, whereas I use inline pictures. Why msoHyperlinkInlineShape doesn't work?
Sub ReplaceHyperlinks()
Dim HL As Hyperlink
Dim sFind As String
Dim sRepl As String
Dim iCnt As Integer
sFind = InputBox("Find what", "Find Hyperlink")
If Len(sFind) = 0 Then Exit Sub
sRepl = InputBox("Replace with", "Replace Hyperlink")
If Len(sRepl) = 0 Then Exit Sub
iCnt = 0
For Each HL In ActiveDocument.Hyperlinks
With HL
If .Type = msoHyperlinkShape Then ' msoHyperlinkInlineShape will not work for some reason
If InStr(LCase(.Address), LCase(sFind)) Then
.Address = Replace(.Address, sFind, sRepl, , , vbTextCompare)
.ScreenTip = Replace(.ScreenTip, sFind, sRepl, , , vbTextCompare)
On Error Resume Next
.Range.Fields.Update
iCnt = iCnt + 1
End If
If InStr(LCase(.TextToDisplay), LCase(sFind)) Then
.TextToDisplay = Replace(.TextToDisplay, sFind, sRepl, , , vbTextCompare)
.Range.Fields.Update
End If
End If
End With
Next
MsgBox ("Links replaced: " & iCnt)
End Sub
This question already has answers here:
Cycle through sub-folders and files in a user-specified root directory [duplicate]
(3 answers)
Closed 7 years ago.
I will realy appreciate your help on this issue. I'm quite new with macro.
The macro that I'm using is inserting a picture in Excel column A cells by taking the file name reference from the column B cells.
I have the following macro that works just fine if I know the subfolder were to search for the picture that I need but I don't know how to do it to search in all subfolders of Z:\mfs\PictureLibrary.
Here is the macro :
Sub Picture()
Dim picname As String
Dim pasteAt As Integer
Dim lThisRow As Long
lThisRow = 2
Do While (Cells(lThisRow, 2) <> "")
pasteAt = lThisRow
Cells(pasteAt, 1).Select 'This is where picture will be inserted
picname = Cells(lThisRow, 2) 'This is the picture name
present = Dir("Z:\mfs\PictureLibrary\Codello A14 Transfer\" & picname & ".jpg")
If present <> "" Then
ActiveSheet.Pictures.Insert("Z:\mfs\PictureLibrary\Codello A14 Transfer\" & picname & ".jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
'.Left = Range("A2").Left
'.Top = Range("A2").Top
.Left = Cells(pasteAt, 1).Left
.Top = Cells(pasteAt, 1).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 55#
.ShapeRange.Width = 40#
.ShapeRange.Rotation = 0#
End With
Else
Cells(pasteAt, 1) = ""
End If
lThisRow = lThisRow + 1
Loop
Range("A10").Select
Application.ScreenUpdating = True
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
Range("B20").Select
End Sub
Please, check the example below, it iterates through subfolders and search for your file, you just have to fit it in your code:
Dim FileSystem As Object
Const mainFolder As String = "Z:\mfs\PictureLibrary\Codello A14 Transfer\"
Sub YourProblem()
Dim filePath As String
filePath = Find("pictureName.jpg")
MsgBox filePath
End Sub
Function Find(picName As String) As String
Set FileSystem = CreateObject("Scripting.FileSystemObject")
Find = FindPicture(FileSystem.GetFolder(mainFolder), picName)
End Function
Function FindPicture(innerFolder, picName As String) As String
Dim pictureFound As String
pictureFound = Dir(innerFolder & "\" & picName)
If Len(Trim(pictureFound)) > 0 Then
FindPicture = innerFolder & "\" & pictureFound
Exit Function
Else
Dim subFolder
For Each subFolder In innerFolder.SubFolders
pictureFound = FindPicture(subFolder, picName)
If Len(Trim(pictureFound)) > 0 Then
FindPicture = pictureFound
Exit Function
End If
Next
End If
End Function
Every week I separate a long PowerPoint file into separate files. The files must be in PowerPoint format, and contain only the slides that are contained in the 'sections' from the PowerPoint file.
I need to:
1) Scan to see the number of slides in a given section
2) Make a file containing the slides within that section
3) Name that file the same as the name of the section, and save it in the same directory as the source file.
4) Repeat the process for subsequent sections.
5) Do this without damaging the original file.
I've located code (http://www.pptfaq.com/FAQ01086_Break_a_presentation_up_into_several_smaller_presentations.htm) that can break the file into many parts, but only by the number of files requested per file. I found some other helpful references here: http://skp.mvps.org/2010/ppt001.htm
I have coded in Basic and a number of easy gaming scripting languages. I need help understanding how this is done in VBA.
Since you do this very often, you should make an Add-In for this. The idea is to create copies of the presentation up to the number of sections in it, then open each one and delete the other sections and save.
Create blank presentation with macros enabled (*.pptm) and possibly add Custom UI button to call SplitIntoSectionFiles
Test and when satisfy, save as PowerPoint Add-In (*.ppam). Don't delete the pptm file!
Assuming that all are pptx files you are dealing with, you can use this code. It opens the splited pptx files in background, then remove irrelevant sections and save, close. If all goes well you get a message box.
Private Const PPT_EXT As String = ".pptx"
Sub SplitIntoSectionFiles()
On Error Resume Next
Dim aNewFiles() As Variant, sPath As String, i As Long
With ActivePresentation
sPath = .Path & "\"
For i = 1 To .SectionProperties.Count
ReDim Preserve aNewFiles(i)
' Store the Section Names
aNewFiles(i - 1) = .SectionProperties.Name(i)
' Force Save Copy as pptx format
.SaveCopyAs sPath & aNewFiles(i - 1), ppSaveAsOpenXMLPresentation
' Call Sub to Remove irrelevant sections
RemoveOtherSections sPath & aNewFiles(i - 1) & PPT_EXT
Next
If .SectionProperties.Count > 0 And Err.Number = 0 Then MsgBox "Successfully split " & .Name & " into " & UBound(aNewFiles) & " files."
End With
End Sub
Private Sub RemoveOtherSections(sPPT As String)
On Error Resume Next
Dim oPPT As Presentation, i As Long
Set oPPT = Presentations.Open(FileName:=sPPT, WithWindow:=msoFalse)
With oPPT
' Delete Sections from last to first
For i = .SectionProperties.Count To 1 Step -1
' Delete Sections that are not in the file name
If Not InStr(1, .Name, .SectionProperties.Name(i), vbTextCompare) = 1 Then
' Delete the Section, along with the slides associated with it
.SectionProperties.Delete i, True
End If
Next
.Save
.Close
End With
Set oPPT = Nothing
End Sub
Read about Custom UI if you don't have experience creating you own ribbon tab: msdn and use the "Office Custom UI Editor", I would use imageMso "CreateModule" for the button.
None of the proposed routines actually works, so I wrote mine from scratch:
Sub Split()
Dim original_pitch As Presentation
Set original_pitch = ActivePresentation
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
With original_pitch
.SaveCopyAs _
FileName:=fso.BuildPath(.Path, fso.GetBaseName(.Name) & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
End With
Dim i As Long
For i = 1 To original_pitch.SectionProperties.Count
Dim pitch_segment As Presentation
Set pitch_segment = Presentations.Open(Replace(original_pitch.FullName, "pptm", "pptx"))
section_name = pitch_segment.SectionProperties.Name(i)
For k = original_pitch.SectionProperties.Count To 1 Step -1
If pitch_segment.SectionProperties.Name(k) <> section_name Then pitch_segment.SectionProperties.Delete k, True
Next k
With pitch_segment
.SaveCopyAs _
FileName:=fso.BuildPath(.Path, original_pitch.SectionProperties.Name(i) & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
.Close
End With
Next i
MsgBox "Split completed successfully!"
End Sub
I could not get the above code to work.
However this is simpler and does work:
Sub SplitToSectionsByChen()
daname = ActivePresentation.Name
For i = 1 To ActivePresentation.SectionProperties.Count
For j = ActivePresentation.SectionProperties.Count To 1 Step -1
If i <> j Then ActivePresentation.SectionProperties.Delete j, True
Next j
ActivePresentation.SaveAs ActivePresentation.SectionProperties.Name(1)
ActivePresentation.Close
Presentations.Open (daname)
Next i
End Sub
I have edited fabios code a bit to look like this. And this works well for me in my PC
Option Explicit
Sub Split()
Dim original_File As Presentation
Dim File_Segment As Presentation
Dim File_name As String
Dim DupeName As String
Dim outputFname As String
Dim origName As String
Dim lIndex As Long
Dim K As Long
Dim pathSep As String
pathSep = ":"
#If Mac Then
pathSep = ":"
#Else
pathSep = "/"
#End If
Set original_File = ActivePresentation
DupeName = "TemporaryFile.pptx"
DupeName = original_File.Path & pathSep & DupeName
original_File.SaveCopyAs DupeName, ppSaveAsOpenXMLPresentation
origName = Left(original_File.Name, InStrRev(original_File.Name, ".") - 1)
For lIndex = 1 To original_File.SectionProperties.Count
If original_File.SectionProperties.SlidesCount(lIndex) > 0 Then
Set File_Segment = Presentations.Open(DupeName, msoTrue, , msoFalse)
File_name = File_Segment.SectionProperties.Name(lIndex)
For K = original_File.SectionProperties.Count To 1 Step -1
If File_Segment.SectionProperties.Name(K) <> File_name Then
Call File_Segment.SectionProperties.Delete(K, 1)
End If
Next K
outputFname = pathSep & origName & "_" & original_File.SectionProperties.Name(lIndex) & "_" & Format(Date, "YYYYMMDD")
With File_Segment
.SaveAs FileName:=.Path & outputFname & ".pptx", FileFormat:=ppSaveAsOpenXMLPresentation
.Close
End With
Set File_Segment = Nothing
End If
Next
Set original_File = Nothing
Kill DupeName
MsgBox "Split completed successfully!"
End Sub
This works for me (except for the filename):
Option Explicit
Sub ExportSlidesAsPresentations()
Dim oPres As Presentation
Dim sSlideOutputFolder As String
Set oPres = ActivePresentation
sSlideOutputFolder = oPres.Path & "\"
'Export all the slides in the presentation
Call oPres.PublishSlides(sSlideOutputFolder, True, True)
Set oPres = Nothing
End Sub
I have a code which saves my specified slide as a PNG:
Dim userName As String
userName = Slide322.TextBox1.Text
'Save slide
ActivePresentation.Slides(302).Export _
filename:="C:\Users\Jessica\Dropbox\Uni\DISSERTATION\Questionnaire\Tools\Results\" & userName & ".png", FilterName:="PNG"
However, I want to save the slide as a .PPT so that I can open it at a later date and edit the text on that slide.
I have tried using the .SaveAs syntax, but I get an error message every time and it just won't recognise any 'Save' type expressions.
I have searched, and searched for the answer to this... Can anyone please help?
Try:
ActivePresentation.Slides(1).Export "c:\temp\slide1.ppt", "PPT"
Alternative:
Use SaveCopy to save a copy of the presentation
Open the saved copy (with or without a window)
Delete all the slides up to the one you want to keep
Delete all the slides after the one you want to keep
Save again.
Close the presentation
Like so:
Sub TestMe()
SaveSlide 5, "c:\temp\slide5.pptx"
End Sub
Sub SaveSlide(lSlideNum As Long, sFileName As String)
Dim oTempPres As Presentation
Dim x As Long
ActivePresentation.SaveCopyAs sFileName
' open the saved copy windowlessly
Set oTempPres = Presentations.Open(sFileName, , , False)
For x = 1 To lSlideNum - 1
oTempPres.Slides(1).Delete
Next
' What was slide number lSlideNum is now slide 1
For x = oTempPres.Slides.Count To 2 Step -1
oTempPres.Slides(x).Delete
Next
oTempPres.Save
oTempPres.Close
End Sub
Obviously, you'll want to add a few safety ropes ... don't try to export slide 15 of a 12-slide presentation, etc.
You could possibly try this code which:
creating new presentation
copying slide to it
saving & closing new presentation.
Sub SaveSeparateSlide()
Dim curPres As Presentation
Set curPres = ActivePresentation
Dim newPres As Presentation
Set newPres = Presentations.Add
'change slide number here:
curPres.Slides(1).Copy
newPres.Slides.Paste
'change your path and name here:
newPres.SaveAs "single slide presentation.pptx"
newPres.Close
End Sub
You will need to adjust that code a bit but I think you'll cope :)
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
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
ActivePresentation.Slides(1).Export "1.ppt", "PPT"
Above code exports Slide#1 to an 'old' type ppt format.
The 2nd one of the following 2 macros can save a copy in a 'new' pptx format which is more compatible. It's actually the mixture of Steve's two methods. But it doesn't bother to delete the rest of the slides.
Sub SaveEachPage2PPT()
Dim sld As Slide
Dim l#
With ActivePresentation
For Each sld In .Slides
l = l + 1
sld.Export .Path & "\" & l & ".ppt", "PPT"
Next sld
End With
End Sub
Sub SaveEachPage2PPTX()
Dim sld As Slide
Dim l#
Dim ppt As Presentation
Dim pptFile$
With ActivePresentation
For Each sld In .Slides
l = l + 1
pptFile = .Path & "\" & l & ".ppt"
sld.Export pptFile, "PPT"
Set ppt = Presentations.Open(pptFile, , , False)
ppt.SaveCopyAs pptFile & "x", ppSaveAsOpenXMLPresentation
ppt.Close
Kill pptFile
Next sld
End With
If Not ppt Is Nothing Then Set ppt = Nothing
End Sub
The following script will help you save the individual slides of your presentation as seperate pptx files. I modified #Steve Rindsberg code to achieve this.
Just change the following in the code
Change K:\PRESENTATION_YOU_ARE_EXPORTING.pptx with the file path of the presentation you are exporting.
Change K:\FOLDER PATH WHERE PPTX SHOULD BE EXPORTED\ with the folder path where the exported presentations should be saved.
Remember to add \ at the end of the folder path in Step 2.
Sub ExportSlidesToIndividualPPPTX()
Dim oPPT As Presentation, oSlide As Slide
Dim sPath As String
Dim oTempPres As Presentation
Dim x As Long
' Location of PPTX File
Set oPPT = Presentations.Open(FileName:="K:\PRESENTATION_YOU_ARE_EXPORTING.pptx")
' Location Where Individual Slides Should Be Saved
' Add \ in the end
sPath = "K:\FOLDER PATH WHERE PPTX SHOULD BE EXPORTED\"
For Each oSlide In oPPT.Slides
lSlideNum = oSlide.SlideNumber
sFileName = sPath & "Slide - " & lSlideNum & ".pptx"
oPPT.SaveCopyAs sFileName
' open the saved copy windowlessly
Set oTempPres = Presentations.Open(sFileName, , , False)
' Delete all slides before the slide you want to save
For x = 1 To lSlideNum - 1
oTempPres.Slides(1).Delete
Next
' Delete all slides after the slide you want to save
For x = oTempPres.Slides.Count To 2 Step -1
oTempPres.Slides(x).Delete
Next
oTempPres.Save
oTempPres.Close
Next
Set oPPT = Nothing
End Sub