[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 :thumb:

[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 :wave:

[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. :thumb:

[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 :afrog:

[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. ;)