Skipping the Browse For Folder

[Evil]

Hi All,

In the following code (all of which works -- it lists files in a folder with extended properties)...


Option Explicit
Dim ShName As String
Dim objFolder As Object
Dim sFullPath As String
Dim blnCreateLink As Boolean
Dim blnStatus As Boolean
Dim objShell As Object

Function ShellFolderName() As String
Set objShell = CreateObject("Shell.Application")
'// SYNTAX = Shell.BrowseForFolder (Hwnd, sTitle, iOptions [, vRootFolder])
Set objFolder = objShell.BrowseForFolder(0, "Please select a folder", 0, 0)
If (Not objFolder Is Nothing) Then
'// NB: If SpecFolder= 0 = Desktop then ....
On Error Resume Next
If IsError(objFolder.items.Item.Path) Then ShellFolderName = objFolder: GoTo Here
On Error GoTo 0
ShellFolderName = objFolder.items.Item.Path
sFullPath = objFolder.items.Item.Path
Else
MsgBox "File details ABORTED": End
End If
Here:
ShName = CStr(objFolder)
End Function

Sub GetFolderFileDetails()
Dim strDir As String
Dim objFSO As Object
Dim strFileName As Object
Dim arrHeaders(27)
Dim X As Double, i As Integer, Y As Integer
Dim oldSb As Boolean
oldSb = Application.DisplayStatusBar
Application.DisplayStatusBar = True
'blnCreateLink = Range("CreateLink")
'blnStatus = Range("DStatus")
strDir = ShellFolderName
Set objFSO = CreateObject("Scripting.FileSystemObject")
If strDir = "Desktop" Then
Set objFolder = objShell.Namespace(0)
Else
Set objFolder = objShell.Namespace("" & strDir & "")
End If
'// Add New details sheet
AddSheet ShName
Application.DisplayStatusBar = True
'// Initialise variable counter
'// We will only get 15 Items
Y = 0
For i = 0 To 27
arrHeaders(i) = objFolder.GetDetailsOf(objFolder.items, i)
Cells(2, Y + 1) = arrHeaders(i)
Y = Y + 1
Next
'// Initialise variable counters
X = 0: Y = 0
Application.ScreenUpdating = Not (blnStatus)
For Each strFileName In objFolder.items
For i = 0 To 27
If blnStatus Then Application.StatusBar = objFolder & ":" & strFileName & ":" & _
objFolder.GetDetailsOf(strFileName, i)
If blnCreateLink Then Cells(X + 3, 1).Hyperlinks.Add Anchor:=Cells(X + 3, 1), _
Address:=sFullPath & "\" & strFileName
If objFolder.GetDetailsOf(strFileName, 1) = "File Folder" Or _
objFolder.GetDetailsOf(strFileName, 2) = "File Folder" Then
Range(Cells(X + 3, 1), Cells(X + 3, 15)).Font.ColorIndex = 3
End If
Cells(X + 3, i + 1) = objFolder.GetDetailsOf(strFileName, i)
Next
X = X + 1
Next
'// Format
Frmt
'// Inform User
MsgBox "Completed....... " & objFolder.items.Count & " Files", vbInformation + vbSystemModal
'// Clean-up
Set objShell = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
With Application
.ScreenUpdating = True
.StatusBar = False
.DisplayStatusBar = oldSb
End With
End Sub

Sub Frmt()
'// Format the sheet
Dim Rg As Range
With Range("A1")
.Value = objFolder.items.Count & " Items in " & sFullPath 'objFolder
.HorizontalAlignment = xlCenter
End With
Set Rg = Range(Range("A2"), Range("A2").End(xlToRight))
With Rg
.Borders.LineStyle = xlDouble
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.FontStyle = "Bold"
.Font.Size = 8
.Font.ColorIndex = 5
End With
'Range("B1").FormulaR1C1 = " RED = Directory"
Columns("A:AA").Columns.AutoFit
Set Rg = Nothing
End Sub

Sub AddSheet(Nm As String)
'// Adds New Sheet
On Error Resume Next
Sheets.Add(after:=ActiveSheet).Name() = Nm
If Err Then Err.Clear
Range("B3").Select
ActiveWindow.FreezePanes = True
'// Place in New Book?
If Range("NewBook") Then ActiveSheet.Move
End Sub


...I try to skip invoking the Browse For Folder dialog and to pass the path that should be read from a label on my User Form directly on to GetFolderFileDetails.

Can you please show me how to do that? I tried with strDir = lblFolder.Caption & "\" but that did not work.

Thanx!

[GTO]

Try this. If it does not work, please show us how the caption of the label control is set.

Up towards the top of GetFolderFileDetails() you need to set a reference to Shell if skipping ShellFolderName.


'strDir = ShellFolderName
strDir = "C:\Documents and Settings\stumpm\Desktop\TODAY\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")


Hope that helps,

Mark

[Evil]

Yes, it helped. Thank you, Mark.

So another Set objShell = CreateObject("Shell.Application") did it.

A very few examples of working code for this around, and even this one is not completely OK. Say, it doesn't return the file size alright. But that I shall solve using something else.

Cheers.

[mdmackillop]

Please use the green VBA button rather than Code tags to format your code.