I have a number of Powerpoint files in a folder (around 10 or so) and am looking to create VBA in Powerpoint that will PDF all of them. What I have appears to work, but it PDFs most of the files but not all of them. No idea why - the ppts it misses each time will vary.
I'm running the below 'OpenPPts' which is calling the the sub 'CreatePdfs'. Calling the CreatePdfs as a separate sub is ideal for me as I can change this to complete other tasks.
Any help would be much appreciated.
Public Sub OpenPpts()
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
Dim oSld As Slide
On Error Resume Next
strFolderName = "C:\my ppt files\"
strFileName = Dir(strFolderName & "\*.pptx")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'enter the vba to call below
Call CreatePdf
PP.Save
PP.Close
strFileName = Dir
Loop
End Sub
Sub CreatePdf()
'saves opens PPT as PDF in the same folder and applies same name.
ActivePresentation.ExportAsFixedFormat ActivePresentation.Path & "\" & ActivePresentation.Name & ".pdf", ppFixedFormatTypePDF, ppFixedFormatIntentPrint
End Sub
Related
I'm trying to copy all slides (preserving format) from an open presentation to a new one (except slide 2). I've got a block of code that seems to work if I step through it, but when I run it in presentation mode (or using Alt+F8), only the last slide is copied to the new presentation the same number of times as there are original presentation slides.
Can anyone spot what I'm doing wrong? Thanks for your help!
Public Sub SaveAs()
Dim oldPresentation As Presentation, newPresentation As Presentation
Dim oldSlide As Slide
Dim i As Integer, count As Integer, path As String, newFileName As String
path = ActivePresentation.path
count = ActivePresentation.Slides.count
Set oldPresentation = ActivePresentation
Set newPresentation = Application.Presentations.Add
For i = 1 To count
If i <> 2 Then
Set oldSlide = oldPresentation.Slides(i)
oldSlide.Copy
newPresentation.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
End If
Next i
newFileName = "\Test " & Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") & ".pptx"
newFileName = Replace(newFileName, ":", "-")
With newPresentation
.SaveCopyAs fileName:=path & newFileName, FileFormat:=ppSaveAsOpenXMLPresentation
End With
newPresentation.Close
End Sub
I found sort of silly solution. I save the current deck to a new copy, then just delete slide 2. Not sure if this is a preferred method or not.
Public Sub SaveAs()
Dim oldPresentation As Presentation
Dim newDeck As Presentation
Dim path As String, newFileName As String
path = ActivePresentation.path
Set oldPresentation = ActivePresentation
newFileName = "\HRB " & Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") & ".pptx"
newFileName = Replace(newFileName, ":", "-")
With oldPresentation
.SaveCopyAs fileName:=path & newFileName, FileFormat:=ppSaveAsOpenXMLPresentation
End With
Set newDeck = GetObject(path & newFileName)
newDeck.Slides(2).Delete
newDeck.Save
newDeck.Close
End Sub
I'm developing an Excel Add-in for .bat / .vbs files. The add-in has 2 options (1) create a new .bat / and .vbs file and (2) modify an existing .bat and .vbs file.
The "create" option is working great and does exactly what we need it to do.
I'm having issues with the "modify" piece. When the user selects "modify", and Excel form is displayed with a List Box. The user scrolls through the list and selects the one they need to modify. So far so go.
The next step is for the add-in to open (not run) both the .bat and .vbs file. I've been able to get the .bat file to execute; which in turns executes the .vbs file. But that is not what I need it to do.
If I was going to manually open the .bat or .vbs file. I would right click on the .bat or .vbs file and select "edit". The appropriate file opens in NotePad. I can then make any changes and save the file.
What I'm looking duplicate is the "right click and select edit steps" with VBA.
Any suggestions would be greatly appreicated. Thanks for your help in advance....
I am not familiar with Add-Ins, sorry if misleading. This does work in normal code:
Assume there is a userform frmTest7 with TextBox1, ListBox1 and CommandButton1 (to save changes). The userform code as follows.
Option Explicit
Private Sub CommandButton1_Click()
Dim fso As FileSystemObject
Dim oFile As TextStream
Dim FilePath As String
Dim strFile As String
FilePath = "C:\Users\" & Environ("UserName") & "\desktop\test_bat.bat"
Dim i As Long
For i = 0 To frmTest7.ListBox1.ListCount - 1
strFile = strFile & frmTest7.ListBox1.List(i) & vbCrLf
Next i
Set fso = New FileSystemObject
If fso.FileExists(FilePath) Then
'fso.DeleteFile (FilePath)
Set oFile = fso.CreateTextFile(FilePath, True)
oFile.WriteLine strFile
End If
If Not (oFile Is Nothing) Then oFile.Close
Set oFile = Nothing
Set fso = Nothing
End Sub
Private Sub ListBox1_Click()
frmTest7.TextBox1.Text = frmTest7.ListBox1.List(frmTest7.ListBox1.ListIndex)
End Sub
Private Sub TextBox1_AfterUpdate()
frmTest7.ListBox1.List(frmTest7.ListBox1.ListIndex) = frmTest7.TextBox1.Text
End Sub
Private Sub UserForm_Activate()
Dim fso As FileSystemObject
Dim oFile As TextStream
Dim FilePath As String
Dim strFile As String
FilePath = "C:\Users\" & Environ("UserName") & "\desktop\test_bat.bat"
Set fso = New FileSystemObject
Set oFile = fso.OpenTextFile(FilePath, ForReading)
strFile = oFile.ReadAll
oFile.Close
Dim arrStrFile() As String
strFile = Replace(strFile, vbCr, "")
arrStrFile = Split(strFile, Chr(10))
frmTest7.ListBox1.Clear
frmTest7.ListBox1.List = arrStrFile
Set oFile = Nothing
Set fso = Nothing
End Sub
I found a way to do this but not sure whether it works for you or not.
1. We cannot open .bat files but we can open .txt files so I converted the .bat file to .txt file and opening it using hyperlink.
In below example, Reminder is a .bat file and on clicking the Open button it converts the Reminder.bat to Reminder.txt and opens the file.
Sub RenameFileExtensionFromBatToTextAndOpen()
Dim fileName As String
Dim fileLocation As String
Dim originalExtension As String
Dim renamedExtenstion As String
fileLocation = "C:\Users\Nandan\Downloads\"
fileName = Sheets("Sheet1").Range("B5")
originalExtension = fileLocation & fileName & ".bat"
renamedExtenstion = fileLocation & fileName & ".txt"
Name originalExtension As renamedExtenstion
ActiveWorkbook.FollowHyperlink Address:=renamedExtenstion
End Sub
2. After changes saved, on clicking Done it will change the file format from Reminder.txt to Reminder.bat
Sub RenameFileExtensionFromTxtToBat()
Dim fileName As String
Dim fileLocation As String
Dim originalExtension As String
Dim renamedExtenstion As String
fileLocation = "C:\Users\Nandan\Downloads\"
fileName = Sheets("Sheet1").Range("B5")
originalExtension = fileLocation & fileName & ".bat"
renamedExtenstion = fileLocation & fileName & ".txt"
Name renamedExtenstion As originalExtension
End Sub
On opening file,
After clicking on Done,
I copied this code from a differen website to try and help me import multiple text files at once. I changed filepaths, text specs, and the table to what I need. Now every time I try to run this is locks up and doesn't respond.
Is there an issue with having too many text files or too much data? How come its causing my program to lock up?
Public Sub WorkedAlertsImport()
On Error GoTo bImportFiles_Click_Err
Dim objFS As Object, objFolder As Object
Dim objFiles As Object, objF1 As Object
Dim strFolderPath As String
strFolderPath = "C:\Import TXT files\"
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strFolderPath)
Set objFiles = objFolder.files
For Each objF1 In objFiles
If Right(objF1.Name, 3) = "txt" Then
DoCmd.TransferText acImportDelim, "TextImportSpecs", "tblImportedFiles", strFolderPath & objF1.Name, False
Name strFolderPath & objF1.Name As "C:\Import TXT files\" & objF1.Name 'Move the files to the archive folder
End If
Next
Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing
bImportFiles_Click_Exit:
Exit Sub
bImportFiles_Click_Err:
MsgBox Err.Number & " " & Err.Description
Resume bImportFiles_Click_Exit
End Sub
After a cursory review of your code, I see no reason why it would cause MS Access to lock up, which would typically be caused by code executing a loop which never met a terminating condition (however, a For Each loop is iterating over a fixed set of data and will therefore always terminate).
I would note that the following line is redundant:
Name strFolderPath & objF1.Name As "C:\Import TXT files\" & objF1.Name
Since earlier in the code you define strFolderPath as:
strFolderPath = "C:\Import TXT files\"
Hence, you are renaming the file to itself.
The code is also naïvely testing the last three characters of the filename, which may not necessarily yield an extension if you were to encounter a file without an extension.
The code could be written without using the FSO and without the if statement altogether, as VBA offers the Dir function as standard to iterate over files of a particular type in a directory, e.g.:
Sub test()
Dim strDir As String: strDir = "C:\Import TXT files"
Dim strTxt As String: strTxt = Dir(strDir & "\*.txt")
Do Until strTxt = vbNullString
DoCmd.TransferText acImportDelim, "TextImportSpecs", "tblImportedFiles", strDir & "\" & strTxt, False
strTxt = Dir
Loop
End Sub
I have never posted here before, so I thought I would give it a try. I have a macro that I have been using for over a year, and at beginning of the week it started to give me some problems. It will either just pull in the first slide of each powerpoint, or it will give me a Run-Time error "Slides (Unknown Member): Invalid request. Clipboard is empty or contains data which may not be pasted here."
The macro works fine if I just step through it using F8, the only time that I have issues is if I try to run it. It may be something super obvious, as I am pretty new to VBA. Thanks for the help!
Public Sub DoFiles()
Dim strFileName As String
Dim strFolderName As String
Dim objPresentation As Presentation
'set default directory here if needed
strFolderName = "Target Folder"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
Set objPresentation = Presentations.Open(strFolderName & "\" &
strFileName)
On Error Resume Next
Dim i As Integer
For i = 1 To objPresentation.Slides.Count
objPresentation.Slides.Item(i).Copy
Presentations.Item(1).Slides.Paste
Presentations.Item(1).Slides.Item(Presentations.Item(1).Slides.Count).Design
= _
objPresentation.Slides.Item(i).Design
Next i
objPresentation.Close
strFileName = Dir
Loop
End Sub
Did Steve's suggestion work?
Public Sub DoFiles()
Dim strFileName As String
Dim strFolderName As String
strFolderName = "Target Folder"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
ActivePresentation.Slides.InsertFromFile strFolderName & "\" & strFileName, ActivePresentation.Slides.Count
strFileName = Dir
Loop
End Sub
I am trying to open a folder full of powerpoint files all with arabic (unicode) names and and edit them, then I knew about VBA and found this code here
yet when I tried to use it it doesn't open the files and always come with and error in the 'open' function
I also tried this solution here too -the StrConv function - but it doesn't seem to work either.
here is my final code
Sub BatchSave()
' Opens each PPT in the target folder and saves as PPT97-2003 format
Dim sFolder As String
Dim sPresentationName As String
Dim oPresentation As Presentation
' Get the foldername:
'sFolder = InputBox("Folder containing PPT files to process", "Folder")
sFolder = "E:\taranem\tttt\tranem"
If sFolder = "" Then
Exit Sub
End If
' Make sure the folder name has a trailing backslash
If Right$(sFolder, 1) <> "\" Then
sFolder = sFolder & "\"
End If
' Are there PPT files there?
If Len(Dir$(sFolder & "*.PPT")) = 0 Then
MsgBox "Bad folder name or no PPT files in folder."
Exit Sub
End If
' Open and save the presentations
sPresentationName = Dir$(sFolder & "*.ppt")
While sPresentationName <> ""
f = sFolder & StrConv(sPresentationName, vbFromUnicode)
Set oPresentation = Presentations.Open(f, , , False)
Call oPresentation.SaveAs(sFolder & "N_" & sPresentationName, ppSaveAsShow)
oPresentation.Close
' New presentation is now saved as N_originalname.ppt
' Now let's rename them - comment out the next couple lines
' if you don't want to do this
' Original.PPT to Original.PPT.OLD
Name sFolder & sPresentationName As sFolder & sPresentationName & ".OLD"
' N_Original.PPT to Original.PPT
Name sFolder & "N_" & sPresentationName As sFolder & sPresentationName
sPresentationName = Dir$()
Wend
MsgBox "DONE"
End Sub
indentation is missed up I know xD