ich habe ein vba makro um Dateinamen und Ordnernamen auszulesen, welches funktioniert wenn ich Dateien/Ordner einfuege bzw loesche ( Dank euch Office Forum ), jedoch ist mir heute ein kleiner Fehler aufgefallen.
Wenn ich eine Datei von Ordner A in B verschiebe spinnt das programm und zeigt die ordner dann nicht mehr richtig an.
Ausgangszustand
1.doc in ordner test1
2.doc in ordner test2
3.doc in ordner test3
Wird auch so in meiner excel tabelle angezeigt.
Nun verschiebe ich 3.doc in ordner test1 und fuehre das makro erneut aus.
Folgendes resultat
1.doc in ordner test 1
3.doc in ordner test 1
2.doc in ordner test 2
3.doc in ordner test 3
Dieser Problem tritt nur auf wenn ich ordner verschiebe.
Hier mein Code
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 Incoming_Correspondence()
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
strPfad = "L:\AL_Sales\MELsales\2011 SALES\2011 Current Projects\" & [E3] & "\02-Incomming _
_
Correspondence\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPfad)
Set colSubfolders = objFolder.Subfolders
Application.ScreenUpdating = False
With Worksheets("02-Incoming Correspondence")
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] & "\02- _
Incomming Correspondence\*.*")
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("02-Incoming Correspondence").Cells( _
lngRow, 5), strPfad + strDatei, "Klicken, um zu öffnen."
.Cells(lngRow, 7).Hyperlinks.Add Worksheets("02-Incoming Correspondence").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] & "\ _
_
02-Incomming Correspondence\" & 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("02-Incoming Correspondence"). _
_
Cells(lngRow, 5), objSubfolder.Path + "\" + strDatei, "Klicken, um zu öffnen."
.Cells(lngRow, 7).Hyperlinks.Add Worksheets("02-Incoming Correspondence").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("02-Incoming Correspondence").Range("E" & n + 9) "" Then
Worksheets("02-Incoming Correspondence").Range("A" & n + 9) = n
End If
Next n
Range("A" & n + 9) = ""
Set objFolder = Nothing
Set colSubfolders = Nothing
Set objFSO = Nothing
Application.ScreenUpdating = True
End Sub
Ueber jegliche hilfe und tipps waere ich ueberaus dankbar.
grus