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
Related
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
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 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 am having problems with my code since it only works in the specific folders but not in all subfolders inside the particular folder.
Could someone please helps to make the code works to all subfolders inside that specific folder? :)
These are my code:
Sub Execute1()
Dim monthstr As String
Dim year As String
Dim monthtext As String
Dim prevmonth As String
Dim prevmonthtext As String
year = Range("D8").Text
monthstr = Trim(Range("D9").Text)
monthtext = Trim(Range("D10").Text)
prevmonth = Trim(Range("D11").Text)
prevmonthtext = Trim(Range("D12").Text)
prevyear = Trim(Range("D13").Text)
'confirmation box before running macro//////////////////////////////////////////////////////////////////////////////////////
response = MsgBox("Are you sure the settings are correct?", vbYesNo, "Confirmation")
If response = vbNo Then
Exit Sub
End If
'optimize macro speed///////////////////////////////////////////////////////////////////////////////////////////////////////////
Call Optimize
'finding the correct path (month)//////////////////////////////////////////////////////////////////////////////////////////
Dim myfile As String
Dim mypath As String
Dim newpath As String
mypath = "C:\Users\praseirw\Desktop\Tes CC\" & prevyear & "\SC\" & prevmonth & " " & prevmonthtext & "\"
myfile = Dir(mypath & "*.xlsx")
newpath = "C:\Users\praseirw\Desktop\Tes CC\" & year & "\SC\" & monthstr & " " & monthtext & "\"
'loop through all files in specified month//////////////////////////////////////////////////////////////////////////////////
Dim root As Workbook
Dim rng As Range
Dim wb As Workbook
Dim ws As Worksheet
Set root = Workbooks("CC Reports Center.xlsm")
Set rng = root.Worksheets("Settings").Range("H7:H14")
Do While myfile <> ""
Set wb = Workbooks.Open(mypath & myfile)
For Each ws In wb.Worksheets
rng.Copy
With ws.Range("D1")
.PasteSpecial xlPasteFormulas
End With
Next ws
Dim oldname As String
Dim newname As String
Dim wbname As String
oldname = wb.Name
wbname = Mid(oldname, 9)
newname = year & "_" & monthstr & "_" & wbname
wb.SaveAs Filename:=newpath & newname
wb.Close
Set wb = Nothing
myfile = Dir
Loop
Application.CutCopyMode = False
MsgBox "Task Complete!"
'reset macro optimization settings//////////////////////////////////////////////////////////////////////////////////////////////
Call ResetOptimize
End Sub
Here's one way to do it with the Dir function. If you want something a little more elegant you may want to consider using a FileSystemObject. (Note that to view Debug.Print output you have to enable the immediate window from under view.)
Sub test()
Dim root As String
root = "C:\"
Dim DC As New Collection
s = Dir(root & "*", vbDirectory)
Do Until s = ""
DC.Add s
s = Dir
Loop
For Each D In DC
Debug.Print D
On Error Resume Next: s = Dir(root & D & "\*.xl*"): On Error GoTo 0
Do Until s = ""
Debug.Print " " & s
s = Dir
Loop
Next
End Sub
Here's an example of how to do this with a FileSystemObject. Note that my code is a little sloppy with "On error resume next" to protect against access denied or other errors. Realistically you may want to consider incorporating better error handling, but that's another topic. Using a FileSystemObject is more powerful than Dir because Dir only returns a string, while FileSystemObject lets you work with files and folders as actual objects, which are much more powerful.
Sub test()
'You can use "CreateObject..." to add a FileSystemObject from the Scipting Library
'Alternatively, you can add a reference to "Microsoft Scripting Runtime"
'allowing you to directly declare a filesystemobject and access related intellisense
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder = fso.GetFolder("C:\")
For Each SubFolder In Folder.SubFolders
Debug.Print SubFolder.Name
On Error Resume Next
For Each File In SubFolder.Files
Debug.Print " " & File.Name
Next
On Error GoTo 0
Next
End Sub
I've been trying to find a script that saves attachments to a folder on our network from Outlook. I've finally got something working but it looks like it doesn't work on my 2nd system which happens to be Outlook 2010. I can't say for sure if it's because of this difference.
Code is:
Sub SaveAllAttachments(objItem As MailItem)
Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
strLocation = "C:\test\"
On Error GoTo ExitSub
If objItem.Class = olMail Then
Set objAttachments = objItem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
GoTo 100
End If
For dblLoop = 1 To dblCount
strID = " from " & Format(Date, "mm-dd-yy") 'Append the Date
'strID = strID & " at " & Format(Time, "hh`mm AMPM") 'Append the Time
' These lines are going to retrieve the name of the
' attachment, attach the strID to it to insure it is
' a unique name, and then insure that the file
' extension is appended to the end of the file name.
strName = objAttachments.Item(dblLoop).Filename 'Get attachment name
strExt = Right$(strName, 4) 'Store file Extension
strName = Left$(strName, Len(strName) - 4) 'Remove file Extension
strName = strName & strID & strExt 'Reattach Extension
' Tell the script where to save it and
' what to call it
strName1 = strLocation & "PDF\" & strName 'Put it all together
strName2 = strLocation & "JPG\" & strName 'Put it all together
' Save the attachment as a file.
objAttachments.Item(dblLoop).SaveAsFile strName1
objAttachments.Item(dblLoop).SaveAsFile strName2
Next dblLoop
objItem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub
It doesn't matter what Outlook version you are using at the moment. The code should work correcly.
Possible reasons why it doesn't work:
I'd suggest choosing another location for saving files. The C: drive requires admin privileges on latest OS.
The rule is not triggered.
An error in the script. Try to call the script manually from other VBA sub and see what happens under the hood. Do you get any errors in the code?