AW: PPT verschieben falls Artikel nicht in Datei
15.07.2009 17:06:34
EffHa
Hallo Lothar,
dies in ein Modul kopieren, die Pfade ändern und los gehts.
Die Dateien werden in ein Array eingelesen.
Dann wird die Tabelle mit den Artikelnummern abgegrast und wenn gefunden kopiert, dann gelöscht
Gruß
Fritz
Option Explicit
Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" ( _
ByVal lpFileName As String) As Long
Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" ( _
ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Const MAX_PATH = 260
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'
'Public Type SYSTEMTIME
' wYear As Integer
' wMonth As Integer
' wDayOfWeek As Integer
' wDay As Integer
' wHour As Integer
' wMinute As Integer
' wSecond As Integer
' wMilliseconds As Integer
'End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Sub test()
Dim I&, J&, Result&, LetzteZeile&
Dim PPtFiles() As String
Dim PfadName$, Suchmuster$
PfadName = "C:\Temp\"
Suchmuster = "*.ppt"
LetzteZeile = GetLastRow(ActiveSheet, "A") 'setzt voraus, das in Spalte "A" was steht
If SearchFilesInList(PfadName, Suchmuster, PPtFiles) Then
For I = 1 To LetzteZeile
For J = 0 To UBound(PPtFiles) - 1
If InStr(1, PPtFiles(J), Cells(I, 3)) Then '3= Spalte mit den Artikelnummern(C)
Result = CopyFile(PfadName & PPtFiles(J), "c:\neuerordner\" & Format(Date, "yyyymmdd" & PPtFiles(J)), 0)
' Die "0" in copyfile bewirkt, dass vorhandene Dateien überschrieben werden
If Result = 0 Then
MsgBox ("Fehler beim kopieren")
Else
Result = DeleteFile(PfadName & PPtFiles(I))
'Wenn Result = dann erfolgreich
End If
End If
Exit For
Next
Next
End If
End Sub
Public Function SearchFilesInList(Pathname$, Pattern$, FoundFileNames) As Boolean
Dim hFind&, hFile&, nFile& 'SDir$,
Dim FD As WIN32_FIND_DATA
ReDim FoundFileNames(0)
If Right(Pathname, 1) "\" Then Pathname = Pathname & "\"
hFile = FindFirstFile(Pathname & Pattern, FD)
If hFile > 0 Then
SearchFilesInList = True
FoundFileNames(UBound(FoundFileNames)) = ClearFileName(FD.cFileName)
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
Do
nFile = FindNextFile(hFile, FD)
If nFile > 0 Then
FoundFileNames(UBound(FoundFileNames)) = ClearFileName(FD.cFileName)
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
End If
Loop While nFile 0
Else
SearchFilesInList = False
'MsgBox ("Keine Dateien für " & fKunde & " gefunden!")
'End
End If
FindClose hFile
End Function
Function ClearFileName(CDat)
Dim X&
X = InStr(1, CDat, Chr$(0))
If X > 0 Then
ClearFileName = Trim$(Left$(CDat, X - 1))
Exit Function
End If
ClearFileName = ""
End Function
Function GetLastRow(Ws As Worksheet, Spalte$) As Long
Spalte = UCase(Spalte & "65536")
GetLastRow = Ws.Range(Spalte).End(xlUp).Row
End Function