Solved: Working Code not finding server folders
Hi all - thanks for looking at this post. I have the following code which up until yesterday was working fine.
It lists the immediate sub folders of a specified server folder without going on to list any further sub-folders (it need to be like this to keep things clean in the userform listbox). When I run the code now only new folders are displayed none of the original folders are returned. No amendments to the code have been made so I'm 100% sure it's not the code failing. I've spoken to our IT dept who say as the folders are visible in Explorer there isn't a problem with the server. I'm sure it's linked to permissions as when the IT dept refreshed the permissions on the folder the few test folders I'd created were no longer found and only new folders from that point are returned by the search.
Since the IT dept are adament there is nothing they can do my question is two fold.
1st - does anyone know what could be causing this so I can take it back to the IT dept to check. (my preferred solution)
2nd - does anyone know an alternative way of acheiving the same thing which doesn't look at attributes, which I guess is the problem because if I use Application.FileSearch to return a list of files (not folders) within a specific folder (which is not returned by the following code) it finds all of the files.
Here's the code which is part of a userform...
[VBA]Const ARRAY_INITIAL = 1000
Const ARRAY_INCREMENT = 100
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Dim arrFiles() As String
Dim myFolder As String
Dim CurrentSubFolder As String
Private Sub UserForm_Initialize()
CommandButton2_Click
End Sub
Private Sub CommandButton2_Click()
Dim X As Integer
myFolder = "P:\General Filing\My Files\"
ListBox1.Clear
ListBox1.Visible = False
Call spanFoldersStart(myFolder, "*.*")
For X = 0 To UBound(arrFiles)
If arrFiles(X) = myFolder Then GoTo NEXTX Else
ListBox1.AddItem Mid(arrFiles(X), InStr(arrFiles(X), myFolder) + Len(myFolder))
NEXTX:
Next X
ListBox1.Visible = True
ListBox4.AddItem myFolder
End Sub
Public Function spanFoldersStart(startfolder As String, srchstr As String)
Dim sFileName As String
Dim sfoldername As String
Dim idx As Integer
Dim limit As Integer
ReDim arrFiles(ARRAY_INITIAL)
On Error GoTo errHandle
idx = 0
arrFiles(0) = startfolder
limit = 1
Do While idx < limit
sfoldername = arrFiles(idx)
sFileName = Dir(sfoldername & srchstr, vbDirectory)
Do While (sFileName <> "") And (DirLevel(sfoldername) < 4)
If GetFileAttributes(sfoldername & sFileName) = _
FILE_ATTRIBUTE_DIRECTORY Then
If sFileName <> "." And sFileName <> ".." Then
arrFiles(limit) = sfoldername & sFileName & "\"
limit = limit + 1
End If
End If
sFileName = Dir
Loop
idx = idx + 1
Loop
ReDim Preserve arrFiles(limit - 1)
Exit Function
errHandle:
If Err.Number = 9 Then
ReDim Preserve arrFiles(UBound(arrFiles) + ARRAY_INCREMENT)
Resume
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If
End Function
Public Function DirLevel(fldr As String) As Long
Dim i As Long, result As Long
result = 0
For i = 1 To Len(fldr)
If Mid(fldr, i, 1) = "\" Then result = result + 1
Next
DirLevel = result
End Function
[/VBA]
If I change myFolder to C:\Windows\System32\ (I have Admin rights on my PC - this doesn't work on a laptop where I don't have admin rights - which again leads me to think it's a permissions issue?) it works fine.
I have full control in the permissions of the Server folder so on the face of it everything looks OK, but it's not working :think:
Any help would be great! : pray2:
Cheers,
rrenis
