[RESOLVED] Power Point Profile

[Kawser]

Hello, I have a macro that can count Name:, File Size:, Number of Slide(s) Found:, Number of WordArt(s) found:, Number of TextBox found(s):, Number of Picture(s) found:, Number of AutoShape(s) found:, Number of Sound(s) & Video(s) file found:, Number of Diagram(s) found:, and Number of Chart(s) found: now what I want to do with this is when ever I press run, the macro will ask me to choose a folder that have all or some of my PowerPoint files saved then it will count all the stuff listed at top from each power point without any human interventions then it will ask me where I want to save as text file. Thanks A Lot

[zaza]

Hi,

You can use the filedialog object (in FolderPicker mode) to accomplish the navigation part. Check out the Excel Tips and Tricks link in my sig for some more info on this (it also applies to PowerPoint) or look it up in the VBA Help. There are plenty of examples there.

You will also need to know how to write text files.


zaza

[Kawser]

Need More Help Please Thanks

[Kawser]

How do I count the powerpoint item from the dialog box thanks.

[Kawser]

PLEASE HELP THANKS (SAMPLE CODE) I know how to save it in a text file all I want to know is how to count all thoes stuff listed up with in multi folder thanks.

[cssriraman]

Hi,

Here is the code usinge File dialog:

Sub ShowFileDialog()
    Dim dlgOpen As FileDialog
    Dim i As Long
    Set dlgOpen = Application.FileDialog(Type:=msoFileDialogOpen)
    With dlgOpen
        .AllowMultiSelect = True
        If .Show = -1 Then
        'if the user press the Open button
            .Execute
        'Once the file is open then run your macros
        '. . . . . . . . . . . . . . . .
        '. . . . . . . . . . . . . . . .
        '. . . . . . . . . . . . . . . .
        'Now you close the presentation.
            ActiveWindow.Close
        End If
    End With
End Sub

I hope this helps.

[cssriraman]

Here is another way to select all files in a given path:

Dim files() As String
 
Sub SelectAllPptFiles()
    Dim i As Integer
    Call GetFiles("c:\Temp\*.ppt")
    For i = LBound(files) To UBound(files)
        Debug.Print "C:\Temp\" & files(i)
    Next i
End Sub
 
Private Function GetFiles(ByVal dir_path As String) As String()
' Return an array containing the names of the
' files in the directory sorted alphabetically.
    Dim num_files As Integer
    Dim file_name As String
    file_name = Dir$(dir_path)
    Do While Len(file_name) > 0
        ' See if we should skip this file.
        If Not (file_name = ".") Or (file_name = "..") Then
            num_files = num_files + 1
            ReDim Preserve files(1 To num_files)
            files(num_files) = file_name
        End If
        ' Get the next file.
        file_name = Dir$()
    Loop
End Function

[Kawser]

I got it to work with ShowFileDialog but it does not save two or more ppt info at once on a singal text file it only does one, how do I make it so it will do more then one at once and also how do I close all the ppt when it's done. thanks a lot lot lot CSSRIRAMAN.

[cssriraman]

Here is the code to close all open presentations:

Sub ClosePPTs()
    Dim PPT As Presentation
 
    For Each PPT In Presentations
        PPT.Close
    Next
 
End Sub

[Kawser]

Thanks a lot man but when I save the text file only one gets saved not the others how do I do that thanks.

[cssriraman]

I hope this function will help you to add the required information to an exiting file:

Sub WriteTextFileContents(Text As String, filename As String, _
                          Optional AppendMode As Boolean)
    Dim fnum As Integer, isOpen As Boolean
    On Error GoTo Error_Handler
    ' Get the next free file number.
    fnum = FreeFile()
    If AppendMode Then
        Open filename For Append As #fnum
    Else
        Open filename For Output As #fnum
    End If
    ' If execution flow gets here, the file has been opened correctly.
    isOpen = True
    ' Print to the file in one single operation.
    Print #fnum, Text
    ' Intentionally flow into the error handler to close the file.
Error_Handler:
    ' Raise the error (if any), but first close the file.
    If isOpen Then Close #fnum
    If Err Then Err.Raise Err.Number, , Err.Description
End Sub

[Kawser]

What I have right now to save the text file is

For Each Slide In ActivePresentation.Slides
For Each Chart In Slide.Shapes
If Chart.Type = msoChart Then
ChartCounter = ChartCounter + 1
End If
 
Next
 
Next
 
Data.CancelError = True
On Error GoTo ErrHandler
 
Data.Filter = "Text File (*.txt)|*.txt| "
 
Data.ShowSave
strFileName = Data.filename
 
