Home » Blogs » meza's blog

Extract notes section from ppt

Submitted by meza on 22 August, 2012 - 17:01

Greeting,
So i have to write an excel macro extracting filename, time &date stamp, and notes from powerpoint. the notes are supposed to be copied exactly as how they look in the notes section of the powerpoint. So i came up with this, i just need help copying the notes, can someone help me plz

Sub PptToExcel()
Dim Ops As Object
Dim PPApp As Object
Dim PPPres As Object
Dim Shp As Object

Range("A1").Value = "File Name"
Range("B1").Value = "Date and Time"
Range("C1").Value = "Notes"

Dim FileName As String
Dim File As String

Range("A5:A2000").ClearContents

Dim List_Files_In_Directory(10000, 1)
Dim One_File_List As String
Dim Number_Of_Files_In_Directory As Long

' need to change the directory
One_File_List = Dir$("C:\Documents and Settings\uu903d\desktop\" + "\*.ppt*")
Do While One_File_List <> ""
List_Files_In_Directory(Number_Of_Files_In_Directory, 0) = One_File_List
One_File_List = Dir$
Number_Of_Files_In_Directory = Number_Of_Files_In_Directory + 1
Loop

Number_Of_Files_In_Directory = 0
While List_Files_In_Directory(Number_Of_Files_In_Directory, 0) <> tom
Range("A2").Offset(Number_Of_Files_In_Directory, 0).Value = List_Files_In_Directory(Number_Of_Files_In_Directory, 0)
Number_Of_Files_In_Directory = Number_Of_Files_In_Directory + 1
Wend

For i = 0 To Number_Of_Files_In_Directory

Range("B2").Offset(Number_Of_Files_In_Directory, 0).Value = FormatDateTime(Now, vbGeneralDate)
Number_Of_Files_In_Directory = Number_Of_Files_In_Directory - 1

Next

For i = 0 To Number_Of_Files_In_Directory

Range("C2:C100") = PPApp.Presentations.slides(1).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Paragraphs(1)
Number_Of_Files_In_Directory = Number_Of_Files_In_Directory - 1

Next
Range("C2:C100").Select
With Selection.Font
.Color = 100
.TintAndShade = 0
End With
Selection.Font.Italic = False
Selection.Font.Bold = False
Selection.Font.Underline = xlUnderlineStyleSingle
End Sub

»

thnks

Submitted by emadbk1984 on 25 August, 2012 - 16:36.

thnks

»

thnx

Submitted by emadbk1984 on 24 August, 2012 - 18:50.

when we extract notes from PowerPoint. you wrote it as
ActiveSheet.Cells(RowN, 3).Value = _
.Slides(1).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Paragraphs(1)

this code for multi paragraph, copy the notes in the rows, can you make it to copy the note for multi paragarphs in column instead?

thanks

»

Extract notes section with multi paragraphs

Submitted by manny on 25 August, 2012 - 13:10.

Hi,

The code line, which you posted, actually copy only the first paragraph. I did it in that way, because of my understanding of meza's requirements based on the posted code example. However, I did the desired changes. Even the changes are not so many, I post the whole subroutine again for clarity. The changes are bolded.

Here is the code:

' ************************* ' ************************* ' ************************* '
Sub ExtractSlideNoteMultiParagraphs()

Application.ScreenUpdating = False

Const FILE_TYPE As String = ".ppt"

Dim oFileDialog As FileDialog
Dim oFileSystem As FileSystemObject
Dim oLoopFolder As Folder
Dim oFilePath As File
Dim strExtension As String
Dim oPowerPoint As PowerPoint.Application
Dim oPresentation As PowerPoint.Presentation
Dim oTextRange As PowerPoint.TextRange
Dim RowN As Long
Dim PCount As Long
Dim i As Long

On Error GoTo ERROR_HANDLER

' ************************* ' ************************* ' ************************* '
' Open a dialog window to select the desired folder.
' ************************* ' ************************* ' ************************* '
Set oFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

With oFileDialog
    If .Show Then ' Check if OK button is pressed
        Set oFileSystem = CreateObject("Scripting.FileSystemObject")
        Set oLoopFolder = oFileSystem.GetFolder(.SelectedItems(1))
       
        If oLoopFolder.Files.Count = 0 Then GoTo EXIT_SUB
       
        ActiveSheet.Cells.Clear ' Clear previous contents and formats
       
        ' ******************** ' ******************** ' ******************** '
        ' Change the following part if you want to add some formats to your headers.
        ' ******************** ' ******************** ' ******************** '
        ActiveSheet.Range("A1").Value = "File Name"
        ActiveSheet.Range("B1").Value = "Date and Time"
        ActiveSheet.Range("C1").Value = "Notes" ' Add additional headers if you need
        ' ******************** ' ******************** ' ******************** '
       
        RowN = 2
       
        Set oPowerPoint = CreateObject("PowerPoint.Application")
       
        With oPowerPoint
            .WindowState = ppWindowMinimized
            .Visible = msoTrue
           
            For Each oFilePath In oLoopFolder.Files
                strExtension = Right(oFilePath, 5)
               
                If InStr(strExtension, FILE_TYPE) > 0 Then
                    Set oPresentation = oPowerPoint.Presentations.Open( _
                        FileName:=oFilePath, _
                        WithWindow:=msoFalse)
                   
                    With oPresentation
                        ActiveSheet.Cells(RowN, 1).Value = .Name
                        ActiveSheet.Cells(RowN, 2).Value = FormatDateTime(Now, vbGeneralDate)
                       
                        Set oTextRange = _
                            .Slides(1).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange
                       
                        PCount = oTextRange.Paragraphs.Count
                       
                        For i = 1 To PCount
                            ActiveSheet.Cells(RowN, i + 2).Value = oTextRange.Paragraphs(i)
                        Next i
                       
                        RowN = RowN + 1
                       
                        .Close
                    End With
                End If
            Next oFilePath
           
            .Quit
        End With
       
        ' ******************** ' ******************** ' ******************** '
        ' This is a formats from your example.
        ' ******************** ' ******************** ' ******************** '
        With ActiveSheet.Range("C2", Range("C2").End(xlDown)).Font
            .Color = 100
            .TintAndShade = 0
            .Italic = False
            .Bold = False
            .Underline = xlUnderlineStyleSingle
        End With
        ' ******************** ' ******************** ' ******************** '
    End If
End With

EXIT_SUB:
    Set oFilePath = Nothing
    Set oPowerPoint = Nothing
    Set oLoopFolder = Nothing
    Set oFileSystem = Nothing
    Set oFileDialog = Nothing
   
    Application.ScreenUpdating = True
    Exit Sub

ERROR_HANDLER:
    ' Some code for error handling
    Err.Clear
    GoTo EXIT_SUB

End Sub
' ************************* ' ************************* ' ************************* '

 

Best regards.

»

RE: Extract notes section...

Submitted by manny on 25 August, 2012 - 12:35.

Hello,

I took the liberty to make changes and write a subroutine in my way. But if you want, you can make any changes or extends to meet your further requirements.

Before run the subroutine, please check in the VBE menu Tools -> References... whether Microsoft PowerPoint 12.0 Object Library and Microsoft Scripting Runtime are checked.

If there is something else or I miss - ask me.

Here is the subroutine:

' ************************* ' ************************* ' ************************* '
Sub ExtractSlideNoteParagraph()

Application.ScreenUpdating = False

Const FILE_TYPE As String = ".ppt"

Dim oFileDialog As FileDialog
Dim oFileSystem As FileSystemObject
Dim oLoopFolder As Folder
Dim oFilePath As File
Dim strExtension As String
Dim oPowerPoint As PowerPoint.Application
Dim oPresentation As PowerPoint.Presentation
Dim RowN As Long

On Error GoTo ERROR_HANDLER

' ************************* ' ************************* ' ************************* '
' Open a dialog window to select the desired folder.
' ************************* ' ************************* ' ************************* '
Set oFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

With oFileDialog
    If .Show Then ' Check if OK button is pressed
        Set oFileSystem = CreateObject("Scripting.FileSystemObject")
        Set oLoopFolder = oFileSystem.GetFolder(.SelectedItems(1))
       
        If oLoopFolder.Files.Count = 0 Then GoTo EXIT_SUB
       
        ActiveSheet.Range("A:C").Clear ' Clear previous contents and formats
       
        ' ******************** ' ******************** ' ******************** '
        ' Change the following part if you want to add some formats to your headers.
        ' ******************** ' ******************** ' ******************** '
        ActiveSheet.Range("A1").Value = "File Name"
        ActiveSheet.Range("B1").Value = "Date and Time"
        ActiveSheet.Range("C1").Value = "Notes"
        ' ******************** ' ******************** ' ******************** '
       
        RowN = 2
       
        Set oPowerPoint = CreateObject("PowerPoint.Application")
       
        With oPowerPoint
            .WindowState = ppWindowMinimized
            .Visible = msoTrue
           
            For Each oFilePath In oLoopFolder.Files
                strExtension = Right(oFilePath, 5)
               
                If InStr(strExtension, FILE_TYPE) > 0 Then
                    Set oPresentation = oPowerPoint.Presentations.Open( _
                        FileName:=oFilePath, _
                        WithWindow:=msoFalse)
                   
                    With oPresentation
                        ActiveSheet.Cells(RowN, 1).Value = .Name
                        ActiveSheet.Cells(RowN, 2).Value = FormatDateTime(Now, vbGeneralDate)
                        ActiveSheet.Cells(RowN, 3).Value = _
                            .Slides(1).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Paragraphs(1)
                       
                        RowN = RowN + 1
                       
                        .Close
                    End With
                End If
            Next oFilePath
           
            .Quit
        End With
       
        ' ******************** ' ******************** ' ******************** '
        ' This is a formats from your example.
        ' ******************** ' ******************** ' ******************** '
        With ActiveSheet.Range("C2", Range("C2").End(xlDown)).Font
            .Color = 100
            .TintAndShade = 0
            .Italic = False
            .Bold = False
            .Underline = xlUnderlineStyleSingle
        End With
        ' ******************** ' ******************** ' ******************** '
    End If
End With

EXIT_SUB:
    Set oFilePath = Nothing
    Set oPowerPoint = Nothing
    Set oLoopFolder = Nothing
    Set oFileSystem = Nothing
    Set oFileDialog = Nothing
   
    Application.ScreenUpdating = True
    Exit Sub

ERROR_HANDLER:
    ' Some code for error handling
    Err.Clear
    GoTo EXIT_SUB

End Sub
' ************************* ' ************************* ' ************************* '

 

Best regards.

»