|
Hey Leute,
ich soll ein Vba Programm erstellen das Dateinamen ausliest, diese in eine excel Tabelle schreibt, mit Verlinkung. Zu dieser Datenreihe die sagen wir in Spalte B steht, sollen nun werte in die selbe reihe manuel hinzugefuegt werden. Das funktioniert alles Gut solange datein in den ordnern hinzugefuegt oder geloescht werden, jedoch habe ich folgende probleme:
-Das Verschieben von Dateien:
dadurch zerhaut es mir die ganze Datenbank
-Das Umbenennen von Dateien:
-Dateiname wird umgeschrieben jedoch werden die haendisch eingetragenen werte geloescht.
Hier mein CODE:
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
Fuer jede hilfe bin ich unendlich dankbar, ich komme einfach nicht weiter.
Gruss chris
|