Open strFileName For Output As #1
Print #1, "Name:,File Size:,Number of Slide(s) Found:,Number of WordArt(s) found:,Number of TextBox found(s):,Number of Picture(s) found:,Number of AutoShape(s) found:,Number of Sound(s) & Video(s) file found:, Number of Diagram(s) found:,Number of Chart(s) found:"
Print #1, PowerPoint.ActivePresentation.Name; ","; ActivePresentation.BuiltInDocumentProperties.Item("Number of Bytes") / 1000; "KB"; ","; ActivePresentation.Slides.Count; ","; WordArtCounter; ","; TextBoxCounter; ","; PictureCounter; ","; AutoShapeCounter; ","; SoundVideoCounter; ","; DiagramCounter; ","; ChartCounter
Close #1
Save.Caption = "File Opener - " & Data.FileTitle
 
End
 
ErrHandler:
 
End Sub

Now how do I do it with this, and also close PPTs only close one PPT not all THANKS man you have helped me enough

[Kawser]

The text thing is not working, and also PPTs close only close one PPT not all thanks.

[Kawser]

Please Help Thanks

[Kawser]

Keep in mind it's an VBA thanks.

[cssriraman]

Hi Kawser,

Very sorry for delayed reply. Here is the solution:

Option Explicit
 
Sub WriteTextFileContents(strText As String, filename As String, Optional AppendMode As Boolean)
    Dim fnum As Integer, isOpen As Boolean
    On Error GoTo Error_Handler
    ' Get the next free file number.
    fnum = FreeFile()
    If AppendMode Then
        Open filename For Append As #fnum
    Else
        Open filename For Output As #fnum
    End If
    ' If execution flow gets here, the file has been opened correctly.
    isOpen = True
    ' Print to the file in one single operation.
    Print #fnum, strText
    ' Intentionally flow into the error handler to close the file.
Error_Handler:
    ' Raise the error (if any), but first close the file.
    If isOpen Then Close #fnum
    If Err Then Err.Raise Err.Number, , Err.Description
End Sub
 
Sub HelpMe()
    Dim dlgOpen As FileDialog
    Dim strTxtFile As String
    Dim iFile
    strTxtFile = "C:\Temp\Testing.txt"
    Set dlgOpen = Application.FileDialog(Type:=msoFileDialogOpen)
    With dlgOpen
        .AllowMultiSelect = True
        If .Show = -1 Then
            'if the user press the Open button
            For Each iFile In .SelectedItems
                'To open the file
                Presentations.Open iFile
 
                'Add the file Name
                Call WriteTextFileContents(iFile & vbCrLf, strTxtFile, True)
 
                'Count the number of slides and store it in text file
                Call WriteTextFileContents("Total No. of Slides: " & Presentations(iFile).Slides.Count & vbCrLf, strTxtFile, True)
 
                'To close the file
                Presentations(iFile).Close
            Next
        End If
    End With
End Sub

Change the code as per your need.

Regards,

[Kawser]

Thanks a lot but it says path not found thanks again.

[cssriraman]

Here the text file name is "C:\Temp\Testing.txt". I think because of that you are getting that error. so make sure you have a folder called "Temp" in C drive.

changed the code in my previous post in HelpMe procedure.

[Kawser]

how do i make this automated please thanks.

[Kawser]

also can you choose where do you want to save thanks

[cssriraman]

how do i make this automated please thanks.

What do you want to automate?

The code which I gave you will open the selected files one by one and count the number of slides and update the Testing.txt file.

Whate else you want to do?

You haven't mentioned anything about the Error you get last time. What happen to that? Are you still getting errors?

[Kawser]

No I am not getting an erro but what I wanted was the user to select the ppt(s) that they want to test then choose where they want to save the text thanks a lot thoe.

[cssriraman]

Here is the complete code:

Option Explicit
 
Dim strFilter As String
Dim strInputFileName As String
 
Type tagOPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    strFilter As String
    strCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    strFile As String
    nMaxFile As Long
    strFileTitle As String
    nMaxFileTitle As Long
    strInitialDir As String
    strTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    strDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
 
Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
 
Global Const ahtOFN_READONLY = &H1
Global Const ahtOFN_OVERWRITEPROMPT = &H2
Global Const ahtOFN_HIDEREADONLY = &H4
Global Const ahtOFN_NOCHANGEDIR = &H8
Global Const ahtOFN_SHOWHELP = &H10
Global Const ahtOFN_NOVALIDATE = &H100
Global Const ahtOFN_ALLOWMULTISELECT = &H200
Global Const ahtOFN_EXTENSIONDIFFERENT = &H400
Global Const ahtOFN_PATHMUSTEXIST = &H800
Global Const ahtOFN_FILEMUSTEXIST = &H1000
Global Const ahtOFN_CREATEPROMPT = &H2000
Global Const ahtOFN_SHAREAWARE = &H4000
Global Const ahtOFN_NOREADONLYRETURN = &H8000
Global Const ahtOFN_NOTESTFILECREATE = &H10000
Global Const ahtOFN_NONETWORKBUTTON = &H20000
Global Const ahtOFN_NOLONGNAMES = &H40000
Global Const ahtOFN_EXPLORER = &H80000
Global Const ahtOFN_NODEREFERENCELINKS = &H100000
Global Const ahtOFN_LONGNAMES = &H200000
 
