Remove protected view from Excel sheet opened programmatically in Access - vba

I have a spreadsheet I open programmatically using the VBA in Access:
Set xl = CreateObject("Excel.Application")
With xl
Call RunASCFormatting(xl, wb, strPath)
'More code
Sub RunASCFormatting(xl As Excel.Application, wb As Excel.Workbook, strPath As String)
With xl
If .ProtectedViewWindows.count > 0 Then
.ActiveProtectedViewWindow.Edit
End If
Set wb = .Workbooks.Open(Trim(strPath) & "ASC.xls", True, False)
wb.Sheets(1).Rows("1:1").Delete Shift:=xlUp
.ActiveWorkbook.SaveAs FileName:=Trim(strPath) & "ASC.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End With
End Sub
I have added in the "If" statement in the sub as I was hoping it would remove the "Protected View - Editing this file type is not recommended due to your File Block settings in the Trust Center" message. What I'm trying to achieve is to get the "Enable Editing" button removed, so this macro can enable editing and run as planned.
Currently, the code falls at the "Set wb" line. What is the proper way to achieve what I'm after?

One possibility is to change the macro security settings programmatically to the lowest before you open the Excel workbook. After manipulating your data, re-enable the previous setting of the macro security.
Here's some revised code which I found at http://www.mrexcel.com/forum/excel-questions/631545-change-trust-center-settings-visual-basic-applications.html:
Public Sub MySubroutine()
Dim lSecurity As Long
lSecurity = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityLow
'''''''''''''''''''''
' Run code here '
'''''''''''''''''''''
Application.AutomationSecurity = lSecurity
End Sub
As a side comment, VBA implements Integer as Long, so it could actually be slightly more performance degrading to declare Integer variables as it has to reinterpret the Integer keyword. When I learned that, I started declaring an Integer as Long instead. I actually read this in some Microsoft documentation, but I lost the link to it years ago.

Sub trusted_locations(path_to_add)
Const HKEY_CURRENT_USER = &H80000001
Dim oRegistry
Dim sDescription 'Description of the Trusted Location
Dim bAllowSubFolders 'Enable subFolders as Trusted Locations
Dim bAllowNetworkLocations 'Enable Network Locations as Trusted
' Locations
Dim bAlreadyExists
Dim sParentKey
Dim iLocCounter
Dim arrChildKeys
Dim sChildKey
Dim sValue
Dim sNewKey
Dim vers As Variant
'Determine the location/path of the user's MyDocuments folder
'*******************************************************************************
Set oRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
bAllowSubFolders = True
bAlreadyExists = False
vers = Application.Version
sParentKey = "Software\Microsoft\Office\" & vers & "\Excel\Security\Trusted Locations"
iLocCounter = 0
oRegistry.EnumKey HKEY_CURRENT_USER, sParentKey, arrChildKeys
For Each sChildKey In arrChildKeys
oRegistry.GetStringValue HKEY_CURRENT_USER, sParentKey & "\" & sChildKey, "Path", sValue
If sValue = spath Then bAlreadyExists = True
If CInt(Mid(sChildKey, 9)) > iLocCounter Then
iLocCounter = CInt(Mid(sChildKey, 9))
End If
Next
'Uncomment the following 4 linesif your wish to enable network locations as Trusted
' Locations
bAllowNetworkLocations = True
If bAllowNetworkLocations Then
oRegistry.SetDWORDValue HKEY_CURRENT_USER, sParentKey, "AllowNetworkLocations", 1
End If
If bAlreadyExists = False Then
sNewKey = sParentKey & "\Location" & CStr(iLocCounter + 1)
oRegistry.CreateKey HKEY_CURRENT_USER, sNewKey
oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Path", path_to_be_added
oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Description", description_of_path
If bAllowSubFolders Then
oRegistry.SetDWORDValue HKEY_CURRENT_USER, sNewKey, "AllowSubFolders", 1
End If
End If
End Sub

You can try turning off protected view settings in the Trust Center
http://office.microsoft.com/en-us/excel-help/what-is-protected-view-HA010355931.aspx#BM5
http://www.howtogeek.com/60310/enable-editing-for-all-office-2010-documents-by-disabling-protected-view/
This may be harmful.
Additionally you should set trusted locations.

Sub fileBlock(value As Long)
Const HKEY_CURRENT_USER = &H80000001
Dim oRegistry
Dim sParentKey
Dim vers As Variant
Dim item As String: item = filetype_to_change_fileblock
'Determine the location/path of the user's MyDocuments folder
'*******************************************************************************
Set oRegistry = GetObject("winmgmts:\.\root\default:StdRegProv")
vers = Application.Version
sParentKey = "Software\Microsoft\Office\" & vers & "\Excel\Security\FileBlock"
oRegistry.SetDWORDValue HKEY_CURRENT_USER, sParentKey, item, value
End Sub

