In Excel-Word Interop, how do I use the File Object after using the Name function to rename it? - vba

Overall objective: create an Excel-based file converter that interops with Word, changing several built-in document properties, header/footer text & pics, watermark, and file name. The new attributes/text/file paths are found in cells. After changing all these attributes, et al, the file is to be copied as a regular .docx to a new Output folder and also exported as a PDF to a separate PDF Output folder. Optionally the files in the input folder will be deleted after the other steps are completed.
Specific problem: After I rename any of the files using the Name function, the File Object (I'm using File Scripting Object) loses its reference to the old file (since it's renamed), but does not pick up on the new, renamed file. After renaming the file, I would like to make a copy of it into the word document output folder; then, with the original, I would export it to the PDF output folder. Finally, I would either delete it or leave it alone, depending on an optional boolean.
I have attempted to re-assign the File Object with the new file, but this doesn't seem to be possible, and nothing else in its properties or methods makes sense to use.
Sub ChangeProperties()
Dim wordApp As Word.Application
Dim wordDoc() As Word.Document
Dim fso As New FileSystemObject
Dim fo(3) As Folder
Dim f As file
Dim cvSht As Worksheet
Dim fileSht As Worksheet
Dim progShp As Shape
Dim fileRng(0 To 13) As Range
Dim optRng As Range
Dim i As Long
Dim n As Long
Dim count As Long
Set wordApp = Word.Application
' Dashboard sheet
Set cvSht = Sheets("Convert")
' Sheet where user types new attributes or views old attributes
Set fileSht = Sheets("FileAttributes")
' Folder objects
Set fo(1) = fso.GetFolder(cvSht.Range("F3").Value)
Set fo(2) = fso.GetFolder(cvSht.Range("F5").Value)
Set fo(3) = fso.GetFolder(cvSht.Range("F7").Value)
ChDir (fo(1) & Application.PathSeparator)
Set optRng = cvSht.Range("H13")
' Just some user-defined true/false input cells
optERR = optRng
optMSG = optRng.Offset(1, 0)
optPDF = optRng.Offset(2, 0)
optDOC = optRng.Offset(3, 0)
optRMV = optRng.Offset(4, 0)
' Run some pre-execution checks to prevent catastrophic failure
If fo(1).Files.count > 20 Then
MsgBox "Too many files in folder. Please only 20 files at a time.", vbOKOnly, "Error!"
Exit Sub
End If
For i = 0 To 13
Set fileRng(i) = fileSht.Range("D27").Offset(0, i)
Next
n = 1
If InStr(1, fileRng(0).Offset(n - 1, 0), "doc") = 0 Then
MsgBox "New file names must end with a proper extension, i.e. - .docx", vbCritical, "Terminating Process!"
Exit Sub
End If
For Each f In fo(1).Files
For i = 0 To fo(1).Files.count
If fileRng(0).Value = f.Name Then
MsgBox "New file names must be different from the existing file names! Aborting...", vbCritical, "Terminating Process!"
Exit Sub
End If
Next
Next
For Each f In fo(1).Files
If optERR = False Then On Error Resume Next
If Left(f.Name, 1) = "~" Then GoTo Nxt
Set wordDoc(n) = wordApp.Documents.Open(f.Path)
' -------- Clipped out middle parts for clarity ---------
If fileRng(0).Offset(n - 1, 0) <> "" Then
End If
On Error GoTo 0
wordDoc(n).Save
Application.Wait Now + 0.00003
Application.StatusBar = "Processing..." & n & "/" & fo(1).Files.count
If optPDF Then
If Right(f, 1) = "x" Then
wordDoc(n).ExportAsFixedFormat fo(2) & Application.PathSeparator & _
VBA.Replace(f.Name, ".docx", ".pdf"), wdExportFormatPDF
ElseIf Right(f, 1) = "c" Then
wordDoc(n).ExportAsFixedFormat fo(2) & Application.PathSeparator & _
VBA.Replace(f.Name, ".doc", ".pdf"), wdExportFormatPDF
ElseIf Right(f, 1) = "m" Then
wordDoc(n).ExportAsFixedFormat fo(2) & Application.PathSeparator & _
VBA.Replace(f.Name, ".docm", ".pdf"), wdExportFormatPDF
End If
End If
wordDoc(n).Close
**Name f.Name As fileRng(0).Offset(n - 1, 0).Value** ' Causes the next lines to fail
**Set f = fileRng(0).Offset(n - 1, 0).Value** ' Attempt to reassign fails
**If optDOC Then f.Copy (fo(3) & "/")** ' This would fail too
If optRMV Then f.Delete
Nxt:
On Error GoTo 0
n = n + 1
Next
End Sub

Related

VBA attempting to open file which name contains characters above high-ascii (256)

What I'd like to achieve is opening a file from the previously-stored variable. The problem is the filename sometimes contains characters like ŰŐ. VBA environment changes them to the closest one UO. So I'm unable to open a workbook included with "special" characters. What I have tried so far:
Sub open_last_modified()
Dim fso As New FileSystemObject
Dim files, folder, lmfile As String
Dim lmdate As Date
' a file previously created on desktop ( like őőőűűű.xlsx)
' with a proper filename, both method works very well
folder = ("C:\Users\szidzse\Desktop\")
files = Dir(folder & "*.*", vbNormal)
Do While files <> ""
On Error Resume Next 'if it contains non
If FileDateTime(folder & files) > lmdate Then
lmdate = FileDateTime(folder & files)
lmfile = files 'the last modified file what i'd like to open even if it has non-ascii characters.
End If
files = Dir
Loop
Set a = Workbooks.Open(folder & lmfile, ReadOnly:=True) 'does nothing when filename is not proper.
fso.CopyFile Source:=folder & lmfile, Destination:=folder & "temp.xlsx" 'file not found (I've tried to copy and rename it to a proper name.)
End Sub
I've also tried StrConv(string, vbFromUnicode or vbUnicode) without success.
Any help will be appreciated.
Please, test the next function. It should replace the non ASCII characters with similar ones:
Function replaceNonASCIICh(x As String) As String
Dim i As Long
For i = 1 To Len(x)
If AscW(Mid(x, i, 1)) <> Asc(Mid(x, i, 1)) Then
x = Replace(x, Mid(x, i, 1), Chr(Asc(Mid(x, i, 1))))
End If
Next i
replaceNonASCIICh = x
End Function
I tested it on the two not ASCII characters we could see/copy, in the next way:
Sub testReplaceNonASCII()
Dim x As String, result As String
x = ChrW(368) & ChrW(79) 'the string containing the characters you show us
result = replaceNonASCIICh(x)
ActiveCell.Offset(1).Value = result 'in Immediate Window non ASCII characters cannot be seen as they are...
End Sub
I do not know what other characters should be involved. Please, test it on your cases and send some feedback.
Now, supposing that Dir returns all files from the folder, even if their name contain non ASCII characters, you should firstly iterate between all of them and change their names, using the above function (and Name function). If it looks complicated, but if Dir returns them, I will show you how to proceed...
If you share such a file (supposing it is not confidential) I can try testing the code I posted, only supposing that it should work...
Edited:
I copied the workbook you sent in a folder named "InvalidCharacters", like subfolder of the one running the code. Then, I (manually) changed its name adding a suffix and copy it again (keeping the non ASCII characters). Please, do the same and test the following code:
Sub changeNonASCIIFileName()
Dim FSOLibrary As Object, fldObj As Object, fsoFile As Object
Dim foldPath As String, fileName As String, newName As String
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
foldPath = ThisWorkbook.path & "\InvalidCharacters\"
Set fldObj = FSOLibrary.GetFolder(foldPath)
For Each fsoFile In fldObj.files
On Error Resume Next 'if no characters to be replaced you cannot rename the file...
fsoFile.Name = replaceNonASCIICh(fsoFile.Name)
On Error GoTo 0
Next
End Sub
It uses the above function. Please, take care to be there!
I would like to receive some feedback after testing it...
#FaneDuru sorry for my late response.
Your code works, for me, it returns uo instead of űő. But gives File not found. when attempting to open. In my special case for opening a file, putting a question mark where the invalid character is doing the trick.
Workbooks.Open("C:\Users\User\invalid??.xlsx") opens successfully the file named: invalidűő.xlsx
Getting that file's last modified date is a bit trickier,if I tried to store as string it runs into error, file not found, so it must be done via FSO and a lot of mess with the strings, and telling the editor that "Hey this is from Middle European code table!!" so in my case:
Chr(254) is ő in the mid-euro table. If your string contains this char in the editor it handles as the following.
Chr(254) is õ in the western table.
Setting the string with the specified Unicode hex code here ChrW$(&H151) is the key. (Accented o letter). While Chr(254) is (o letter with tilde, or without).
Sub lmfile_check2()
Dim files As String
Dim folder As String
Dim lmdate As Date
Dim lmfile As String
files = Empty
For i = 1 To 11
folder = ThisWorkbook.Sheets(1).Cells(i, 2).Value
files = Dir(folder & "*.*", vbNormal)
Do While files <> ""
On Error Resume Next
If FileDateTime(folder & files) = Empty Then GoTo 2
On Error GoTo 2
lmdate_2:
If FileDateTime(folder & files) > lmdate Or lmdate2 > lmdate Then
If IsEmpty(FileDateTime(folder & files)) Then
GoTo ende
End If
lmfile = files '
If lmdate2 > lmdate And lmdate <> Empty Then
lmdate = lmdate2
Else
lmdate = FileDateTime(folder & files)
End If
End If
GoTo ende
2:
If InStr(1, files, "hétfo") > 0 Then 'this section is for known invalid character
Set fs = CreateObject("Scripting.FileSystemObject")
files2 = Replace(files, "hetfo", "hetf" & ChrW$(&H151), 1, -1, vbTextCompare)
l = Len(files2)
files2 = Left(files2, l - 5)
Set f = fs.GetFile(folder & files2 & ChrW$(&H151) & ".xls")
lmdate2 = f.DateLastModified
If lmdate2 > lmdate Then
lmdate = lmdate2
lmfile = Replace(files, "hetfo", "hetf" & "?", 1, -1, vbTextCompare)
GoTo vege
End If
End If
GoTo lmdate_2
ende:
files = Dir
Loop
ThisWorkbook.Sheets(1).Cells(i, 1) = folder & lmfile
ThisWorkbook.Sheets(1).Cells(i, 4) = lmdate
Set f = Nothing
lmdate = Empty
lmfile = Empty
Next i
For i = 1 To 11
ThisWorkbook.Sheets(1).Cells(i, 1) = Replace(ThisWorkbook.Sheets(1).Cells(i, 1), "hétfo", "hétf" & "?", 1, -1, vbTextCompare)
Next i
MsgBox "Vertig"
End Sub