Function TestIt()
    Dim strFilter As String
    strFilter = ahtAddFilterItem(strFilter, "Text Files (*.txt)", "*.TXT")
    strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*")
    Call HelpMe
End Function
 
Function ahtCommonFileOpenSave(Optional ByRef Flags As Variant, Optional ByVal InitialDir As Variant, Optional ByVal Filter As Variant, Optional ByVal FilterIndex As Variant, Optional ByVal DefaultExt As Variant, Optional ByVal filename As Variant, Optional ByVal DialogTitle As Variant, Optional ByVal hwnd As Variant, Optional ByVal OpenFile As Variant) As Variant
    Dim OFN As tagOPENFILENAME
    Dim strFileName As String
    Dim strFileTitle As String
    Dim fResult As Boolean
    If IsMissing(InitialDir) Then InitialDir = CurDir
    If IsMissing(Filter) Then Filter = ""
    If IsMissing(FilterIndex) Then FilterIndex = 1
    If IsMissing(Flags) Then Flags = 0&
    If IsMissing(DefaultExt) Then DefaultExt = ""
    If IsMissing(filename) Then filename = ""
    If IsMissing(DialogTitle) Then DialogTitle = ""
    If IsMissing(OpenFile) Then OpenFile = True
    strFileName = Left(filename & String(256, 0), 256)
    strFileTitle = String(256, 0)
    With OFN
        .lStructSize = Len(OFN)
        .strFilter = Filter
        .nFilterIndex = FilterIndex
        .strFile = strFileName
        .nMaxFile = Len(strFileName)
        .strFileTitle = strFileTitle
        .nMaxFileTitle = Len(strFileTitle)
        .strTitle = DialogTitle
        .Flags = Flags
        .strDefExt = DefaultExt
        .strInitialDir = InitialDir
        .hInstance = 0
        .lpfnHook = 0
        .strCustomFilter = String(255, 0)
        .nMaxCustFilter = 255
    End With
    If OpenFile Then
        fResult = aht_apiGetOpenFileName(OFN)
    Else
        fResult = aht_apiGetSaveFileName(OFN)
    End If
    If fResult Then
        If Not IsMissing(Flags) Then Flags = OFN.Flags
        ahtCommonFileOpenSave = TrimNull(OFN.strFile)
    Else
        ahtCommonFileOpenSave = vbNullString
    End If
End Function
 
Function ahtAddFilterItem(strFilter As String, strDescription As String, Optional varItem As Variant) As String
    If IsMissing(varItem) Then varItem = "*.*"
    ahtAddFilterItem = strFilter & strDescription & vbNullChar & varItem & vbNullChar
End Function
 
Private Function TrimNull(ByVal strItem As String) As String
    Dim intPos As Integer
    intPos = InStr(strItem, vbNullChar)
    If intPos > 0 Then
        TrimNull = Left(strItem, intPos - 1)
    Else
        TrimNull = strItem
    End If
End Function
 
Sub WriteTextFileContents(strText As String, filename As String, Optional AppendMode As Boolean)
    Dim fnum As Integer, isOpen As Boolean
    On Error GoTo Error_Handler
    ' Get the next free file number.
    fnum = FreeFile()
    If AppendMode Then
        Open filename For Append As #fnum
    Else
        Open filename For Output As #fnum
    End If
    ' If execution flow gets here, the file has been opened correctly.
    isOpen = True
    ' Print to the file in one single operation.
    Print #fnum, strText
    ' Intentionally flow into the error handler to close the file.
Error_Handler:
    ' Raise the error (if any), but first close the file.
    If isOpen Then Close #fnum
    If Err Then Err.Raise Err.Number, , Err.Description
End Sub
 
Sub HelpMe()
    Dim lngFlags As Long
    Dim dlgOpen As FileDialog
    Dim strTxtFile As String
    Dim iFile
    Set dlgOpen = Application.FileDialog(Type:=msoFileDialogOpen)
    strTxtFile = ahtCommonFileOpenSave(InitialDir:="C:\", Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, DialogTitle:="Save the Txt file As")
    With dlgOpen
        .AllowMultiSelect = True
        If .Show = -1 Then
            'if the user press the Open button
            For Each iFile In .SelectedItems
                'To open the file
                Presentations.Open iFile
 
                'Add the file Name
                Call WriteTextFileContents(iFile & vbCrLf, strTxtFile, True)
 
                'Count the number of slides and store it in text file
                Call WriteTextFileContents("Total No. of Slides: " & Presentations(iFile).Slides.Count & vbCrLf, strTxtFile, True)
 
                'To close the file
                Presentations(iFile).Close
            Next
        End If
    End With
End Sub

[cssriraman]

Run the function "TestIT". first it will ask you to save the text file and then it will ask you to select the ppt files then it will process.

[cssriraman]

Do you need any other help on this thread?

When you have received an answer to your question, please mark it as resolved using the Thread Tools menu.

[Kawser]

Thanks A Lot cssriraman that looks complicated your the great.