VBA - Automatisches Entpacken von Zipordnern

Hallo,

ich exportiere mit VBA Anhänge aus Outlook. Gleichzeitig Entpacke ich die enthaltenen Zip-Archive.

Allerdings will ich verhindern, dass Doppelte Dateien einfach Überschrieben werden (könnte ja sein, dass man mit zwei mal eine info.txt schickt).
=> Also soll beim Entpacken die "doppelt" vorhandene Datei einfach umbenannt werden in info(2).txt <- wobei mir das Schema egal ist (wegen mir werden auch alle Dateien mit einer UNIQUE-ID umbenannt).

gefunden habe ich folgendes Script (welches ich für meinen Bedarf minimalst angepasst habe)

Function UnzipFile(ByVal zipFile As String, ByVal theFolder As String)
    Dim objApp As Object
    Dim objArchive As Object
    Dim objDest As Object
    
    Set objApp = CreateObject("Shell.Application")  
    
    If Dir$(theFolder, vbDirectory) = "" Then MkDir theFolder  

    objApp.NameSpace(theFolder).CopyHere objApp.NameSpace(zipFile).Items, FOF_NOCONFIRMATION + FOF_RENAMEONCOLLISION
    
    UnzipFile = True

End Function

ich habe bereits mit FOF_RENAMEONCOLLISION experimentiert (habe ich gleich mal im Code gelassen), allerdings sehe ich nicht den erhofften effekt.

Hat jemand eine Idee für mich? Vielen Dank

grüße

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

Content-ID: 338989

Url: https://administrator.de/forum/vba-automatisches-entpacken-von-zipordnern-338989.html

Ausgedruckt am: 23.12.2024 um 00:12 Uhr

6 Kommentare

Neuester Kommentar

Servus.

FOF_RENAMEONCOLLISION

Hast du die Konstanten überhaupt definiert? Vermutlich nicht, zumindest ist in deinem Code oben keine Defintion vorhanden.
Ersetze das FOF_NOCONFIRMATION + FOF_RENAMEONCOLLISION durch 24. Das setzt sich zusammen aus
16 = Respond with "Yes to All" for any dialog box that is displayed.
und

8 = Give the file being operated on a new name in a move, copy, or rename operation if a file with the target name already exists.

Siehe dazu bitte auch die Referenz im zweiten Parameter vOptions :
Folder.CopyHere method

Grüße Uwe

hm... danke, war mal wieder n FAIL Ich dachte FOF_RENAMEONCOLLISION ist sozusagen schon die Definition... <- aber LOGISCH

aber hier steht, ich habe jetzt die Möglichkeit die Datei umzubenennen... doch wie mache ich das.
Weil jetzt macht er einfach nichts im Falle wenn die Datei bereits existiert :/

=> jetzt muss ich ja irgendwie sagen ... DANN benenne die Datei 12!

Gruß

Zitat von @it4baer:
aber hier steht, ich habe jetzt die Möglichkeit die Datei umzubenennen... doch wie mache ich das.

?? Wo steht was, wie?

Weil jetzt macht er einfach nichts im Falle wenn die Datei bereits existiert :/

Funktioniert hier testweise einwandfrei, existiert eine Datei mit dem selben Namen benennt er die neue mit (x) am Ende um.
Aber die Namespace Funktion war noch nie sehr zuverlässig. Nimm 7zip oder mach das Extrahieren mit Powershell. Funktion dazu findest du in meinen Posts hier im Forum.

Ich würde aber anstatt alles in ein Verzeichnnis zu entpacken lieber einen neuen Ordner mit einer einheitlichen ID (Random/oder anhand der UID der Mail / etc) erstellen. Oder vorher in einen temporären Ordner entpacken und dann per Test mit FileExist und Move und einer while-Schleife die Files verschieben.

jo, die 16 drückt bei mir einfach auf ja und nicht auf umbenennen und beide behalten

naja... ich hätte gerne eine eine VBA-Funktion welche "möglichst unkompliziert" mir alle Daten aus einem bestimmten Ordner entpackt...

