Log In
Register
Home
December 4, 2021
Offline
I posted a macro, and @Velouria had a great solution of using a Function to browse for the folder, rather than hardcoding a location or using GetFolder. (Brilliant). I had already closed that one as my specific request had been answered. Anyways, My Boss now wants The Software Name (Word, Excel, Adobe, PowerPoint, etc....) to display in Column A, and the file extension to appear in Column B. This would then shift the current info of Document Name from (currently) column A to Column C. And No of Pages from Column B to Column C. Here is the current VBA code below. This code works on PDF files if I change the extension. However I have to do PowerPoint (count # of slides) and Excel (# of sheets) manually. Can a version of this code be "converted" to use for those softwares too? I would run it seperately, as all PP files are in a seperate folder, same is true for Excel.
Sub CountPagesInDocs()
Const wdStatisticPages = 2
Dim wsStats As Worksheet
Dim objWrd As Object
Dim objDoc As Object
Dim strFileName As String
Dim strPath As String
Dim arrStats()
Dim cnt As Long
strPath = GetFolder & "\" ' This code uses Function code below to BROWSE
strFileName = Dir(strPath & "*.doc*")
Set objWrd = CreateObject("Word.Application")
objWrd.Visible = False
Do While Len(strFileName) 0
ReDim Preserve arrStats(1 To 2, cnt)
Set objDoc = objWrd.Documents.Open(strPath & strFileName)
arrStats(1, cnt) = strFileName
arrStats(2, cnt) = objDoc.ComputeStatistics(wdStatisticPages)
objDoc.Close
cnt = cnt + 1
strFileName = Dir
Loop
objWrd.Quit
Set objWrd = Nothing
Set wsStats = Sheets.Add
With wsStats
.Range("A1:B1").Value = Array("Document Name", "No of Pages")
.Range("A2:B2").Resize(UBound(arrStats, 2) + 1).Value = Application.Transpose(arrStats)
.Range("A1:B1").EntireColumn.AutoFit
End With
End Sub
Function GetFolder() As String
Dim dlg As fileDialog
Set dlg = Application.fileDialog(msoFileDialogFolderPicker)
dlg.InitialFileName = "C:\"
If dlg.Show = -1 Then
GetFolder = dlg.SelectedItems(1)
End If
End Function
Trusted Members
Moderators
November 1, 2018
Offline
You could do something like this (it could probably do with a bit of refactoring and some error handling, but should get you started):
Option Explicit
Sub GetWordPageCounts()
CountPagesInFiles "Word"
End Sub
Sub GetAdobePageCounts()
CountPagesInFiles "Adobe"
End Sub
Sub GetExcelSheetCounts()
CountPagesInFiles "Excel"
End Sub
Sub GetPowerPointSlideCounts()
CountPagesInFiles "Powerpoint"
End Sub
Sub CountPagesInFiles(appName As String)
Dim arrStats()
Dim cnt As Long
Dim FilePath As String
FilePath = GetFolder & "\" ' This code uses Function code below to BROWSE
Dim startAppName As String
startAppName = appName
Dim FileExt As String
Dim countType As String
Select Case LCase$(appName)
Case "word"
FileExt = "doc*"
countType = "Pages"
Case "adobe"
startAppName = "Word" ' use Word to handle pdfs
FileExt = "pdf"
countType = "Pages"
Case "excel"
FileExt = "xl*"
countType = "Sheets"
Case "powerpoint"
FileExt = "ppt*"
countType = "Slides"
Case Else
MsgBox "Invalid application name!"
Exit Sub
End Select
Dim fileName As String
fileName = Dir(FilePath & "*." & FileExt)
If Len(fileName) 0 Then
Dim someApp As Object
Set someApp = CreateObject(startAppName & ".Application")
If LCase$(appName) "powerpoint" Then someApp.Visible = False
Do
ReDim Preserve arrStats(1 To 4, cnt)
arrStats(1, cnt) = appName
arrStats(2, cnt) = FileExt
arrStats(3, cnt) = fileName
arrStats(4, cnt) = GetPageCount(someApp, appName, FilePath & fileName)
cnt = cnt + 1
fileName = Dir
Loop While Len(fileName) 0
someApp.Quit
Set someApp = Nothing
Dim StatsSheet As Worksheet
Set StatsSheet = Sheets.Add
With StatsSheet
Dim colCount As Long
colCount = UBound(arrStats, 1)
.Range("A1").Resize(, colCount).Value = Array("Application", "File extension", "Document Name", "No of " & countType)
.Range("A2").Resize(UBound(arrStats, 2) + 1, colCount).Value = Application.Transpose(arrStats)
.Range("A1").Resize(, colCount).EntireColumn.AutoFit
End With
End If
End Sub
Function GetPageCount(app As Object, appName As String, fileName As String) As Long
Const wdStatisticPages = 2
Dim someFile As Object
Select Case LCase$(appName)
Case "word", "adobe"
Set someFile = app.Documents.Open(fileName)
GetPageCount = someFile.ComputeStatistics(wdStatisticPages)
someFile.Close savechanges:=False
Case "excel"
Set someFile = app.Workbooks.Open(fileName)
GetPageCount = someFile.Sheets.Count
someFile.Close savechanges:=False
Case "powerpoint"
Set someFile = app.presentations.Open(fileName, , , msoFalse)
GetPageCount = someFile.slides.Count
someFile.Close
End Select
End Function
Function GetFolder() As String
Dim dlg As FileDialog
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
dlg.InitialFileName = "C:\"
If dlg.Show = -1 Then
GetFolder = dlg.SelectedItems(1)
End If
End Function
December 4, 2021
Offline
@Velouria,
I copied your solution into my VBA editor, and was about to try it when I noticed this. Normally code in red is some type of error, am I correct?
Trusted Members
Moderators
November 1, 2018
Offline
Yes, it looks like the forum software stripped out any occurrences of a 'less than' symbol followed by a 'more than' symbol (presumably treated it as a HTML tag)
It should read:
If Len(fileName) <> 0 Then
Dim someApp As Object
Set someApp = CreateObject(startAppName & ".Application")
If LCase$(appName) <> "powerpoint" Then someApp.Visible = False
Do
ReDim Preserve arrStats(1 To 4, cnt)
arrStats(1, cnt) = appName
arrStats(2, cnt) = FileExt
arrStats(3, cnt) = fileName
arrStats(4, cnt) = GetPageCount(someApp, appName, FilePath & fileName)
cnt = cnt + 1
fileName = Dir
Loop While Len(fileName) <> 0
December 4, 2021
Offline
Velouria,
Thanks. I made the corrections. I divided up my files (so the macro test would take less time). I started with Adobe, there were 2 files. I initially saw it freeze up, and eventually give me an error. I was forced to close Excel, and then I tried again. Then I got a run-time error. Screenshots of everything is attached. Not sure why this is happening.
.
Trusted Members
Moderators
November 1, 2018
Offline
The first message is quite normal - you just need to say Yes and check the box to not ask again. (the code is not saving the files so there will be no permanent changes)
I suspect the other two messages are related to the first one, so you probablhy need to restart and try the code again.
1 Guest(s)
