I need to export in a .txt file that contains all the titles, numbers and comments of a PowerPoint with VBA. I found some code that allows me to do it, however I can't add the code to display the title.
I tried to use ActivePresentation.Slides(1).CustomLayout.name but it only shows me the name of slide 1. What I need is to display a dynamic title.
Dim oSl As Slide
Dim oSlides As Slides
Dim oCom As Comment
Dim sText As String
Dim sFilename As String
Set oSlides = ActivePresentation.Slides
For Each oSl In oSlides
sText = sText & vbCrLf & "==================================" & vbCrLf
sText = sText & "Slide: " & oSl.SlideIndex & vbCrLf
sText = sText & "==================================" & vbCrLf
For Each oCom In oSl.Comments
sText = sText & oCom.Text & vbCrLf
sText = sText & "--------------" & vbCrLf
Next oCom
Next oSl
sFilename = ActivePresentation.Path & "\" & "Titles-Comments" & ".txt"
If Len(sFilename) > 0 Then
WriteStringToFile sFilename, sText
SendFileToNotePad sFilename
End If
Related
I'm having a bit of trouble here. My code stops with a Run-time error -2147467259 (80004005) Mehod 'Open' of object 'Presentations: failed.
This code presents a warning, prompts for source and target folder and loops through all files in the source folder, opening each file and exporting each slide as an individual file, and again until the last file in the folder.
I put a couple of msgboxes to see if it was a problem with the names, re-wrote the open file segment based on some code from MVP Andy Pope, yet nothing.
Any help is deeply appreciated.
Sub ExportIndividualSlides()
''Application.DisplayAlerts = False
Dim ObjPPAPP As New PowerPoint.Application
Dim objPPPres As PowerPoint.Presentation
Dim objPPSlide As PowerPoint.Slide
'Initial directory path.
Dim SourceFolder As String
Dim TargetFolder As String
SourceFolder = "c:\source"
TargetFolder = "c:\target"
Dim Slide As Long
Dim SourcePresentation As Presentation
Dim SourcePresentationName As String
Dim TargetFileName As String
Dim SourceNamePath
Debug.Print "-- Start --------------------------------"
ActiveWindow.ViewType = ppViewNormal
'Loop through ppt* files only in source folder
SourcePresentationName = Dir(SourceFolder & "\*.ppt*")
MsgBox "SPN:" & SourcePresentationName
While (SourcePresentationName <> "")
SourceNamePath = SourceFolder & "\" & SourcePresentationName
Debug.Print " SourceNamePath"
MsgBox SourceNamePath
Set ObjPPAPP = New PowerPoint.Application
ObjPPAPP.Visible = True
Set objPPPres = ObjPPAPP.Presentations.Open(SourceNamePath)
' On Error GoTo errorhandler
' Open source files
Set SourcePresentation = Presentations.Open(FileName:=SourcePresentationName, WithWindow:=False)
Debug.Print " SourcePresentation: " & SourcePresentation.Name
' Loop through slides
For Slide = 1 To SourcePresentation.Slides.Count
Debug.Print " Slide: " & Slide
' Create a unique filename and save a copy of each slide
TargetFileName = Left(SourcePresentation.Name, InStrRev(SourcePresentation.Name, ".") - 1) & " [" & Slide & "].pptx"
TargetNamePath = TargetFolder & "\" & TargetFileName
Debug.Print " TargetNamePath: " & TargetNamePath
SourcePresentation.Slides(Slide).Export TargetNamePath, "PPTX"
Next Slide
objPPPres = Nothing
SourcePresentation.Close
SourcePresentationName = Dir
Wend
On Error GoTo 0
Exit Sub
errorhandler:
Debug.Print Err, Err.Description
Resume Next
End Sub
This worked for me:
Sub ExportIndividualSlides()
'use const for fixed values
Const SOURCE_FOLDER As String = "c:\source\" 'include terminal \
Const TARGET_FOLDER As String = "c:\target\"
Dim objPres As PowerPoint.Presentation
Dim Slide As Long
Dim SourcePresentationName As String
Dim TargetFileName As String
Dim TargetNamePath As String
Dim SourceNamePath
Debug.Print "-- Start --------------------------------"
ActiveWindow.ViewType = ppViewNormal
On Error GoTo errorhandler
'Loop through ppt* files only in source folder
SourcePresentationName = Dir(SOURCE_FOLDER & "*.ppt*")
Do While Len(SourcePresentationName) > 0
SourceNamePath = SOURCE_FOLDER & SourcePresentationName
Debug.Print "Opening: " & SourceNamePath
Set objPres = Presentations.Open(SourceNamePath)
' Loop through slides
For Slide = 1 To objPres.Slides.Count
Debug.Print " Slide: " & Slide
' Create a unique filename and save a copy of each slide
TargetFileName = Left(objPres.Name, InStrRev(objPres.Name, ".") - 1) & " [" & Slide & "].pptx"
TargetNamePath = TARGET_FOLDER & TargetFileName
Debug.Print " TargetNamePath: " & TargetNamePath
objPres.Slides(Slide).Export TargetNamePath, "PPTX"
Next Slide
objPres.Close
SourcePresentationName = Dir() 'next file
Loop
Exit Sub
errorhandler:
Debug.Print Err, Err.Description
Resume Next
End Sub
Can anybody help me about this issue. I found a script to take snapshot from first page of my PowerPoint. it works when I run the macro in normal view. but when i use the action button (hyperlink it to created macro) and click on it at the slideshow, there is no action.
I expect it to take snapshot from my presentation view every time i click the Action button on slide show.. but nothing
this is the script (I do not have any programming knowledge)
Sub SaveCurrentSlideAsJpg()
Dim imagePath As String
Dim slideNum As Integer
imagePath = "C:\JPG\"
slideNum = ActiveWindow.Selection.SlideRange(1).SlideIndex
If Dir(imagePath & ActivePresentation.Name & "_" & slideNum & ".jpg") <> ""
Then
Kill imagePath & ActivePresentation.Name & "_" & slideNum & ".jpg"
End If
ActivePresentation.Slides(slideNum).Export _
FileName:=imagePath & ActivePresentation.Name & "_" & slideNum & ".jpg", _
FilterName:="JPG"
End Sub
If you are referencing the SlideIndex during a slideshow, you can do it like this:
slideNum = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
Here's the full code, with some slight modifications:
Sub SaveCurrentSlideAsJpg()
Dim imagePath As String
Dim slideNum As Integer
Dim fullJpgName As String
imagePath = "C:\JPG\"
slideNum = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
fullJpgName = imagePath & ActivePresentation.Name & "_" & slideNum & ".jpg"
If Dir(fullJpgName) <> "" Then
Kill fullJpgName
End If
ActivePresentation.Slides(slideNum).Export _
FileName:=fullJpgName, FilterName:="JPG"
End Sub
I am trying to download an Excel attachment with the subject keyword.
I managed to create a code but sometimes it is giving Error 440 "Array Index out of Bounds".
The code got stuck in this part.
If Items(i).Class = Outlook.OlObjectClass.OlMail Then
Here is the code
Sub Attachment()
Dim N1 As String
Dim En As String
En = CStr(Environ("USERPROFILE"))
saveFolder = En & "\Desktop\"
N1 = "Mail Attachment"
If Len(Dir(saveFolder & N1, vbDirectory)) = 0 Then
MkDir (saveFolder & N1)
End If
Call Test01
End Sub
Private Sub Test01()
Dim Inbox As Outlook.Folder
Dim obj As Object
Dim Items As Outlook.Items
Dim Attach As Object
Dim MailItem As Outlook.MailItem
Dim i As Long
Dim Filter As String
Dim saveFolder As String, pathLocation As String
Dim dateFormat As String
Dim dateCreated As String
Dim strNewFolderName As String
Dim Creation As String
Const Filetype1 As String = "xlsx"
Const Filetype2 As String = "xlsm"
Const Filetype3 As String = "xlsb"
Const Filetype4 As String = "xls"
Dim Env As String
Env = CStr(Environ("USERPROFILE"))
saveFolder = Env & "\Desktop\Mentor Training\"
Set Inbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
'If Inbox.Items.Restrict("[UnRead] = True").Count = 0 Then
' MsgBox "No Mentor Training Mail In Inbox"
' Exit Sub
'End If
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '4/2/2017' AND " & _
Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1 AND" & Chr(34) & _
Chr(34) & "urn:schemas:httpmail:read" & _
Chr(34) & "= 0"
Set Items = Inbox.Items.Restrict(Filter)
For i = 1 To Items.Count
If Items(i).Class = Outlook.OlObjectClass.olMail Then
Set obj = Items(i)
Debug.Print obj.subject
For Each Attach In obj.Attachments
If Right(LCase(Attach.fileName), Len(Filetype1)) = Filetype1 Then 'For searching only excel files
dateFormat = Format(obj.ReceivedTime(), "dd-mm-yyyy hh-mm")
Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
End If
If Right(LCase(Attach.fileName), Len(Filetype2)) = Filetype2 Then 'For searching only excel files
dateFormat = Format(obj.ReceivedTime(), "dd-mm-yyyy hh-mm")
Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
End If
If Right(LCase(Attach.fileName), Len(Filetype3)) = Filetype3 Then 'For searching only excel files
dateFormat = Format(obj.ReceivedTime(), "dd-mm-yyyy hh-mm")
Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
End If
If Right(LCase(Attach.fileName), Len(Filetype4)) = Filetype4 Then 'For searching only excel files
dateFormat = Format(obj.ReceivedTime(), "dd-mm-yyyy hh-mm")
Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
End If
obj.UnRead = False
DoEvents
obj.Save
Next
End If
Next
MsgBox "Attachment Saved"
End Sub
It was my understanding that arrays in vba started at 0 by default. So if there is only one item in the list it will be located at Items(0). And since your for statement starts by looking at Items(1) it will throw that error. Changing it to:
For i = 0 To Items.Count - 1
should work I believe.
The filter may return zero items.
Set Items = Inbox.Items.Restrict(Filter)
If Items.Count > 0 then
For i = 1 To Items.Count
No need for setting up multiple dot objects simply use
If Items(i).Class = olMail Then
You may also wanna set your objects to nothing, once your done with them...
Set Inbox = Nothing
Set obj = Nothing
Set Items = Nothing
Set Attach = Nothing
Set MailItem = Nothing
End Sub
I exported a PDF with form fields in FDF and wrote a sub to output another FDF verbatim, with cell values for the form field values. If I edit the FDF in a text editor and change the values, Acrobat can read the file just fine, but the file output with VBA throws an error:
Adobe could not open whatever.fdf because it is either not a supported file type or because the file has been damaged
I've tried two different types of line breaks, I've tried a similar sub with xfdf formatting which is slightly different with the same results.
Sub something()
Dim sht As Worksheet
Set sht = Sheets("owssvr")
Dim lastrow As Integer
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim Fileout As Object
Dim x As Integer
For x = 2 To lastrow
Set Fileout = fso.CreateTextFile("C:\Users\blabla\" & x & ".fdf", True, True)
Fileout.Write "%FDF-1.2" & vbCrLf & _
"%âãÏÓ" & vbCrLf & _
"1 0 obj" & vbCrLf & _
"<</FDF<</F(MyDocument.pdf)/Fields[<</T(Adobe Form Field)/V(" & sht.Range("U" & x) & ")>>]/ID[<4ED54800AC4A3D41ABE4F4C7B12A3D23><609E705B7532334B8F914CFF4C09F2A0>]/UF(MyDocument.pdf)>>/Type/Catalog>>" & vbCrLf & _
"endobj" & vbCrLf & _
"trailer" & vbCrLf & _
"<</Root 1 0 R>>" & vbCrLf & _
"%%EOF" & vbCrLf
Fileout.Close
Next x
End Sub
Simply leave out the line: "%âãÏÓ" & vbCrLf & _". /ID and /UF keys not really needed.
Something like this should work:
Fileout.Write "%FDF-1.2" & vbCrLf & _
"1 0 obj<</FDF<<" & vbCrLf & _
"/F(MyDocument.pdf)" & vbCrLf & _
"/Fields" & vbCrLf & _
"[<</T(Adobe Form Field)/V(xyValue)>>]" & vbCrLf & _
">>>>" & vbCrLf & _
"endobj" & vbCrLf & _
"trailer" & vbCrLf & _
"<</Root 1 0 R>>" & vbCrLf & _
"%%EOF" & vbCrLf
You will find that in the Acrobat IAC documentation. Here a quick vbs(vba) example. Where you need only 2 lines from that: jso.getField and f.value =... Good luck.
'//-> Set a value for a form field via JSO
'//-> Settings
FileNm = "d:\TestInput.pdf"
FieldNm= "Input1"
FieldValue= "50"
'//-> let's start
Set App = CreateObject("Acroexch.app")
app.show
Set AVDoc = CreateObject("AcroExch.AVDoc")
'//-> open the file and put the value in
If AVDoc.Open(FileNM,"") Then
Set PDDoc = AVDoc.GetPDDoc()
Set jso = PDDoc.GetJSObject
'//-> Get the field and put a value in
set f = jso.getField(FieldNm)
f.value = FieldValue
end if
As much as I want to leave this open in hopes somebody figures out WHY VBA is screwing up the unicode, my problem can be solved without invoking fso at all and just using FreeFile and string replace on an original FDF
Sub blabla()
Dim objAcroApp As Acrobat.AcroApp
Dim objAcroAVDoc As Acrobat.AcroAVDoc
Dim objAcroPDDoc As Acrobat.AcroPDDoc
Dim jsObj As Object
Dim boResult As Boolean
Dim oldPDF As String
Dim NewFilePath As String
Dim sTemp As String
Dim iFileNum As Integer
Dim oldFDF As String
Dim i As Integer
Dim lastRow As Integer
Dim sht As Worksheet
Set sht = Sheets("owssvr")
With sht
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
For i = 2 To lastRow
oldPDF = "\mydoc.pdf"
oldFDF = "\mydoc_data.fdf"
newPDF = "\" & i & ".pdf"
iFileNum = FreeFile
Open oldFDF For Input As iFileNum
Do Until EOF(iFileNum)
Line Input #iFileNum, sBuf
sTemp = sTemp & vbCrLf
Loop
Close iFileNum
sTemp = Replace(sTemp, "<</T(some form field)/V( )>>", "<</T(some form field)/V(" & sht.Range("E" & i) & ")>>")
iFileNum = FreeFile
oldFDF = "\" & i & ".fdf"
Open oldFDF For Output As iFileNum
Print #iFileNum, sTemp
Close iFileNum
Set objAcroApp = CreateObject("AcroExch.App")
Set objAcroAVDoc = CreateObject("AcroExch.AVDoc")
boResult = objAcroAVDoc.Open(oldPDF, "")
Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
Set jsObj = objAcroPDDoc.GetJSObject
jsObj.ImportAnFDF oldFDF
jsObj.SaveAs newPDF
boResult = objAcroAVDoc.Close(True)
boResult = objAcroApp.Exit
Next i
End Sub
I have the following macro for Microsoft Powerpoint 365 for exporting the notes into a separate .txt file. The problem is it excludes the bullet points from the notes which are in the notes. How can I fix this problem?
Sub ExportNotesText()
Dim oSlides As Slides
Dim oSl As Slide
Dim oSh As Shape
Dim strNotesText As String
Dim strFileName As String
Dim intFileNum As Integer
Dim lngReturn As Long
' Get a filename to store the collected text
strFileName = InputBox("Enter the full path and name of file to extract notes text to", "Output file?", ActivePresentation.Path + "\notes.txt")
' did user cancel?
If strFileName = "" Then
Exit Sub
End If
' is the path valid? crude but effective test: try to create the file.
intFileNum = FreeFile()
On Error Resume Next
Open strFileName For Output As intFileNum
If Err.Number <> 0 Then ' we have a problem
MsgBox "Couldn't create the file: " & strFileName & vbCrLf _
& "Please try again."
Exit Sub
End If
Close #intFileNum ' temporarily
' Get the notes text
Set oSlides = ActivePresentation.Slides
For Each oSl In oSlides
For Each oSh In oSl.NotesPage.Shapes
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
strNotesText = strNotesText & "Slide: " & CStr(oSl.SlideIndex) & vbCrLf _
& oSh.TextFrame.TextRange.Text & vbCrLf & vbCrLf
End If
End If
End If
Next oSh
Next oSl
' now write the text to file
Open strFileName For Output As intFileNum
Print #intFileNum, strNotesText
Close #intFileNum
' show what we've done
' lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus)
End Sub
Once you have the reference to the notes TextFrame, you can loop through its .TextRange.Paragraphs collection.
This will give you an asterisk & space & and the text of the paragraph or just the text if no bullet:
If .Paragraphs(x).ParagraphFormat.Bullet.Type = ppBulletUnnumbered Then
Debug.Print "* " & .Paragraphs(x).Text
Else
Debug.Print .Paragraphs(x).Text
End if
There may also be numbered or picture bullets. Let's not go there.