Option
Explicit
Private
Declare
Function
PathAddBackslash
Lib
"shlwapi.dll"
_
Alias
"PathAddBackslashA"
( _
ByVal
pszPath
As
String
)
As
Long
Sub
Ausprobieren()
Dim
wks
As
Excel.Worksheet
Dim
rngFileIDs
As
Excel.Range
Dim
rngFileID
As
Excel.Range
Dim
oFiles
As
VBA.Collection
Dim
strPath
As
String
Dim
strFile
As
String
Dim
strFileN
As
String
Dim
strFileID
As
String
Dim
strFileIDN
As
String
Dim
i&, k&, n&, nt&
Set
wks = ThisWorkbook.Worksheets(1)
strPath = AddBackslash(ThisWorkbook.Path)
Debug.Print vbNewLine &
"["
& Now &
"]{'"
& strPath &
"'} >>>"
On
Error
Resume
Next
Set
rngFileIDs = wks.Columns(
"A"
).SpecialCells(xlCellTypeConstants)
On
Error
GoTo
0
If
Not
rngFileIDs
Is
Nothing
Then
Set
rngFileIDs = rngFileIDs.Cells
Else
Debug.Print
" # keine ID-Liste vorhanden"
Debug.Print
"<<<"
Call
MsgBox(
"Keine ID-Liste vorhanden."
, vbInformation)
Exit
Sub
End
If
Call
GetFiles(strPath, oFiles,
"*.bmp;*.jpg"
)
nt = oFiles.Count
For
Each
rngFileID
In
rngFileIDs
If
oFiles.Count = 0
Then
Exit
For
strFileID = Trim$(rngFileID.Text)
strFileIDN = Trim$(rngFileID.Offset(, 1).Text)
If
strFileIDN =
""
Then
Debug.Print
" ? "
& strFile &
" (ID: "
& strFileID &
") | neue FileID in Liste nicht angegeben)"
Else
k = 0
For
i = oFiles.Count
To
1
Step
-1
strFile = Trim$(oFiles(i))
If
FileCheck(strFile, strFileID)
Then
If
k > 0
Then
strFileN = FilenameNew(strFile, strFileIDN &
"_"
& k)
Else
strFileN = FilenameNew(strFile, strFileIDN)
End
If
On
Error
Resume
Next
Name strPath & strFile
As
strPath & strFileN
If
Err.Number = 0
Then
n = n + 1
Debug.Print
" # DATEI '"
& strFile &
"' >> '"
& strFileN &
"'"
Else
Debug.Print
" ! DATEI '"
& strFile &
"' (ID '"
& strFileID &
"' | konnte NICHT umbenannt werden (Fehler "
& Err.Number &
"; "
& Err.Description &
")"
End
If
On
Error
GoTo
0
k = k + 1
oFiles.Remove i
End
If
Next
If
k = 0
Then
Debug.Print
" # ID '"
& strFileID &
"' | es wurde keine passende Datei gefunden"
End
If
End
If
Next
For
i = 1
To
oFiles.Count
Debug.Print
" # DATEI '"
& oFiles(i) &
"' | blieb unangetastet"
Next
Debug.Print
"<<<"
Call
MsgBox(
"Datei-Anzahl: "
& nt & vbNewLine & _
"davon umbenannt: "
& n, _
vbInformation)
End
Sub
Private
Function
FileCheck(
ByVal
Filename
As
String
,
ByVal
FileID
As
String
)
As
Boolean
Dim
n$
Call
FileInfo(Filename, n, vbNullString)
FileCheck = (StrComp(Left$(n, Len(FileID)), FileID, vbTextCompare) = 0)
End
Function
Private
Function
FilenameNew(
ByVal
OldFilename
As
String
,
ByVal
NewFilename
As
String
,
Optional
KeepExtension
As
Boolean
=
True
)
As
String
OldFilename = Trim$(OldFilename)
NewFilename = Trim$(NewFilename)
Dim
strN$, strE1$, strE2$
Call
FileInfo(OldFilename, vbNullString, strE1)
Call
FileInfo(NewFilename, strN, strE2)
If
KeepExtension
Then
FilenameNew = strN &
"."
& strE1
Else
FilenameNew = strN &
"."
& strE2
End
If
End
Function
Private
Sub
FileInfo(
ByVal
Filename
As
String
,
ByRef
Name
As
String
,
ByRef
Extension
As
String
)
Filename = Trim$(Filename)
Dim
i
As
Long
i = InStrRev(Filename,
"."
)
If
CBool
(i)
Then
Name = Left$(Filename, i - 1)
Extension = Right$(Filename, Len(Filename) - i)
Else
Name = Filename
Extension =
""
End
If
End
Sub
Private
Sub
GetFiles(
ByVal
Path
As
String
, File
As
VBA.Collection, Filter
As
String
,
Optional
Separator
As
String
=
";"
)
Dim
clc
As
New
VBA.Collection
Dim
vnt
As
Variant
Dim
strFile$, strExt$
Dim
n&, i&
Path = AddBackslash(Path)
vnt = Split(Filter, Separator)
strFile = Dir(Path &
"*.*"
)
While
strFile <>
""
For
i = LBound(vnt)
To
UBound(vnt)
If
strFile
Like
vnt(i)
Then
clc.Add strFile
Exit
For
End
If
Next
strFile = Dir()
Wend
Set
File = clc
Erase
vnt
End
Sub
Private
Function
AddBackslash(
ByVal
Path
As
String
)
As
String
Dim
sBuf
As
String
sBuf = Path +
String
(100, 0)
Call
PathAddBackslash(sBuf)
AddBackslash = RemNulls(sBuf)
End
Function
Private
Function
RemNulls(
ByVal
sStr
As
String
)
As
String
Dim
lPos
As
Long
lPos = InStr(1, sStr, vbNullChar)
If
lPos > 0
Then
RemNulls = Left(sStr, lPos - 1)
Else
RemNulls = sStr
End
If
End
Function