Folder summary of workbooks - solved

ROBINSYN · Sep 7, 2002

Is there anyway to summarize the filenames in a folder even after new additions. Can this be done with excel or do I need a program?

Thanks for the incite> WORKS LIKE A CHARM
This message was edited by ROBINSYN on 2002-09-07 13:07

XL-Dennis · Sep 7, 2002

ROBINSYN,

What do You mean with summarize?

- List all filenames in a folder in worksheet

Kind regards,
Dennis

Ivan F Moala · Sep 7, 2002

Hi
If you mean File details in a sheets of certain Dir then this may help you.

<PRE>'---------------------------------------------------------------------------------------

' Module : Mod_DirInfo

' DateTime : 8/01/01 18:06

' Author : Ivan F Moala

' Purpose : Lists xls File info

' Inputs : Directory

' Outputs : Full path name of file,size Kb of file,Date time of File

'---------------------------------------------------------------------------------------

Option Explicit

Option Base 1

Dim KbSum As Double

Const Dmsg = "Select the Directory to get xls File info from"

'// Code for generating list of files in a directory...

'// 32-bit API declarations

Declare Function SHGetPathFromIDList Lib "shell32.dll" _

Alias "SHGetPathFromIDListA" ( _

ByVal pidl As Long, _

ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _

Alias "SHBrowseForFolderA" ( _

lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO

hOwner As Long

pidlRoot As Long

pszDisplayName As String

lpszTitle As String

ulFlags As Long

lpfn As Long

lParam As Long

iImage As Long

End Type

Function GetDirectory(Optional Msg As String) As String

Dim bInfo As BROWSEINFO

Dim path As String

Dim r As Long, x As Long, pos As Integer

'// Root folder = Desktop

bInfo.pidlRoot = 0&

'// Title in the dialog

If IsMissing(Msg) Then

bInfo.lpszTitle = "Select a folder."

Else

bInfo.lpszTitle = Msg

End If

'// Type of directory to return

bInfo.ulFlags = &H1

'// Display the dialog

x = SHBrowseForFolder(bInfo)

'// Parse the result

path = Space$(512)

r = SHGetPathFromIDList(ByVal x, ByVal path)

If r Then

pos = InStr(path, Chr$(0))

GetDirectory = Left(path, pos - 1)

Else

GetDirectory = ""

End If

End Function

Function GetFileList(FileSpec As String) As Variant

'// Returns an array of filenames that match FileSpec

'// If no matching files are found, it returns False

Dim FileSearch

Dim FileArray() As Variant

Dim i As Double

Dim Exists

On Error GoTo ErrSearch

Set FileSearch = Application.FileSearch

If Right(FileSpec, 1) <> "" Then FileSpec = FileSpec & ""

Exists = Dir(FileSpec)

If Exists = "" Then GoTo ErrSearch

'// Reset KbSum

KbSum = 0

With FileSearch

.NewSearch

.LookIn = FileSpec

.FileName = "*.xls"

If .Execute > 0 Then

ReDim FileArray(.FoundFiles.Count, 3)

For i = 1 To .FoundFiles.Count

FileArray(i, 1) = .FoundFiles(i)

KbSum = KbSum + FileLen(.FoundFiles(i)) 1024

FileArray(i, 2) = FileLen(.FoundFiles(i)) 1024 & " Kb"

FileArray(i, 3) = Format(FileDateTime(.FoundFiles(i)), "dd/mm/yy hh:mm:ss")

Next

Else

GetFileList = False

Exit Function

End If

End With

GetFileList = FileArray

Set FileSearch = Nothing

Exit Function

'// Error handler

ErrSearch:

If Exists = "" Then On Error Resume Next: Err.Raise 76

MsgBox Err.Number & " : " & Err.Description, vbMsgBoxHelpButton, _

"Error Search", Err.HelpFile, Err.HelpContext

End

End Function

Sub ListToSheet_FileInfo()

Dim Dir_ToLookIn As String, x As Variant, i As Double

Dir_ToLookIn = GetDirectory(Dmsg)

If Dir_ToLookIn = "" Then Exit Sub

x = GetFileList(Dir_ToLookIn)

Select Case IsArray(x)

Case True '// Files found


ActiveSheet.Range("A:C").Clear

[A1] = UBound(x) & " Files in Dir:= " & Dir_ToLookIn

[B1] = KbSum & " Kb"

[C1] = "File Date"

With Range("A1:C1")

.HorizontalAlignment = xlCenter

.Font.Bold = True

.Font.ColorIndex = 5

End With

With ActiveSheet

.Range("A2").Resize(UBound(x), 3) = x

.Range("A:C").Columns.AutoFit

End With

MsgBox "Done!....", vbInformation

Case False '// No files found

MsgBox "No matching files", vbCritical

End Select

x = ""

End Sub
</PRE>

XL-Dennis · Sep 7, 2002

Ivan,

Thanks for a nice piece of code although I´m still prefer the "FSO"-approach (i e less lines of code) but I realize more and more the power of API.

Kind regards,
Dennis

Mudface · Sep 7, 2002

FSO, pah!

.

XL-Dennis · Sep 7, 2002

Mudface,

Hehe, the only reason You´ve got is that You don´t has any sample of the FSO-approach

Here it come and don´t forget to set a reference to the Microsoft Scripting Runtime via the Tools | Reference.

<PRE>

Sub List_Files()

Dim fsoObj As Scripting.FileSystemObject

Dim fsoMapp As Scripting.Folder

Dim fsoFil As Scripting.File

Dim i As Long

Set fsoObj = New Scripting.FileSystemObject

Set fsoMapp = fsoObj.GetFolder("e:Arbetsmaterial")

With Range("A1:H1")

.Value = Array("Filename", "Created", "Last changed", "Size", "Type", _

"Drive", "Folder", "Path")

.Font.Bold = True

End With

i = 0

If Not fsoMapp Is Nothing Then

For Each fsoFil In fsoMapp.Files

If fsoFil Like "*.xls" Then

i = i + 1

With fsoFil

Cells(1 + i, 1).Value = .Name

Cells(1 + i, 2).Value = .DateCreated

Cells(1 + i, 3).Value = .DateLastModified

Cells(1 + i, 4).Value = .Size

Cells(1 + i, 5).Value = .Type

Cells(1 + i, 6).Value = .Drive

Cells(1 + i, 7).Value = .ParentFolder

Cells(1 + i,

.Value = .Path

End With

End If

Next

End If

Columns("A:H").EntireColumn.AutoFit

Set fsoFil = Nothing

Set fsoMapp = Nothing

Set fsoObj = Nothing

End Sub

</PRE>

Kind regards,
Dennis

Mudface · Sep 7, 2002

Dennis, I was just messing

. Remember yesterday's post, where the guy couldn't set a reference to the scripting library?

Ivan F Moala · Sep 7, 2002

On 2002-09-07 12:51, XL-Dennis wrote:
Ivan,

Thanks for a nice piece of code although I´m still prefer the "FSO"-approach (i e less lines of code) but I realize more and more the power of API.

Kind regards,
Dennis

Hi Dennis
Yes I agree...this was just one of many approaches....for instance the whole API approach can be taken out with this...

<pre/>
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please Select Image Folder", 0, GetDrive)

If Not objFolder Is Nothing Then
'// Is it the Root Dir?...if so change
If Len(objFolder.Items.Item.Path) > 3 Then
strPictFullPath = objFolder.Items.Item.Path & Application.PathSeparator
Else
strPictFullPath = objFolder.Items.Item.Path
End If
</pre>

and many other ways.....I just had the above handy (written) last year.
Note: FSO for searching is slower then native VBA Filesearch....

XL-Dennis · Sep 7, 2002

Mudface,

Yes, I know You was joking so did I :wink:

Ivan,
Yes, I agree that the native VBA Filesearch is the preferable approach

However, I´m always amazed over the fact that You seems to have "an ace up Your sleeve" :wink:

Have a nice weekend,
Dennis

Ivan F Moala · Sep 7, 2002

On 2002-09-07 13:37, XL-Dennis wrote:
Mudface,

Yes, I know You was joking so did I :wink:

Ivan,
Yes, I agree that the native VBA Filesearch is the preferable approach

However, I´m always amazed over the fact that You seems to have "an ace up Your sleeve" :wink:

Have a nice weekend,
Dennis

Dennis my friend

Have a GREAT Weekend....

BTW....I have taken a copy of your routine

_________________
Kind Regards, Ivan F Moala From the City of Sails

This message was edited by Ivan F Moala on 2002-09-07 14:01

Folder summary of workbooks - solved

ROBINSYN

Board Regular

Excel Facts

XL-Dennis

Well-known Member

Ivan F Moala

MrExcel MVP

XL-Dennis

Well-known Member

Mudface

MrExcel MVP

XL-Dennis

Well-known Member

Mudface

MrExcel MVP

Ivan F Moala

MrExcel MVP

XL-Dennis

Well-known Member

Ivan F Moala

MrExcel MVP

Similar threads

Forum statistics

Share this page

Folder summary of workbooks - solved

Board Regular

Excel Facts

Well-known Member

MrExcel MVP

Well-known Member

MrExcel MVP

Well-known Member

MrExcel MVP

MrExcel MVP

Well-known Member

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock