Clever-Excel-Forum

Moin zusammen,

ich habe ein Skript geschrieben, mit dem ich automatisch ein ZIP-Ordner erstelle und diesen per email verschicke. Das ganze funktioniert auch so ganz gut, außer dass mir Outlook sagt, dass die Anlage angeblich geöffnet sei. Das Fenster muss ich dann bestätigen, sodass er die email dann verschickt. Nun nervt dieses natürlich in der Automatik ein bisschen und würde das ganze gerne irgendwie beseitigen.

Den ZIP-Ordner erstelle ich mit folgendem Code:

Code:
Sub ZipFolder(folderToZipPath As Variant, zippedFileFullName As Variant)

Dim ShellApp As Object

'Create an empty zip file

Open zippedFileFullName For Output As #1

Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)

Close #1

'Copy the files & folders into the zip file

Set ShellApp = CreateObject("Shell.Application")

ShellApp.Namespace(zippedFileFullName).CopyHere ShellApp.Namespace(folderToZipPath).items

'Zipping the files may take a while, create loop to pause the macro until zipping has finished.

On Error Resume Next

Do Until ShellApp.Namespace(zippedFileFullName).items.Count = ShellApp.Namespace(folderToZipPath).items.Count

    Application.Wait (Now + TimeValue("0:00:01"))

Loop

On Error GoTo 0

End Sub

Muss ich den ZIP Ordner danach noch irgendwie manuell schließen? Kann mir da irgendjemand weiterhelfen? :)

Mach Ich u.a. so:

Code:
Option Explicit

Const m_zipExtension As String = "ZIP"

'Ur-Quelle: https://codekabinett.com/rdumps.php?Lang=2&targetDoc=create-zip-archive-vba-shell32

'geringfügig angepasst

Public Sub AddToZip(ByVal zipArchivePath As String, ByVal addPath As String)

    Dim sh        As New Shell32.Shell

    Dim fSource    As Shell32.Folder

    Dim fTarget    As Shell32.Folder

    Dim iSource    As Shell32.FolderItem

    Dim sourceItem As Shell32.FolderItem

    Dim i          As Shell32.FolderItem

    '

    Set fTarget = sh.Namespace((zipArchivePath))

    If fTarget Is Nothing Then

        createZipFile zipArchivePath

        Set fTarget = sh.Namespace((zipArchivePath))

    End If

    '

    Set fSource = sh.Namespace((addPath))

    With fSource

        For Each i In .Items

            If Not UCase(Right(i, 3)) = m_zipExtension Then 'ZIP

                fTarget.CopyHere i

                Application.Wait Now() + TimeSerial(0, 0, 3)

            End If

        Next i

    End With

    '

End Sub

Public Sub createZipFile(ByVal fileName As String)

    Dim fileNo            As Integer

    Dim ZIPFileEOCD(22)    As Byte

    'Signature of the EOCD:  &H06054b50

    ZIPFileEOCD(0) = Val("&H50")

    ZIPFileEOCD(1) = Val("&H4b")

    ZIPFileEOCD(2) = Val("&H05")

    ZIPFileEOCD(3) = Val("&H06")

    fileNo = FreeFile

    Open fileName For Binary Access Write As #fileNo

    Put #fileNo, , ZIPFileEOCD

    Close #fileNo

End Sub

Hallo,

da ich so etwas noch nie gemacht habe, kann ich dir nicht sagen, wie das funktioniert. Aber da man mit "Application.DisplayAlerts = False" ansonsten nervige Nachfragen unterdrücken kann, wäre es einen Versuch wert, denke ich jedenfalls.

Servus

ezay

Mase

herbert grom