Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" ( _
ByVal RootPath As String, _
ByVal InputPathName As String, _
ByVal InputPathBuffer As String) As Long
Private Const MAX_PATH = 260
Public Sub Contract_Summary_Scope_of_Work()
Dim objFSO As Object, objFolder As Object
Dim objSubfolder As Object, colSubfolders As Object
Dim strPfad As String, strDatei As String
Dim strTemp As String * MAX_PATH
Dim lngRow As Long, lngReturn As Long, ialngIndex As Long
Dim avntFiles As Variant
Dim s As String
strPfad = "L:\AL_Sales\MELsales\2011 SALES\2011 Current Projects\" & [E3] & "\01-Contract Summary & Scope of Works\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPfad)
Set colSubfolders = objFolder.Subfolders
Application.ScreenUpdating = False
With Worksheets("01-ContractSummaryScopeOfWork")
avntFiles = .Range(.Cells(1, 5), .Cells( _
.Rows.Count, 5).End(xlUp)).Value2
If IsArray(avntFiles) Then
For ialngIndex = UBound(avntFiles) To 10 Step -1
lngReturn = SearchTreeForFile(strPfad, _
avntFiles(ialngIndex, 1), strTemp)
If lngReturn = 0 Then .Rows(ialngIndex).delete
Next
End If
lngRow = 9
strDatei = Dir$("L:\AL_Sales\MELsales\2011 SALES\2011 Current Projects\" & [E3] & "\01-Contract Summary & Scope of Works\*.*")
Do Until strDatei = ""
lngRow = lngRow + 1
If .Cells(lngRow, 5).Value <> strDatei Then
.Rows(lngRow).Insert
.Cells(lngRow, 5).Value = strDatei
.Cells(lngRow, 7).Value = objFolder.Name
.Cells(lngRow, 5).Hyperlinks.Add Worksheets("01-ContractSummaryScopeOfWork").Cells(lngRow, 5), strPfad + strDatei, "Klicken, um zu öffnen."
.Cells(lngRow, 7).Hyperlinks.Add Worksheets("01-ContractSummaryScopeOfWork").Cells(lngRow, 7), strPfad, "Klicken, um zu öffnen."
End If
strDatei = Dir$
Loop
For Each objSubfolder In colSubfolders
strDatei = Dir$("L:\AL_Sales\MELsales\2011 SALES\2011 Current Projects\" & [E3] & "\01-Contract Summary & Scope of Works\" & objSubfolder.Name & "\*.*")
Do Until strDatei = ""
lngRow = lngRow + 1
If .Cells(lngRow, 5).Value <> strDatei Then
.Rows(lngRow).Insert
.Cells(lngRow, 5).Value = strDatei
.Cells(lngRow, 7).Value = objSubfolder.Name
.Cells(lngRow, 5).Hyperlinks.Add Worksheets("01-ContractSummaryScopeOfWork").Cells(lngRow, 5), objSubfolder.Path + "\" + strDatei, "Klicken, um zu öffnen."
.Cells(lngRow, 7).Hyperlinks.Add Worksheets("01-ContractSummaryScopeOfWork").Cells(lngRow, 7), objSubfolder.Path, "Klicken, um zu öffnen."
End If
strDatei = Dir$
Loop
Next
End With
Dim n As Integer
For n = 1 To lngRow
If Worksheets("01-ContractSummaryScopeOfWork").Range("E" & n + 9) <> "" Then
Worksheets("01-ContractSummaryScopeOfWork").Range("A" & n + 9) = n
End If
Next n
Set objFolder = Nothing
Set colSubfolders = Nothing
Set objFSO = Nothing
Application.ScreenUpdating = True
End Sub