=> in den Ordner sind so oder so nur gleiche Typen, welche Später dann weiterverarbeitet werden.
d.h. ich BRAUCH die im gleichen Ordner

Cool wäre natürlich schon, wenn man z.B. den Absender mit in den Dateinamen packen kann

also z.B. in der anhang.zip liegen info.txt und bild.jpg
Entpackt werden

absender@test.de_info.txt
absender@test.de_bild.jpg

vielen dank für jede hilfe

Zitat von @it4baer:
naja... ich hätte gerne eine eine VBA-Funktion welche "möglichst unkompliziert" mir alle Daten aus einem bestimmten Ordner entpackt...

=> in den Ordner sind so oder so nur gleiche Typen, welche Später dann weiterverarbeitet werden.
d.h. ich BRAUCH die im gleichen Ordner

Cool wäre natürlich schon, wenn man z.B. den Absender mit in den Dateinamen packen kann

also z.B. in der anhang.zip liegen info.txt und bild.jpg
Entpackt werden

absender@test.de_info.txt
absender@test.de_bild.jpg

vielen dank für jede hilfe

Das habe ich hier alles schon x mal gepostet

Outlook VBA - Anhang autom. speichern
Ohne Outlook und Co Anhänge aus vielen gespeicherten Mails .eml rauskopieren
usw.

Bitte mal die Suchfunktion bemühen.

Bei Bedarf kannst du mich gerne für dein Projekt ordern
=> PM

Hier ein einfaches Beispiel:

' Erstelle Objekte  
Set fso = CreateObject("Scripting.FileSystemObject")  
Set objShell = CreateObject("Wscript.Shell")  
Set objShellApp = CreateObject("Shell.Application")  

'extrahiere ZIP File  
Sub ExtractZip (zipFile, sFolder)
    zipFile = fso.GetAbsolutePathName(zipFile)
    sFolder = fso.GetAbsolutePathName(sFolder)

    With objShellApp
        .NameSpace(sFolder).CopyHere .NameSpace(zipFile).Items, 16
        Do Until .NameSpace(sFolder).Items.Count = .NameSpace(zipFile).Items.Count
            WScript.Sleep 200
        Loop
    End With
End Sub

' Temporärer Ordner zum entpacken  
TMP = objShell.ExpandEnvironmentStrings("%TEMP%") & "\temp_extract"  
'Zielordner für Dateien  
TARGET = "A:\temp_target"  

'Wenn Entpackordner existiert lösche ihn  
If fso.FolderExists(TMP) Then fso.DeleteFolder TMP,True
'und erstelle ihn dann neu  
fso.CreateFolder TMP

'extrahiere die Zip-Datei ins Temporäre Verzeichnis  
ExtractZip "D:\Daten\demo.zip",TMP  
'Kopiere den Inhalt in den Zielordner unter Berücksichtigung von doppelten Dateinamen  
CopyContents TMP, TARGET

'Sub welches den Inhalt eines Zip rekursiv durchläuft,den Zielordner auf doppelte Dateien prüft und entsprechend umbenennt  
Sub CopyContents(strFolder,strTarget)
	'Erstelle Ordner wenn er nicht existiert  
	If Not fso.FolderExists(strTarget) Then fso.CreateFolder strTarget
	'Für jede Datei im Ordner  
	For Each file In fso.GetFolder(strFolder).Files
		'setze Zieldateinamen  
		strTargetPath = strTarget & "\" & file.Name  
		cnt = 1
		'erstelle den Zielnamen so lange neu (mit angehängter Nummer) bis ein Dateinamen frei ist  
		While fso.FileExists(strTargetPath)
			strTargetPath = strTarget & "\" & fso.GetBaseName(file.Name) & "(" & cnt & ")." & fso.GetExtensionName(file.Name)  
			cnt = cnt + 1
		Wend
		'Verschiebe Datei mit neuem Namen  
		file.Move strTargetPath
	Next
	'Verarbeite Unterordner rekursiv  
	For Each subfolder In fso.GetFolder(strFolder).SubFolders
		CopyContents subfolder.Path, strTarget & "\" & subfolder.Name  
	Next
End Sub