Copy row until cell not empty

Thanks for any help you can provide. I have managed using a macro to search through folders and sub folders and hyperlink them and display Folder 1 in column A the files that is in the folder in column B.
There is about 200 folders and some 1600 files. Anyway I want to be able to place a button and attach a macro to that button that will enable only the folder and files names be to copy from that buttons position.
I was thinking of placing that button in column D directly across from the folder name in column A
The code does something similar to what you appear to want. It recursively (see TraversePath subroutine) finds all the paths and files in them and prints them out to "Sheet1" in the same manner as the image you posted with your question: the file folder names are written out to column 'A' (as a hyperlink), the files in that folder are written out to column 'B' (again as hyperlinks) and a button is placed in column 'C'.
Modify 'CreateDirSheet' with the root or top directory for which you want all sub-folders and files printed out in 'Sheet1'. The '1' argument to 'TraversePath' is the row # of where to start printing out the folders/files in 'Sheet'.
The TraversePath subroutine places the buttons and identifies the macro handler that is processed when the button is pressed. Two arguments are passed to that routine: the name of the sheet (it'll be 'Sheet1' in this case) and the row number from where the folder is given in column 'A'.
When a button is pressed the handler prompts the user for the destination path and goes down the list in column 'B' copying all the files from the source folder (in column 'A') to the destination folder provided by the user.
It's probably not entirely what you're after but should be a good starting point to get the functionality you want.
Option Explicit
' Button event handler
Sub CopyDirBtn(shtName As String, rs As String)
Dim sht As Worksheet
Set sht = Worksheets(shtName)
' Get the destination path (where to copy files) from user
Dim dpath As String, spath As String
Dim fdialog As FileDialog
Set fdialog = Application.FileDialog(msoFileDialogFolderPicker)
With fdialog
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> 0 Then
dpath = .SelectedItems(1)
Else
Exit Sub
End If
End With
' Copy all files
Dim r As Integer: r = CInt(rs)
With sht
spath = .Cells(r, "A")
r = r + 1
Do While .Cells(r, "B") <> ""
FileCopy spath & .Cells(r, "B"), dpath & "\" & .Cells(r, "B")
r = r + 1
Loop
End With
End Sub
' Populate sheet with folder/link links and buttons
Sub TraversePath(path As String, r As Integer)
Dim currentPath As String, directory As Variant
Dim dirCollection As Collection
Set dirCollection = New Collection
currentPath = Dir(path, vbDirectory)
Dim sht As Worksheet
Set sht = Worksheets("Sheet1")
With sht
'Add directory and hyperlink to sheet
.Hyperlinks.Add Anchor:=.Cells(r, "A"), _
Address:=path, _
TextToDisplay:=path
' Add copy button
Dim copyBtn As Button
Set copyBtn = .Buttons.Add(Cells(r, "C").Left, _
Cells(r, "C").Top, 100#, 14#)
With copyBtn
.Caption = "Copy Files"
.Name = "copyBtn_" & r
.Locked = False
.OnAction = "'CopyDirBtn """ & sht.Name & """, """ & r & """'"
End With
' Add files and hyperlinks to sheet
r = r + 1
Do Until currentPath = vbNullString
If Left(currentPath, 1) <> "." And _
(GetAttr(path & currentPath) And vbDirectory) = vbDirectory Then
dirCollection.Add currentPath
Else
If currentPath <> "." And currentPath <> ".." Then
.Hyperlinks.Add Anchor:=.Cells(r, "B"), _
Address:=path, _
TextToDisplay:=currentPath
r = r + 1
End If
End If
currentPath = Dir()
Loop
End With
'process remaining directories
For Each directory In dirCollection
TraversePath path & directory & "\", r
Next directory
End Sub
' This is the main macro that populates the sheet
' Modify first parameter so it's your root folder path
Sub CreateDirSheet()
TraversePath "D:\tmp\", 1
End Sub

Reference name-changing workbook in VBA

I was wondering whether there is a (built in/simple) option to reference/connect/link to a workbook that has a variable name?
My xy-problem is, I have workbook b v45.xlsm and wish to export data to workbook a v34.xlsm where the version numbers vary. So I was wondering if there is a sub-ID for each workbook, to which excel can refence independent of the name, automatically picking the most recent version in that folder.
Of course the simple solution is to pick the most recently modified excel file in the folderpath containing the string "a v", assuming an identical folderpath, but I was curious if there was a more convential/integrated option for this.
Kind regards.
(For future people looking at this issue, here is my manual solution:)
Sub find_planner_name()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim string_object(0 To 2) As String 'saving the filenames as strings
Dim count As Integer 'counting nr of files encountered
Dim save_version_number(0 To 1) As Long
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
'Cells(i + 1, 1) = objFile.name
count = count + 1
ReDim version_number(0 To count) As Long
string_object(0) = ""
string_object(1) = ""
string_object(2) = ""
string_object(0) = objFile.name
If Right(string_object(0), 5) = ".xlsm" Or Right(string_object(0), 5) = ".xlsb" Then
If Left(string_object(0), 10) = " planner v" Or Left(string_object(0), 10) = " planner v" Then
string_object(1) = Right(string_object(0), Len(string_object(0)) - 10)
MsgBox (string_object(1))
Do While IsNumeric(Left(string_object(1), 1)) = True
If IsNumeric(Left(string_object(1), 1)) = True Then
string_object(2) = string_object(2) & Left(string_object(1), 1)
string_object(1) = Right(string_object(1), Len(string_object(1)) - 1)
End If
Loop
If version_number(count) < string_object(2) And string_object(2) > 0 Then
version_number(count) = string_object(2)
MsgBox (version_number(count))
save_version_number(0) = version_number(count)
save_version_number(1) = count
End If
End If
End If
i = i + 1
Next objFile
count = save_version_number(1) 'rewrite maxima back
version_number(count) = save_version_number(0) 'rewrite maxima back
'MsgBox ("done " & version_number(count))
Dim myMax As Long
Dim count_results As Long
For count_results = LBound(version_number, 1) To UBound(version_number, 1)
If version_number(count_results) > myMax Then
myMax = version_number(count_results)
Findmax = count_results
'MsgBox (version_number(count_results))
End If
'MsgBox (version_number(count_results) & " and count_results = " & count_results)
Next count_results
'the name of the planner =
name_planner = " planner v" & version_number(Findmax) & ".xlsm"
' check if xlsm or xlsb
'MsgBox (name_planner)
If Dir(ThisWorkbook.Path & "\" & name_planner) <> "" Then
MsgBox ("File exists. and name is " & name_planner)
Else
name_planner = " planner v" & version_number(Findmax) & ".xlsb"
End If
End Sub
It should be more reliable to parse filenames looking at the version numbers rather than looking at the most recently modified file. Loop through all of them checking the filename with something like:
strFile = Dir(DirectoryPath)
Do while strFile <> ""
'Code here to parse strFile for intNewVersionNumber
if intNewVersionNumber > intVersionNumber then intVersionNumber = intNewVersionNumber
strFile = Dir
Loop
strFile = 'Code here to reconstruct filename from intVersionNumber
From your question, I think this might actually be necessary, even though there may be a couple of ways of adding/checking metadata on Excel files.
When you say the workbook name changes, it is literally the exact same file being renamed through Windows Explorer, or do you have multiple versions in the same folder created when you use Save As...? The issue of "automatically picking the most recent version" suggests that there are new versions being created in the same folder. If so, it means that you're actually changing which workbook you're linking to, so any kind of link to a file isn't going to work anyway. Also, even if you put in a sub-ID, each version will still have that same sub-ID. While this can still identify the files that are different versions of the same file, you still have to loop through all of those files looking for the latest version. A sub-ID would help if the filename is changing entirely, but doesn't remove the need to search through the different versions. So, if you can keep a consistent filename with only the version number changing, you'll be able to implement the simplest solution possible.

How to open a new workbook and add images with VBA?

I'm trying to get a macro for Excel 2007to open a folder with a bunch of images in them. Then Create a new workbook and embed the images into it.
Everything works if I comment out the line Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310 If I uncomment that line I get "Run-time error '434': Object required"
I've check that Sheet.Shapes is returning a Shapes object, it is but the Shapes object is empty. When I try Sheet.Shapes,AddPicture on a workbook that is opened outside of the macro, it adds the images. I've also checked that Sheet.Shapes.AddShape works with the workbook opened in the macro, it does.
At this point, I'm at a lose for what the issue might be. Does anyone have any experience with this sort of thing? Should I be using a different method? Thanks in advance for any help or guidance.
Sub Macro1()
Dim ImagePath, Flist
ImagePath = GetFolder()
If ImagePath = "" Then Exit Sub
Flist = FileList(ImagePath)
Name = "C:\target.xlsm"
Set Book = Workbooks.Add
Set Sheet = Book.Sheets(1)
For i = 1 To 5
cell = "C" + CStr(i)
F = ImagePath + "\" + Flist(i - 1)
Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310
Next
Book.SaveAs FileName:=Name, FileFormat:=52
Book.Close
End Sub
Function FileList(ByVal fldr As String) As Variant
'Lists all the files in the current directory
'Found at http://www.ozgrid.com/forum/showthread.php?t=71409
Dim sTemp As String, sHldr As String
If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
sTemp = Dir(fldr & "*.png")
If sTemp = "" Then
FileList = False
Exit Function
End If
Do
sHldr = Dir
If sHldr = "" Then Exit Do
sTemp = sTemp & "|" & sHldr
Loop
FileList = Split(sTemp, "|")
End Function
Function GetFolder() As String
Folder:
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "New Screenshot Folder"
.Show
num = .SelectedItems.Count
If .SelectedItems.Count = 0 Then
GetFolder = ""
Else: GetFolder = .SelectedItems(1)
End If
End With
End Function
You can't define a cell by creating the string "C1", that's just the address. The way you did it, cell is a string and a string doesn't have any properties. What you want is a range object so either use
Dim cell As Range
Set cell = sheet.Range("C" & i)
or
Dim cell As Range
Set cell = sheet.Cells(i, 3)
You should always Dim all variables, use Option Explicit on top of your module so you don't forget it ;)
This will often prevent mistakes. Of course you should Dim them with the correct type, i.e. Dim FilePath As String.
The correct command would be:
Sheet.Shapes.AddPicture Filename:=F, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=Range(cell).Left + 5, Top:=Range(cell).Top + 5, Width:=560, Height:=310
I strongly advise you to change your Name variable name, as it will cause errors on recent versions of excel.

Exporting PowerPoint sections into separate files

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