Einkürzen aller Dateien in einem Verzeichnis auf länge X

Hallo,
ich möchte gerne in einem Verzeichnis X alle Dateien mit der Endung TXT auf eine maximale Länge von 50 Zeichen einkürzen
Wie kann ich das am besten per VBA umsetzen?

Grüße aus München

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 269084

Url: https://administrator.de/forum/einkuerzen-aller-dateien-in-einem-verzeichnis-auf-laenge-x-269084.html

Ausgedruckt am: 22.01.2025 um 16:01 Uhr

5 Kommentare

Neuester Kommentar

Hallo Thomas,
z.B. so
(ich gehe hier davon aus das du die 50 Zeichen inkl. Dateierweiterung meinst)

On Error Resume Next
Const FOLDER = "C:\Ordner"  
Set fso = CreateObject("Scripting.FileSystemObject")  
For Each file In fso.GetFolder(FOLDER).Files
	If LCase(fso.GetExtensionName(file.Name)) = "txt" And Len(file.Name) > 50 Then  
		newname = file.ParentFolder & "\" & (Left(file.Name,46) & ".txt")  
		file.Move newname
                If Err.Number > 0 Then
	            MsgBox Err.Description & vbNewLine & newname,vbCritical
	        End If
	End If
Next

Grüße Uwe

Hallo Uwe,

danke für die Information,
klappt wunderbar.
Besteht die Möglichkeit dieses Script noch zu erweitern und zwar soll er die Dateien löschen, wenn im Dateinamen gewisse Wörter vorkommen..
Sprich vor dem Prüfen auf länge, Prüfe ob Wort X in Datei vorhanden dann löschen ansonste fahre mit dem einkürzen fort.

Gruß
Thomas

Ich glaube eher es ist der Text im inneren der Datei gemeint?

Also die Textdatei im VBA einlesen und den Inhalt in eine Variable übernehmen. Dann:

Langertext = "Variable mit mehr als X Zeichen"
kurzertext = Left(test, 50)

Das Ergebnis dann zurück in die Datei schreiben.

LG,

Thomas

EDIT:
Okay - da hat thomas1972 geantwortet bevor ich auf Senden geklickt habe.
Hat sich scheinbar doch auf die Dateinamen bezogen.

Zitat von @thomas1972:
Besteht die Möglichkeit dieses Script noch zu erweitern und zwar soll er die Dateien löschen, wenn im Dateinamen gewisse
Wörter vorkommen..
Sprich vor dem Prüfen auf länge, Prüfe ob Wort X in Datei vorhanden dann löschen ansonste fahre mit dem
einkürzen fort.

Lässt sich machen...in Zeile 3 die Keywords ins Array eintragen

On Error Resume Next
Const FOLDER = "C:\ordner"  
keywords = Array("Wort1","Wort2")  
Set fso = CreateObject("Scripting.FileSystemObject")  
For Each file In fso.GetFolder(FOLDER).Files
	If LCase(fso.GetExtensionName(file.Name)) = "txt" Then  
		deleted = False
		For i = 0 To UBound(keywords)
			If InStr(1,file.Name,keywords(i),1) > 0 Then
				file.Delete
				deleted = True
				Exit For
			End If
		Next
		If Not deleted Then
			If Len(file.Name) > 50 Then
				newname = file.ParentFolder & "\" & (Left(file.Name,46) & ".txt")  
				file.Move newname
		        If Err.Number > 0 Then
			    	MsgBox Err.Description & vbNewLine & newname,vbCritical
			    End If
		    End If
		End If
	End If
Next

Ein Weitere Möglichkeit ist Regular Expressions für die Keywords zu nutzen / Zeile 6 ist der RegEx Pattern (damit hat man dann mehr Möglichkeiten der Keywordgestaltung. Bitte beachte aber das es sich um einen "Regular Expression Pattern" handelt in dem Sonderzeichen besondere Bedeutung haben!):

On Error Resume Next
Const FOLDER = "C:\ordner"  
Set fso = CreateObject("Scripting.FileSystemObject")  
Set regex = CreateObject("vbscript.regexp")  
regex.IgnoreCase = True
regex.Pattern = "Wort1|Wort2|Wort3"  

For Each file In fso.GetFolder(FOLDER).Files
	If LCase(fso.GetExtensionName(file.Name)) = "txt" Then  
		If regex.Test(file.Name) Then
			file.Delete
		Else
			If Len(file.Name) > 50 Then
				newname = file.ParentFolder & "\" & (Left(file.Name,46) & ".txt")  
				file.Move newname
		        If Err.Number > 0 Then
			    	MsgBox Err.Description & vbNewLine & newname,vbCritical
			    End If
			End If
		End If
	End If
Next