We have some set of (powerpoint) pptx files which are targeted for different audiences
I was thinking of merging different slide sets based on target audiance
I want to know if it's possible to
Merge multiple powerpoint files into one
If a single file is changed, i want the same change to reflect into the merged file
Is this possible graphically or by a VBA?
Ex:
A.pptx
B.pptx
C.pptx
D.pptx
E.pptx
Set 1 (Dev.pptx):
A.pptx
B.pptx
D.pptx
Set 2 (Manager.pptx)
A.pptx
D.pptx
E.pptx
Set 3 (all.pptx)
A.pptx
B.pptx
C.pptx
D.pptx
E.pptx
If i change any one of the Pptx (A,b,c,d,e) the combined files should be updated automatically
The simplest and probably most reliable solution would be to put all of the slides into one file and then create custom shows, one for each target audience.
Another approach would be to have a main "menu" presentation, one slide with links to sub-presentations, one per audience. Each of those presentations would have its own "menu" slide that links to A.pptx, B.pptx etc. as needed.
At the end of A.pptx, add an End Presentation link; click on that (or just press ESC to quit the presentation) and you'll be returned to the sub-menu presentation.
This is possible with VBS on a Windows with installed PowerPoint.exe.
Create a script named merge.vbs with this content:
Option Explicit
Sub WriteLine ( strLine )
WScript.Stdout.WriteLine strLine
End Sub
Sub WriteError ( strLine )
WScript.Stderr.WriteLine strLine
End Sub
Dim inputFile1
Dim inputFile2
Dim outputFile
Dim objPPT
Dim objFso
Dim objPresentation
If WScript.Arguments.Count <> 3 Then
WriteError "You need to specify 2 input files and one output file."
WScript.Quit 1
End If
inputFile1 = WScript.Arguments(0)
inputFile2 = WScript.Arguments(1)
outputFile = WScript.Arguments(2)
Set objFso = CreateObject("Scripting.FileSystemObject")
If Not objFso.FileExists( inputFile1 ) Then
WriteError "Unable to find your input file " & inputFile1
WScript.Quit 1
End If
If Not objFso.FileExists( inputFile2 ) Then
WriteError "Unable to find your input file " & inputFile2
WScript.Quit 1
End If
WriteLine "Input File 1 : " & inputFile1
WriteLine "Input File 2 : " & inputFile2
WriteLine "Output File: " & outputFile
Set objPPT = CreateObject( "PowerPoint.Application" )
' Open presentation with window hidden
Set objPresentation = objPPT.Presentations.Open(inputFile1, True, False, False)
mergeAndKeepSourceFormatting objPresentation, inputFile2
' Reference for this at https://learn.microsoft.com/en-us/office/vba/api/powerpoint.presentation.saveas
WriteLine "Saving File: " & outputFile
objPresentation.SaveAs outputFile
objPresentation.Close
ObjPPT.Quit
'
' Add the file to the loaded presentation
'
Sub mergeAndKeepSourceFormatting(ByRef objPresentation, ByVal newPptxFile)
WriteLine "Merging file: " & newPptxFile
Dim newSlides
Dim oldSlides
oldSlides = objPresentation.Slides.Count
newSlides = objPresentation.Slides.InsertFromFile( newPptxFile, objPresentation.Slides.Count)
objPresentation.Slides.Range(FillRangeArray(oldSlides + 1, oldSlides + newSlides)).ApplyTemplate newPptxFile
End Sub
Function FillRangeArray(n1, n2)
Dim myArr()
Redim myArr(n2 - n1)
Dim i
For i = 0 to (n2 - n1)
myArr(i) = n1 + i
Next
FillRangeArray = myArr
End Function
Then from the command line you can call it:
CSCRIPT merge.vbs "A.pptx" "B.pptx" "resultA_B.pptx"
Please adjust the script to your needs or call it several times to merge the resulting file with the next one.
Related
I want to create a macro for exporting all Excel charts from several workbooks in one folder.
I'm a beginner in VBA and I need your help with the following code:
P.S. The code seems to work (I don't have errors) but does not export any graph to the selected folder.
Could you, please, help me with some hints? I don`t know where is the problem.
Thank you in advance! :)
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them (export all charts in one folder)
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim objChart As Excel.Chart
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
'myExtension = "*.xls*"
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
For Each objChart In wb.Charts
objChart.Export myPath & Left(wb.Name, Len(wb.Name) - 5) & "_" & objChart.Name & ".png"
Next objChart
For Each objSheet In wb.Worksheets
For Each objChartObject In objSheet.ChartObjects
With objChartObject.Chart
.Export myPath & Left(wb.Name, Len(wb.Name) - 4) & "_" & .Name & "png" '/export graphs with WorkbookName + _worksheet name
End With
Next
Next
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'Open the windows folder
Shell "Explorer.exe" & " " & myPath, vbNormalFocus
End Sub
Maybe is useful to mention that I wanted to adapt one of my oldest macro (this one export all the charts from a workbook in one folder. Now I need to export all the charts from multiple workbooks in one folder).
Sub ExportAllCharts()
'
' '
' This macro extracts all the graphs from an Excel document and imports them into the selected folder as .PNG images. '
'
' '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim objShell As Object
Dim objWindowsFolder As Object
Dim strWindowsFolder As String
Dim objSheet As Excel.Worksheet
Dim objChartObject As Excel.ChartObject
Dim objChart As Excel.Chart
'Sheets.Select
'ActiveSheet.Select
'Select a Windows folder
Set objShell = CreateObject("Shell.Application")
Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows folder:", 0, "")
If Not objWindowsFolder Is Nothing Then
strWindowsFolder = objWindowsFolder.self.Path & "\"
''''''''''''''''''''''''''
' charts on chart sheets '
''''''''''''''''''''''''''
'For Each objChart In ThisWorkbook.Charts
For Each objChart In ActiveWorkbook.Charts
objChart.Export strWindowsFolder & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & "_" & objChart.Name & ".png" '/export graphs with workbook name prefix + _ + worksheet name ( ex: WorkbookName_WorksheetName.png ---> OK)
Next objChart
'Open the windows folder
Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus
End If
End Sub
Ok, so we need to create a GPO that allows our users to only use specific programs.
GPO Location:
User Configuration
Policies
Administrative Templates [...]
System
Run only specified Windows applications
Then setting the GPO to enabled and clicking on List of allowed applications --> Show...
I have created an excel spreadsheet containing the names of all the programs and their associated executable files with other pertinent information so that we can easily organize, add, delete, etc. the executable files that we need to allow our users access to.
This spreadsheet then dumps all the executable files into a text file.
Here is an example of what the text file looks like:
Acrobat.exe
chrome.exe
calc.exe
.
.
.
There are a lot of entries and these are likely subject to change. What I am trying to do is create a script that will take that text file and populate the GPO automatically. I don't care if we have to open the window and then run it, it does not need to run from the task scheduler (although that would be amazing if someone has that code ready). We just need it to populate this ridiculous amount of executable filenames into the fields.
Here is code I found (VBScript) that when run, should populate the fields automatically, however I cannot get it to run in the Group Policy Management Editor (it runs in the windows explorer window instead and ends up searching for some of the files)
' Open the text file, located in the same path as the script
Set objFSO = CreateObject("Scripting.FileSystemObject")
strPath = Mid(Wscript.ScriptFullName, 1, InStrRev(Wscript.ScriptFullName, wscript.ScriptName) -1)
Set objFile = objFSO.OpenTextFile(strPath & "appList.txt")
' Activate the "Show Contents" window with the "List of allowed applications".
' Note the window must be opened already and we should have selected where in
' the list we want to enter the data before running the script
set WshShell = WScript.CreateObject("WScript.Shell")
WScript.Sleep 1000
WshShell.AppActivate "Show Contents"
' Read the file line by line
Do While objFile.AtEndOfStream <> True
' Each line contains one EXE name
exeName = objFile.ReadLine
' Escape forbidden chars { } [ ] ( ) + ^ % ~
exeName = Replace(exeName, "[", "{[}")
exeName = Replace(exeName, "]", "{]}")
exeName = Replace(exeName, "(", "{(}")
exeName = Replace(exeName, ")", "{)}")
exeName = Replace(exeName, "+", "{+}")
exeName = Replace(exeName, "^", "{^}")
exeName = Replace(exeName, "%", "{%}")
exeName = Replace(exeName, "~", "{~}")
' Send the EXE name to the window
WScript.Sleep 100
WshShell.SendKeys exeName
' Move to the next one
WshShell.SendKeys "{TAB}"
Loop
objFile.Close
from: http://blogs.msdn.com/b/alejacma/archive/2011/03/24/how-to-update-quot-run-only-specified-windows-applications-quot-gpo-programmatically-vbscript.aspx
"C:\Windows\System32\GroupPolicy\User\Registry.pol"
Is where my policies are stored. It's a semi text file. Try writing to that file.
Ok, so I tried it many different ways. If anyone is looking for an answer to do this, this is the way I've figured it out and the way I've decided to proceed. I will post all relevant code below.
In Excel, the format of my table is as follows:
(With obviously WAY more entries)
Here is the VBA code I used to turn the data from this file into the proper format for the registry key:
VBA - In Excel
Public Sub ExportToTextFile(FName As String, _
Sep As String, SelectionOnly As Boolean, _
AppendData As Boolean)
Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile
StartRow = 2
If SelectionOnly = True Then
With Selection
StartCol = .Cells(2).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(2).Column
End With
Else
With ActiveSheet.UsedRange
StartCol = .Cells(2).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(2).Column
End With
End If
If AppendData = True Then
Open FName For Append Access Write As #FNum
Else
Open FName For Output Access Write As #FNum
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & Chr(34) & CellValue & ".exe" & Chr(34) & "=" & Chr(34) & CellValue & ".exe" & Chr(34) & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine; ""
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum
End Sub
Sub PipeExport()
Dim FileName As Variant
Dim Sep As String
FileName = Application.GetSaveAsFilename(InitialFileName:="appList", filefilter:="Text (*.txt),*.txt")
If FileName = False Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Sep = "|"
If Sep = vbNullString Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Debug.Print "FileName: " & FileName, "Extension: " & Sep
ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), _
SelectionOnly:=False, AppendData:=False
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
PipeExport
End Sub
The file that is created is appList.txt and its format is the same format as the registry key:
"Acrobat.exe"="Acrobat.exe"
"AcroRd32.exe"="AcroRd32.exe"
Now in your GPO, add a unique program name to the allowed applications list (say test1234.exe) and in your registry editor, go to Edit > Find test1234.exe.
Export that registry key under File > Export. Remove the test1234.exe line and paste in your text file. Then reimport that file and you're done!
I'm new to VBScripting and have completely no knowledge on how to code but however i understand the basics of VBScripting.
I tried using the search function to find similar cases to mine but it doesn't have what i need.
I would really appreciate any help as my project is due soon.
Scenario:
I need to delete jpeg files that are more than 3months old that is in a directory with lots and lots of subfolders within each other. Furthermore there are 4 folders in the directory that i must not delete or modify.
How i manually did it was to navigate to the mapped drive, to the folder, use the "Search 'Folder'" from the window and type in this "datemodified:2006-01-01 .. 2013-08-31".
It will then show all the folders and subfolders and excel sheets within that folder, i'll then filter the shown list by ticking jpeg only from Type.
Code:
'**** Start of Code **********
Option Explicit
On Error Resume Next
Dim oFSO, oFolder, sDirectoryPath
Dim oFileCollection, oFile, sDir
Dim iDaysOld
' Specify Directory Path From Where You want to clear the old files
sDirectoryPath = "C:\MyFolder"
' Specify Number of Days Old File to Delete
iDaysOld = 15
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sDirectoryPath)
Set oFileCollection = oFolder.Files
For each oFile in oFileCollection
'This section will filter the log file as I have used for for test case
'Specify the Extension of file that you want to delete
'and the number with Number of character in the file extension
If LCase(Right(Cstr(oFile.Name), 4)) = "jpeg" Then
If oFile.DateLastModified < (Date() - iDaysOld) Then
oFile.Delete(True)
End If
End If
Next
Set oFSO = Nothing
enter code here`Set oFolder = Nothing
enter code here`Set oFileCollection = Nothing
enter code here`Set oFile = Nothing
'******* End of Code **********
I need to set an path that must be excluded + go through sub folders.
I'd like to thank you in advance for helping me out.
Thanks,
Working solution (Jobbo almost got it to work in generic form):
UPDATE: includes log file writing with number of folders skipped and files deleted.
Option Explicit
'set these constants to your requirements
Const DIR = "C:\Test"
Const LOGFILE = "C:\Log.txt" ' Location of Log file
Const MAX_AGE = 3 ' Unit: Months
Const FILEEXT = "jpeg"
Dim oFSO
Dim oLogFile
Dim aExclude
Dim lngDeletes, lngSkips
'add to this array to exclude paths
aExclude = Array("c:\Test\test 1", "c:\Test\test 2\test")
Set oFSO = CreateObject("Scripting.FilesystemObject")
Set oLogFile = oFSO.createtextfile(LOGFILE)
lngDeletes = 0
lngSkips = 0
LOGG "Script Start time: " & Now
LOGG "Root Folder: " & DIR
LOGG String(50, "-")
deleteFiles oFSO.GetFolder(DIR)
LOGG String(50, "-")
LOGG lngDeletes & " files are deleted"
LOGG lngSkips & " folders skipped"
LOGG "Script End time: " & Now
oLogFile.Close
Set oLogFile = Nothing
Set oFSO = Nothing
MsgBox "Logfile: """ & LOGFILE & """", vbInformation, wscript.scriptName & " Completed at " & Now
wscript.Quit
'=================================
Sub LOGG(sText)
oLogFile.writeline sText
End Sub
'=================================
Function isExclude(sPath)
Dim s, bAns
bAns = False
For Each s In aExclude
If InStr(1, sPath, s, vbTextCompare) = 1 Then
bAns = True
Exit For
End If
Next
isExclude = bAns
End Function
'=================================
Function isOldFile(fFile)
' Old file if "MAX_AGE" months before today is greater than the file modification time
isOldFile = (DateAdd("m", -MAX_AGE, Date) > fFile.DateLastModified)
End Function
'==================================
Function isFileJPEG(fFile)
Dim sFileName
sFileName = fFile.Name
' Mid(sFileName, InStrRev(sFileName, ".")) gives you the extension with the "."
isFileJPEG = (LCase(Mid(sFileName, InStrRev(sFileName, ".") + 1)) = FILEEXT)
End Function
'==================================
Sub deleteFiles(fFolder)
Dim fFile, fSubFolder
If Not isExclude(fFolder.Path) Then
'WScript.echo "==>> """ & fFolder.Path & """" ' Comment for no output
For Each fFile In fFolder.Files
If isFileJPEG(fFile) And isOldFile(fFile) Then
lngDeletes = lngDeletes + 1
LOGG lngDeletes & vbTab & fFile.Path
'WScript.echo vbTab & "DELETE: """ & fFile.Path & """" ' Comment for no output
fFile.Delete True ' Uncomment to really delete the file
End If
Next
' Only Process sub folders if current folder is not excluded
For Each fSubFolder In fFolder.SubFolders
deleteFiles fSubFolder
Next
Else
lngSkips = lngSkips + 1
'WScript.echo "<<-- """ & fFolder.Path & """" ' Comment for no output
End If
End Sub
Never ever use On Error Resume Next unless it absolutely cannot be avoided.
This problem needs a recursive function. Here's how I would do it:
Option Explicit
'set these constants to your requirements
Const DIR = "C:\MyFolder"
Const AGE = 15
Dim oFSO
Dim aExclude
'add to this array to exclude paths
aExclude = Array("c:\folder\exclude1", "c:\folder\another\exclude2")
Set oFSO = CreateObject("Scripting.FilesystemObject")
Call deleteFiles(oFSO.GetFolder(DIR))
Set oFSO = Nothing
WScript.Quit
'=================================
Function isExclude(sPath)
Dim s
For Each s in aExclude
If LCase(s) = LCase(sPath) Then
isExclude = True
Exit Function
End If
Next
isExclude = False
End Function
'==================================
Sub deleteFiles(fFolder)
Dim fFile, fSubFolder
If Not isExclude(fFolder.Path) Then
For Each fFile in fFolder.Files
If (LCase(Right(Cstr(fFile.Name),4)) = "jpeg") And (fFile.DateLastModified < (Date() - AGE)) Then
'WScript.echo fFile.Path 'I put this in for testing, uncomment to do the same
Call fFile.Delete(true)
End If
Next
End If
For Each fSubFolder in fFolder.SubFolders
Call deleteFiles(fSubFolder)
Next
End Sub
I'm not really able to fully test it out because I don't have an example data set, but really all you need to do is set DIR and change the aExclude array. Make sure you know what its going to delete before you run it though...
Also, it will only delete jpeg extensions, not jpg but I imagine you already know that
I'm attempting to convert PPT files to PPTX files using VBSCRIPT. I haven't used VB in a very long time & am pretty unfamiliar with the framework. I'm attempting to modify a script that converts PPTX/PPT to PDF, however without much luck. Here's an example of what I've got so far...
Option Explicit
Dim inputFile
Dim objPPT
Dim objPresentation
Dim objPrintOptions
Dim objFso
Dim pptf
If WScript.Arguments.Count <> 1 Then
WriteLine "You need to specify input and output files."
WScript.Quit
End If
inputFile = WScript.Arguments(0)
Set objFso = CreateObject("Scripting.FileSystemObject")
If Not objFso.FileExists( inputFile ) Then
WriteLine "Unable to find your input file " & inputFile
WScript.Quit
End If
WriteLine "Input File: " & inputFile
Set objPPT = CreateObject( "PowerPoint.Application" )
objPPT.Visible = True
objPPT.Presentations.Open inputFile
Set objPresentation = objPPT.ActivePresentation
objPresentation.SaveAs "out.pptx", Microsoft.Office.Interop.PowerPoint.PpSaveAsFileType.ppSaveAsOpenXMLPresentation
objPresentation.Close
ObjPPT.Quit
Things turn pear shaped around the objPresentation.SaveAs line; obviously its illegal syntax - however I'm not sure of the best route here. Any help would be much appreciated. Also if there are other variables (or a link to api documentation) for converting doc->docx, and xls->xlsx.
Thanks in advance.
EDIT:
I found a solution to this myself; sorry I stopped checking in on this thread a few days after posted it. I found a documentation page for this code & noticed one function in particular (convert2): http://msdn.microsoft.com/en-us/library/office/ff743830.aspx
I'll mark the answer below as the answer; because it came first (although I haven't tested it). If you're interested - heres my code; AFAIK it only converts in between various PowerPoint formats (in either direction). Also FYI I modified this script from another popularly googlized script on the topic; the only line I changed was one of the last (the convert2 mehtod). Anyways... (also - this requires office 2010; per the documentation)
Usage:
CSCRIPT scriptName.vbs C:\inputfileName.ppt C:\outputFileName.pptx
Option Explicit
Sub WriteLine ( strLine )
WScript.Stdout.WriteLine strLine
End Sub
' http://msdn.microsoft.com/en-us/library/office/aa432714(v=office.12).aspx
Const msoFalse = 0 ' False.
Const msoTrue = -1 ' True.
' http://msdn.microsoft.com/en-us/library/office/bb265636(v=office.12).aspx
Const ppFixedFormatIntentScreen = 1 ' Intent is to view exported file on screen.
Const ppFixedFormatIntentPrint = 2 ' Intent is to print exported file.
' http://msdn.microsoft.com/en-us/library/office/ff746754.aspx
Const ppFixedFormatTypeXPS = 1 ' XPS format
Const ppFixedFormatTypePDF = 2 ' PDF format
' http://msdn.microsoft.com/en-us/library/office/ff744564.aspx
Const ppPrintHandoutVerticalFirst = 1 ' Slides are ordered vertically, with the first slide in the upper-left corner and the second slide below it.
Const ppPrintHandoutHorizontalFirst = 2 ' Slides are ordered horizontally, with the first slide in the upper-left corner and the second slide to the right of it.
' http://msdn.microsoft.com/en-us/library/office/ff744185.aspx
Const ppPrintOutputSlides = 1 ' Slides
Const ppPrintOutputTwoSlideHandouts = 2 ' Two Slide Handouts
Const ppPrintOutputThreeSlideHandouts = 3 ' Three Slide Handouts
Const ppPrintOutputSixSlideHandouts = 4 ' Six Slide Handouts
Const ppPrintOutputNotesPages = 5 ' Notes Pages
Const ppPrintOutputOutline = 6 ' Outline
Const ppPrintOutputBuildSlides = 7 ' Build Slides
Const ppPrintOutputFourSlideHandouts = 8 ' Four Slide Handouts
Const ppPrintOutputNineSlideHandouts = 9 ' Nine Slide Handouts
Const ppPrintOutputOneSlideHandouts = 10 ' Single Slide Handouts
' http://msdn.microsoft.com/en-us/library/office/ff745585.aspx
Const ppPrintAll = 1 ' Print all slides in the presentation.
Const ppPrintSelection = 2 ' Print a selection of slides.
Const ppPrintCurrent = 3 ' Print the current slide from the presentation.
Const ppPrintSlideRange = 4 ' Print a range of slides.
Const ppPrintNamedSlideShow = 5 ' Print a named slideshow.
' http://msdn.microsoft.com/en-us/library/office/ff744228.aspx
Const ppShowAll = 1 ' Show all.
Const ppShowNamedSlideShow = 3 ' Show named slideshow.
Const ppShowSlideRange = 2 ' Show slide range.
'
' This is the actual script
'
Dim inputFile
Dim outputFile
Dim objPPT
Dim objPresentation
Dim objPrintOptions
Dim objFso
If WScript.Arguments.Count <> 2 Then
WriteLine "You need to specify input and output files."
WScript.Quit
End If
inputFile = WScript.Arguments(0)
outputFile = WScript.Arguments(1)
Set objFso = CreateObject("Scripting.FileSystemObject")
If Not objFso.FileExists( inputFile ) Then
WriteLine "Unable to find your input file " & inputFile
WScript.Quit
End If
If objFso.FileExists( outputFile ) Then
WriteLine "Your output file (' & outputFile & ') already exists!"
WScript.Quit
End If
WriteLine "Input File: " & inputFile
WriteLine "Output File: " & outputFile
Set objPPT = CreateObject( "PowerPoint.Application" )
objPPT.Visible = True
objPPT.Presentations.Open inputFile
Set objPresentation = objPPT.ActivePresentation
Set objPrintOptions = objPresentation.PrintOptions
objPrintOptions.Ranges.Add 1,objPresentation.Slides.Count
objPrintOptions.RangeType = ppShowAll
' Reference for this at http://msdn.microsoft.com/en-us/library/office/ff746080.aspx
objPresentation.convert2(output)
objPresentation.Close
ObjPPT.Quit
Normally you would do this in PowerPoint with ExportAsFixedFormat(...). Since you chose VBS, you have to use SaveAs(...).
I assume you would also want to be able to batch convert ppt/pptx into pdf rather than specify a full file name one by one...
Option Explicit
'http://msdn.microsoft.com/en-us/library/office/bb251061(v=office.12).aspx
Const ppSaveAsPDF = 32
Dim oFSO ' Public reference to FileSystemObject
Dim oPPT ' Public reference to PowerPoint App
Main
Sub Main()
Dim sInput
If wscript.Arguments.Count <> 1 Then
Wscript.Echo "You need to specify input and output files."
wscript.Quit
End If
' PowerPoint version must be 12 or later (PowerPoint 2007 or later)
Set oPPT = CreateObject("PowerPoint.Application")
If CDbl(oPPT.Version) < 12 Then
Wscript.Echo "PowerPoint version must be 2007 or later!"
oPPT.Visible = True
oPPT.Quit
Set oPPT = Nothing
wscript.Quit
End If
' Store Input Argument and detect execute mode (single file / Folder batch mode)
sInput = wscript.Arguments(0)
Set oFSO = CreateObject("Scripting.FileSystemObject")
If IsPptFile(sInput) Then
PPT2PDF sInput
ElseIf oFSO.FolderExists(sInput) Then
Wscript.Echo "Batch Start: " & Now
Wscript.Echo "Root Folder: " & sInput
BatchPPT2PDF sInput
Else
Wscript.Echo """" & sInput & """ is not a PPT file or Folder!"
End If
' Close PowerPoint app if no other presentations are opened
If oPPT.Presentations.Count = 0 Then oPPT.Quit
Set oPPT = Nothing
Set oFSO = Nothing
End Sub
Private Sub BatchPPT2PDF(sFDR)
Dim oFDR, oFile
Wscript.Echo String(50, Chr(151))
Wscript.Echo "Processing Folder: " & sFDR
For Each oFile In oFSO.GetFolder(sFDR).Files
If IsPptFile(oFile.Name) Then
PPT2PDF(oFile)
End If
Next
For Each oFDR In oFSO.GetFolder(sFDR).SubFolders
BatchPPT2PDF oFDR
Next
End Sub
Private Function IsPptFile(sFile)
IsPptFile = (InStr(1, Right(sFile, InStrRev(sFile, ".")), "ppt") > 0)
End Function
Private Sub PPT2PDF(sFile)
On Error Resume Next
Dim sPDF, oPres
sPDF = Left(sFile,InstrRev(sFile,".")) & "pdf"
Set oPres = oPPT.Presentations.Open(sFile, True, False, False) ' Read Only, No Title, No Window
Err.Clear
oPres.SaveAs sPDF, ppSaveAsPDF
oPres.Close
Set oPres = Nothing
If Err.Number = 0 Then
Wscript.Echo "OK" & vbTab & sPDF
Else
Wscript.Echo "X" & vbTab & sPDF & " [ERR " & Err.Number & ": " & Err.Description & "]"
Err.Clear
End If
End Sub
I am using the following VBscript to get the total row count from my csv files. I need help in exporting the returned line count to a csv which will have two columns Name and Count name will be anything and the count is the returned count.
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objArgs = WScript.Arguments
myFile = objArgs(0)
Set objFile = objFSO.OpenTextFile(myFile,1)
Do Until objFile.AtEndOfLine
line = objFile.Line
objFile.ReadLine
Loop
WScript.Echo "Line count of", myFile , "is", line
The way i would like to call the script would be:
Cscript 'vbscript_name' file_name_to_count 'custom_name' 'export_count.csv'
Thanks
Maybe I not see where is the break, as you only need to create new file and write just 2 lines in, but it w'd be something like this:
Set objFile = objFSO.OpenTextFile(objArgs(2), 2, True)
objFile.WriteLine "Name,Count"
objFile.WriteLine objArgs(1) & "," & line
objFile.Close
And just to become more friendly, here is the whole deal:
Set objArgs = WScript.Arguments
iLinesCount = FileLinesCount(objArgs(0))
DumpResult objArgs(2), objArgs(1), iLinesCount
WScript.Echo "File: " & objArgs(0) & " has " & iLinesCount & " lines"
Function FileLinesCount(strFileName)
With CreateObject("Scripting.FileSystemObject")
With .OpenTextFile(strFileName, 1)
Do Until .AtEndOfStream
Call .ReadLine
Loop
FileLinesCount = .Line
End With
End With
End Function
Sub DumpResult(strFileName, strCustomName, iCount)
With CreateObject("Scripting.FileSystemObject")
With .OpenTextFile(strFileName, 2, True)
.WriteLine "Name,Count"
.WriteLine strCustomName & "," & iCount
End With
End With
End Sub
Also it's good to add error checks for your command line arguments, but I live this simple task to you, cheers!
P.S. I suppose you'll prefer to append your count data to existing file instead of creating new file for each counted source file. If so, you have a very little work on DumpResult function, just need to open the file for appending (ForAppending = 8) and add "header" (column names) only then needs (i.e. when the file is newly created):
' modified version w`d be:
Sub DumpResult(strFileName, strCustomName, iCount)
With CreateObject("Scripting.FileSystemObject")
With .OpenTextFile(strFileName, 8, True)
If .Line = 1 Then ' new empty file
.WriteLine "Name,Count" ' add column names
End If
.WriteLine strCustomName & "," & iCount
End With
End With
End Sub