Dateien umbenennen

Hallo Excelgemeinde,
ich habe vor einiger Zeit schon mal eine ähnliche Frage ins Forum gestellt, aber leider auf diesen Beitrag keine Antwort bekommen.
Ich versuche seitdem die Lösung selbst zu finden, aber ich scheitere daran. :o(
Hier mein Problem:
Ich habe folgenden code (ein Auszug) aus diesem Forum etwas auf meine Bedürfnisse abgeändert:


Sub Test()
'### START Bilder Auslesen
On Error Resume Next
'### Test Bilder umwandeln
For Each S In .Documents(1).InlineShapes
If S.Type = msoLine Then S.Delete
'If S.Type = msoPicture Then
S.ConvertToShapes
'End If
Next S
If .Documents(1).Shapes.Count > 0 Then
For lngPic = 1 To .Documents(1).Shapes.Count
'Bilder zurüchsetzen auf Originalabmessungen
With .Documents(1).Shapes(lngPic)
.LockAspectRatio = msoFalse
.Reset
.ScaleHeight 1, True
.ScaleWidth 1, True
End With
Next
'Worddatei als HTM speichern
.Documents(1).SaveAs FileName:=strTmpFile, FileFormat:=10, _
LockComments:=False, Password:="", AddToRecentFiles:=False, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
strPic = Dir(Environ("Temp") & "\dummy-Dateien\*.*")
lngCnt = 0
Do While strPic  ""
Zeichen = IIf(InStr(objFiles(lngIndex).Name, "b") > 0, "b", ".")
Name Environ("Temp") & "\dummy-Dateien\" & strPic As strPicPath & _
Replace(Replace(Replace(Replace(Left(objFiles(lngIndex).Name, InStrRev(objFiles( _
lngIndex).Name, Zeichen) + 1) _
, " ", ""), ".b", "b"), "b", "-ZF") & _
IIf(lngCnt > 0, "[" & lngCnt + 1 & "]", "") & Mid(strPic, InStrRev(strPic, "." _
)), "..", ".")
Sleep 500
Kill strPic
strPic = Dir
lngCnt = lngCnt + 1
Loop
End If
.Documents(1).Close saveChanges:=False
Kill strTmpFile
Err.Clear
On Error GoTo ErrExit
'### ENDE Bilder Auslesen
End Sub

Es werden nacheinander Worddocumente geöffnet und als htm gespeichert.
Die enstandenen Bilder werden nun beannant in in einen Ordner kopiert. Ein b wird durch -ZF ersetzt usw.
Wenn die Worddateien so aussehen:
KO-1.1.1.b.doc oder KO-1.1.1.doc
funzt das perfekt auch überflüssige Punkte und Leerzeichen werden gelöscht.
In diesem Beispiel sehen die Bilddateien dann so aus:
KO-1.1.1-ZF.jpg und KO-1.1.1.jpg
Im Falle, dass die Datei so aussieht:
KO-1.1.1b irgendwas.doc habe ich durch:
Zeichen = IIf(InStr(objFiles(lngIndex).Name, "b") > 0, "b", ".")
folgendes Ergebnis:
KO-1.1.1-ZF.jpg
Soweit funzt das auch wirklich prima, aber....
Es sollte so auch bei folgendem Beispielen funktionieren:
KO-1.1.1 2 Test.doc oder KO-1.1.1 test.doc
In diesen Fällen sollten die Bilddateien so aussehen:
KO-1.1.1.jpg
Leider ist das Ergebnis bisher folgendes:
KO-1.1.12Test.jpg und KO-1.1.1test.doc
Ich hoffe ich habe mich nicht zu umständlich ausgedrückt?
Ich hoffe auf eure Hilfe!!!!!!!
Gruß
Dirk R.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub kleiner Ausschnitt() Zeichen = IIf(InStr(objFiles(lngIndex).Name, "b") > 0, "b", ".") Name Environ("Temp") & "\dummy-Dateien\" & strPic As strPicPath & _ Replace(Replace(Replace(Replace(Left(objFiles(lngIndex).Name, InStrRev(objFiles( _ _ lngIndex).Name, Zeichen) + 1) _ , " ", ""), ".b", "b"), "b", "-ZF") & _ IIf(lngCnt > 0, "[" & lngCnt + 1 & "]", "") & Mid(strPic, InStrRev(strPic, "." _ _ )), "..", ".") End Sub

Option Explicit Sub ExtractName() Dim strN As String 'Bsp-String zum Testen strN = "KO-1.1.....1 2 Test.doc" strN = CStr(Split(strN)(0)) 'linker Teil bis erster Blank Do While InStr(strN, "..") strN = Replace(strN, "..", ".") 'mehrfach Punkte löschen Loop If Right(strN, 4) = ".doc" Then strN = Left(strN, Len(strN) - 4) '".doc" abschneiden End If If Right(strN, 2) = ".b" Then strN = Left(strN, Len(strN) - 2) & "-ZF" '".b" durch "-ZF" ersetzen ElseIf Right(strN, 1) = "b" Then strN = Left(strN, Len(strN) - 1) & "-ZF" '"b" durch "-ZF" ersetzen End If strN = strN & ".jpg" 'neue Datei-Endung MsgBox strN End Sub

Option Explicit Sub ExtractName() Dim strName As String, i As Integer Dim oRegex As Object, oMatch As Object, oItems As Object 'Bsp-String zum Testen strName = "KO -- 1...2. . ..3.. b irgendwas.doc" strName = Replace(strName, " ", "") Set oRegex = CreateObject("vbscript.regexp") oRegex.Pattern = "(\d+)+\.+(\d+)+\.+(\d+)+\.*(b)?" 'regular expression Set oMatch = oRegex.Execute(strName) Set oItems = oMatch(0) strName = "KO-" Select Case oItems.Submatches.Count Case 3, 4 For i = 0 To 2 strName = strName & oItems.Submatches(i) & "." Next strName = Left(strName, Len(strName) - 1) End Select If oItems.Submatches.Count = 4 Then If Len(oItems.Submatches(3)) Then strName = strName & "-ZF" End If strName = strName & ".jpg" MsgBox strName End Sub

Option Explicit Sub TestName() Dim strName As String, strResult As String Dim intBlocks As Integer intBlocks = 6 'maximale Anzahl Zahlenblöcke, ggf. erhöhen 'Bsp-String zum Testen strName = "AB -- 1.... 23 .1. 67 ..45b irgendwas.doc" strResult = ExtractName(strName, intBlocks) MsgBox strName & vbLf & vbLf & strResult End Sub Function ExtractName(strSrc As String, intBlc As Integer) Dim strRes$, strPtrn$ Dim i%, j%, blnFnd As Boolean Dim oRegex As Object, oMatch As Object strPtrn = "^([A-Z]{2}).*?-[^0-9]*?(\d+)" Set oRegex = CreateObject("vbscript.regexp") For j = 2 To intBlc strPtrn = strPtrn & "\.+(\d+)" Next For j = intBlc To 2 Step -1 oRegex.Pattern = strPtrn & "\.*(b)?[^0-9]" If Not blnFnd Then For Each oMatch In oRegex.Execute(Replace(strSrc, " ", "")) strRes = oMatch.SubMatches(0) & "-" For i = 1 To j strRes = strRes & oMatch.SubMatches(i) & "." Next strRes = Left(strRes, Len(strRes) - 1) If Len(oMatch.SubMatches(j + 1)) Then strRes = strRes & "-ZF" strRes = strRes & ".jpg" blnFnd = True Next End If If blnFnd Then Exit For strPtrn = Left(strPtrn, Len(strPtrn) - 8) Next ExtractName = strRes End Function

Sub ExtractName() Dim strName As String, i As Integer Dim oRegex As Object, oMatch As Object, oItems As Object 'Bsp-String zum Testen strName = "ZW -- 1..1.2. . ..3. b.irgendwas.doc" strName = Replace(strName, " ", "") Set oRegex = CreateObject("vbscript.regexp") oRegex.Pattern = "(\d+)\.+(\d+)\.*(\d+)?\.*(\d+)?\.*(b)?" 'regular expression Set oMatch = oRegex.Execute(strName) Set oItems = oMatch(0) strName = Left(strName, 2) & "-" 'z.B.: "KO-" Select Case oItems.Submatches.Count Case 4, 5 For i = 0 To 3 If oItems.Submatches(i) "" Then strName = strName & oItems.Submatches(i) & "." Next End Select strName = Left(strName, Len(strName) - 1) If oItems.Submatches.Count = 5 Then If Len(oItems.Submatches(4)) Then strName = strName & "-ZF" End If strName = strName & ".jpg" MsgBox strName End Sub

Hallo Christian,
ich habe deinen Code nun in meinen vorhandenen eingebaut und getestet. Zuerst gab es Probleme mit einigen Dateien. Es hat dann auch einige Zeit gedauert, bis ich dahinter kam, warum der Code bei einigen Dateien nicht funktioniert hat.
Einige Worddateien hatten am Anfang:
Dz-1.1.1b irgendwas.doc
Mit dem Kleinbuchstaben z hatte der Code ein Problem. Also habe ich erstmal den String mit
strName = UCase(strName) in Großbuchstaben umgewandelt und habe dann in der Funktion
oRegex.Pattern = strPtrn & "\.*(b)?[^0-9]" aus dem kleinen b ein großes B gemacht:
oRegex.Pattern = strPtrn & "\.*(B)?[^0-9]"
Nun läuft der Code spitzenmäßig!!!!!! :o)
Deinen Code in der Funktion verstehe ich zwar noch nicht so ganz, aber irgendwann werde ich schon dahinter kommen.
Vielen, vielen Dank für deine Mühe und deine Geduld. Du hast mir sehr weitergeholfen.
Jetzt kann ich mit meiner Datei endlich loslegen und aus 1000en Worddateien Bilder exportieren und diese auch so zu benennen, wie ich es brauche.
Gruß
Dirk