Related

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.

VBA script that maps https to \\ paths for downloads

I wrote a script to download files using VBA. The VBA script has to download items that start with https://collaboration.company.corp/collrooms/specificfolder or with \collaboration.company.corp#SSL\DavWWWRoot\collrooms\specificfolder
The specific folders are the same.
If I allow the script to select the specific mapping, it will only recognize it if I use the definition \collaboration.company.corp#SSL\DavWWWRoot\collrooms\specificfolder
How can I create a mapping in VBA to tell Excel that https://collaboration.company.corp/collrooms/specificfolder and \collaboration.company.corp#SSL\DavWWWRoot\collrooms\specificfolder is the same and that the first specification is also valid?
My code:
Option Explicit
Sub FolderSelection()
'Shows the folder picker dialog in order the user to select the folder
'in which the downloaded files will be saved.
Dim FoldersPath As String
'Show the folder picker dialog.
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a folder to save your files..."
.Show
If .SelectedItems.Count = 0 Then
Sheets("Main").Range("B4") = "-"
MsgBox "You did't select a folder!", vbExclamation, "Canceled"
Exit Sub
Else
FoldersPath = .SelectedItems(1)
End If
End With
'Pass the folder's path to the cell. HERE I AM MISSING THE MAPPING. It will show files starting with https if selected and not transfer it to the other structure.
Sheets("Main").Range("B4") = FoldersPath
End Sub
Sub Clear()
'Clears the URLs, the result column and the folder's path.
Dim LastRow As Long
'Find the last row.
With Sheets("Main")
.Activate
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
'Clear the ranges.
If LastRow > 7 Then
With Sheets("Main")
.Range("C8:D" & LastRow).ClearContents
.Range("B4:D4").ClearContents
.Range("B4").Select
End With
End If
End Sub
and the other part of the download macro is
'Check if the folder exists. I did not check whether it will also download with the https structure?
DownloadFolder = sh.Range("B4")
On Error Resume Next
If Dir(DownloadFolder, vbDirectory) = vbNullString Then
MsgBox "The path is incorrect!", vbCritical, "Folder's Path Error"
sh.Range("B4").Select
Exit Sub
End If
On Error GoTo 0
I tried with a script that I found on Stackoverflow but it does not work
I created an additional module:
Sub test()
Dim dm As New DriveMapper
Dim sharepointFolder As Scripting.Folder
Set sharepointFolder = dm.MapDrive("https://collaboration.company.corp/collrooms/")
' unsure whether I have to add something here and whether this will work with https
Debug.Print sharepointFolder.Path
End Sub
and added the following WebDAV mapping as a new CLASS
Option Explicit
Private oMappedDrive As Scripting.Drive
Private oFSO As New Scripting.FileSystemObject
Private oNetwork As New WshNetwork
Private Sub Class_Terminate()
UnmapDrive
End Sub
Public Function MapDrive(NetworkPath As String) As Scripting.Folder
Dim DriveLetter As String, i As Integer
UnmapDrive
For i = Asc("Z") To Asc("A") Step -1
DriveLetter = Chr(i)
If Not oFSO.DriveExists(DriveLetter) Then
oNetwork.MapNetworkDrive DriveLetter & ":", NetworkPath
Set oMappedDrive = oFSO.GetDrive(DriveLetter)
Set MapDrive = oMappedDrive.RootFolder
Exit For
End If
Next i
End Function
Private Sub UnmapDrive()
If Not oMappedDrive Is Nothing Then
If oMappedDrive.IsReady Then
oNetwork.RemoveNetworkDrive oMappedDrive.DriveLetter & ":"
End If
Set oMappedDrive = Nothing
End If
End Sub
The question is also whether removing the dispose method "Class_Terminate" which unmaps the drive would help? When the class goes out of scope then the drive get's unmapped. And how I could put it all together.

Updating Excel Application.StatusBar within Access VBA

My current situation:
I am developing a culmination of VBA programs embedded in an excel file (named "Dashboard.xlsm" and an access file "Dashboard.accdb"). These two files talk to one another via VBA in order to help me do some heavy lifting on data that I need to analyze for my company. Because these programs are being distributed to several managers who panic when something doesn't complete within 3 seconds, I need a good way to indicate the progress of the SQL queries that are being run in Access through Excel (because Access is running invisibly in the background).
My current Excel code:
Sub generateFRMPComprehensive_ButtonClick(Optional sheetName As Variant)
Application.ScreenUpdating = False
Dim directoryPath As String
Dim cn As Object
Dim rs As Object
Dim strCon As String
Dim strSQL, strInput As String
Dim sArray As Variant
Dim appAccess As Access.Application
Dim directoryName
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
directoryName = Application.ActiveWorkbook.Path
directoryPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Dashboard Exports"
Application.ScreenUpdating = False
If IsMissing(sheetName) Then
sheetName = Application.InputBox("Sheet Name?", "Sheet Selection")
If sheetName = "False" Then
Exit Sub
Else
End If
If FileFolderExists(directoryPath) = 0 Then
Application.StatusBar = "Creating Export Folder"
MkDir directoryPath
End If
End If
'-- Set the workbook path and name
reportWorkbookName = "Report for " & sheetName & ".xlsx"
reportWorkbookPath = directoryPath & "\" & reportWorkbookName
'-- end set
'-- Check for a report already existing
If FileExists(reportWorkbookPath) = True Then
Beep
alertBox = MsgBox(reportWorkbookName & " already exists in " & directoryPath & ". Do you want to replace it?", vbYesNo, "File Exists")
If alertBox = vbYes Then
Kill reportWorkbookPath
'-- Run the sub again with the new sheetName, exit on completion.
generateFRMPComprehensive_ButtonClick (sheetName)
Exit Sub
ElseIf alertBox = vbNo Then
Exit Sub
ElseIf alertBox = "False" Then
Exit Sub
End If
End If
'-- End check
'- Generate the report
'-- Create new access object
Set appAccess = New Access.Application
'-- End Create
'-- Open the acces project
Application.StatusBar = "Updating Access DB"
Call appAccess.OpenCurrentDatabase(directoryName & "\Dashboard.accdb")
appAccess.Visible = False
'-- End open
'-- Import New FRMP Data
Application.StatusBar = "Running SQL Queries"
appAccess.Application.Run "CleanFRMPDB", sheetName, directoryName & "\Dashboard.xlsm"
'-- End Import
Workbooks.Add
ActiveWorkbook.SaveAs "Report for " & sheetName
ActiveWorkbook.Close
appAccess.Application.Run "generateFRMPReport_Access", reportWorkbookPath
Workbooks.Open (reportWorkbookPath)
End Sub
My current Access Code:
Public Sub generateFRMPReport_Access(excelReportFileLocation As String)
Dim queriesList As Variant
queriesList = Array("selectAppsWithNoHolds", _
"selectAppsWithPartialHolds", _
"selectAppsCompleted", _
"selectAppsCompletedEPHIY", _
"selectAppsByDivision", _
"selectAppsByGroup", _
"selectAppsEPHIY", _
"selectAppsEPHIN", _
"selectAppsEPHIYN", _
"selectApps")
For i = 0 To 9
DoCmd.TransferSpreadsheet acExport, , queriesList(i), _
excelReportFileLocation, True
Next i
End Sub
My Request:
Is there a way that I can call the Application.DisplayStatusBar from within the 'for' loop within Access and pass the name of the query being run?
Alternatively, what other ways could I display this information?
Thank you!!
You have a few options for achieving this, but the two most obvious are to:
Execute the queries from Excel, and update the status bar from Excel
Execute the queries from Access, but pass the Excel Application reference to Access, so that Access can call back to the Excel status bar.
As your'e driving the activity from Excel, and you already have a reference to the Access Application, the first option is the most logical. The second approach is possible - you just need to pass the Excel object to Access, but then you'd be using Excel to automate Access to automate Excel.
You'll need to move the generateFRMPReport_Access procedure from the Access VBA into the Excel VBA, and modify your call to the procedure in generateFRMPComprehensive_ButtonClick
Sub generateFRMPComprehensive_ButtonClick(Optional sheetName As Variant)
'...
'appAccess.Application.Run "generateFRMPReport_Access", reportWorkbookPath
generateFRMPReport_Access reportWorkbookPath, appAccess
'...
End Sub
Public Sub generateFRMPReport_Access(excelReportFileLocation As String, appAccess As Access.Application)
Dim queriesList As Variant
Dim i As Long
queriesList = Array("selectAppsWithNoHolds", _
"selectAppsWithPartialHolds", _
"selectAppsCompleted", _
"selectAppsCompletedEPHIY", _
"selectAppsByDivision", _
"selectAppsByGroup", _
"selectAppsEPHIY", _
"selectAppsEPHIN", _
"selectAppsEPHIYN", _
"selectApps")
Application.DisplayStatusBar = True
For i = 0 To 9
Application.StatusBar = "Running query " & (i + 1) & " of 9"
appAccess.DoCmd.TransferSpreadsheet acExport, , queriesList(i), _
excelReportFileLocation, True
Next i
Application.StatusBar = False
Application.DisplayStatusBar = False
End Sub

VBA kill crashes after being called by auto_open

I'm experiencing some trouble with my VBA code. I have created an application in Excel and its copies have been distributed to users. To be able to correct bugs or add some new functions, every copy stores information what version it is. I have written procedure, that opens (read-only) a central file, that is providing some data a and information, which version is current. If the file, that opened this central file is older, it gets updated.
So the auto_open calls a procedure discovers that it has to be updated, saves the current file AS FileName_old.xlsm (to have some backup), kills the FileName.xlsm and copies a new file from a template. The problem is that the procedure crashes when it tries to kill the old file (to be more precise, it just ends without any error message). What confuses me is that when I run the auto_open macro manually (F5), everything goes correctly. Even step by step goes right. Also, when I call the update process via a button in a worksheet, it works perfectly. Any idea, what might cause this problem?
Thanks
Sub auto_open()
If Range("H_User").Value = "" Then UserNameWindows 'Write a user that is using this workbook in the range H_User
If Range("H_Updated").Value < FileDateTime(Range("H_File_Data").Value) Then UpdateData
End Sub
Sub UpdateData()
Dim ActWB As String
ActWB = ActiveWorkbook.Name
Application.ScreenUpdating = False
ThisWorkbook.Activate
If Not FileExists(Range("H_File_Data").Value) Then
MsgBox "The data file is not available!", vbCritical
Workbooks(ActWB).Activate
Application.ScreenUpdating = True
Exit Sub
End If
Dim WB As String, oknoData As String, IsTeam As Boolean, User As String
Dim version As Integer, Subversion As Integer, DataPath As String
On Error GoTo konec
Application.EnableCancelKey = xlDisabled
IsTeam = False
User = Range("H_User").Value
WB = ActiveWindow.Caption
version = Range("H_version").Value
Subversion = Range("H_Subversion").Value
Range("C_Data_All").ClearContents
DataPath = Range("H_File_Data").Value
Workbooks.Open fileName:=DataPath, ReadOnly:=True
oknoData = ActiveWindow.Caption
If Range("H_version_Spec").Value <= version Or (Range("H_version_Spec").Value = version And Range("H_Subversion_Spec").Value <= Subversion) Then
FileUpdate
End If
'If there is no need to update the file then continue with in this procedure
End Sub
Sub FileUpdate()
Dim NewPath As String, NewWB As String, OldPath As String, OldWB As String, BackupWB As String, BackupPath As String
Dim MainWB As String, version As String, Subversion As String
Dim versionMax As Integer, SubversionMax As Integer, versionMin As Integer, SubversionMin As Integer
ThisWorkbook.Activate
version = Range("H_version").Value
Subversion = Range("H_Subversion").Value
OldPath = ThisWorkbook.FullName
OldWB = ThisWorkbook.Name
BackupWB = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "_old.xlsm"
BackupPath = ThisWorkbook.Path & "\" & BackupWB
If Not FileExists(Workbooks(OldWB).Names("H_File_Data").RefersToRange.Value) Then
MsgBox "The data file is not available!", vbCritical
Exit Sub
End If
Workbooks.Open fileName:=Workbooks(OldWB).Names("H_File_Data").RefersToRange.Value, ReadOnly:=True
MainWB = ActiveWorkbook.Name
If version = Range("O_Spec_version").Value And Subversion >= Range("O_Spec_Subversion").Value Then
'Just some little piece of code if the version is not lower
Else
If FileExists(BackupPath) Then Kill (BackupPath)
If Not FileExists(Range("H_Path_Spec_Actual").Value) Then
MsgBox "The spec template is not available!", vbCritical
Exit Sub
End If
ThisWorkbook.SaveAs BackupPath
Kill (OldPath)
'Continue with update
End If
End Sub
Function FileExists(FilePath As String) As Boolean
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
FileExists= fso.FileExists(FilePath)
End Function
Option Explicit
Private Sub Workbook_Open()
Dim BackupPath As String
Dim OldPath As String
BackupPath = "folder\Filename_old.xlsm"
With ThisWorkbook
OldPath = .FullName
.SaveCopyAs BackupPath
.Saved = True
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
End Sub

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