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
rngResult
As
Excel.Range
Dim
f()
As
String
Dim
strPath
As
String
Dim
strFileN
As
String
Dim
strFileID
As
String
Dim
n
As
Long
Dim
i
As
Long
Set
wks = ThisWorkbook.Worksheets(1)
strPath = AddBackslash(ThisWorkbook.Path)
n = GetJPGs(strPath, f)
Debug.Print vbNewLine & Now &
" >>>"
For
i = 1
To
n
strFileID = GetID(f(i))
Set
rngResult = wks.Columns(
"A"
).Find(strFileID)
If
Not
rngResult
Is
Nothing
Then
strFileN = Trim$(wks.Columns(
"B"
).Rows(rngResult.Row).Text)
If
Not
Dir(strPath & strFileN) <>
""
Then
On
Error
Resume
Next
Name strPath & f(i)
As
strPath & strFileN
If
Err.Number = 0
Then
Debug.Print
" # "
& f(i) &
" >> "
& strFileN
Else
Debug.Print
" ! "
& f(i) &
" | ID "
& strFileID &
" konnte NICHT umbenannt werden (Fehler "
& Err.Number &
"; "
& Err.Description &
")"
End
If
On
Error
GoTo
0
Else
Debug.Print
" ? "
& f(i) &
" >> "
& strFileN &
" | wurde nicht ausgeführt (Zieldatei existiert bereits)"
End
If
Else
Debug.Print
" ? "
& f(i) &
" | ID "
& strFileID &
" konnte NICHT in Liste gefunden werden"
End
If
Next
Debug.Print
"<<<"
End
Sub
Private
Function
GetID(File
As
String
)
As
String
Dim
i
As
Long
For
i = 1
To
Len(File)
If
IsNumeric(Mid$(File, i, 1))
Then
GetID = GetID & Mid$(File, i, 1)
Else
Exit
For
End
If
Next
End
Function
Private
Function
GetJPGs(Path
As
String
, File()
As
String
)
As
Long
Dim
f()
As
String
Dim
strFile$
Dim
n&
strFile = Dir(Path &
"*.jpg"
)
While
strFile <>
""
n = n + 1
ReDim
Preserve
f(1
To
n)
f(n) = strFile
strFile = Dir()
Wend
File = f
GetJPGs = n
Erase
f
End
Function
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