Sub AusschnittAusModul Do While strPic "" 'String Filtern Dim strN As String strN = Left(objFiles(lngIndex).Name, InStrRev(objFiles(lngIndex).Name, ".") + 1) strN = Replace(Replace(Replace(strN, "- ", "-"), " b", "b "), " -", "-") strN = CStr(Split(strN)(0)) 'linker Teil bis erster Blank If Right(strN, 4) = ".doc" Then strN = Left(strN, Len(strN) - 4) '".doc" abschneiden End If If Right(strN, 2) = ".b" Then strN = Left(strN, Len(strN) - 2) & "-ZF" '".b" durch "-ZF" ersetzen ElseIf Right(strN, 1) = "b" Then strN = Left(strN, Len(strN) - 1) & "-ZF" '"b" durch "-ZF" ersetzen End If Do While InStr(strN, "..") strN = Replace(strN, "..", ".") 'mehrfach Punkte löschen Loop Name Environ("Temp") & "\dummy-Dateien\" & strPic As strPicPath & strN & _ IIf(lngCnt > 0, "[" & lngCnt + 1 & "]", "") & Mid(strPic, InStrRev(strPic, "." _ )) Sleep 500 Kill strPic strPic = Dir lngCnt = lngCnt + 1 Loop End Sub

Beliebteste Forumthreads (12 Monate)

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread