### Verzeichnis prüfen ###

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Sabine,
ich bin mir etwas unsicher wegen deines Nachsatzes. Kann es denn vorkommen, dass in dem Verzeichnis dann doch ateien über mehrere Tage drin bleiben? Dann werden sie nämlich mit der momentanen Version des Programms mehrfach gelistet.
Option Explicit Dim bolStop As Boolean Dim intDateianzahl As Integer Dim strDateien() As String Dim datStopzeit As Date Const strTabelle As String = "Tabelle1" Public Sub start() Dim varEingabe As Variant Do varEingabe = InputBox("Bitte die Uhrzeit eingeben, an der das Programm beendet werden soll.", "Uhrzeiteingabe", Time + TimeSerial(8, 0, 0)) If varEingabe = False Then Exit Sub If IsDate(varEingabe) And InStr(1, varEingabe, ":") <> 0 Then Exit Do MsgBox "Keine gültige Uhrzeit.", 48, "Hinweis" Loop datStopzeit = CDate(varEingabe) Protokoll End Sub Public Sub Protokoll() Dim bolgefunden As Boolean Dim intIndex1 As Integer, intIndex2 As Integer, intZeile As Integer Dim myFile As Object, myFileSystemObject As Object Set myFileSystemObject = CreateObject("Scripting.FileSystemObject") If Worksheets(strTabelle).Cells(1, 1) <> "" Then intZeile = Worksheets(strTabelle).Cells(65536, 1).End(xlUp).Row With Application.FileSearch .LookIn = "E:\Daten\IMP" .FileType = msoFileTypeAllFiles If .Execute > intDateianzahl Then intDateianzahl = .FoundFiles.Count ReDim Preserve strDateien(1 To intDateianzahl) For intIndex1 = 1 To .FoundFiles.Count bolgefunden = False For intIndex2 = 1 To UBound(strDateien) If strDateien(intIndex2) = .FoundFiles(intIndex1) Then bolgefunden = True: Exit For If strDateien(intIndex2) = "" Then strDateien(intIndex2) = .FoundFiles(intIndex1) intZeile = intZeile + 1 Set myFile = myFileSystemObject.GetFile(.FoundFiles(intIndex1)) Worksheets(strTabelle).Hyperlinks.Add Anchor:=Cells(intZeile, 1), Address:=.FoundFiles(intIndex1), ScreenTip:=myFile.Name, TextToDisplay:=myFile.Name Worksheets(strTabelle).Cells(intZeile, 2) = Now Worksheets(strTabelle).Columns.AutoFit Exit For End If Next Next End If End With Set myFile = Nothing Set myFileSystemObject = Nothing If Time < datStopzeit Then Application.OnTime (Time + TimeSerial(0, 0, 5)), "Protokoll" Else Absenden End Sub Public Sub beenden() datStopzeit = Time bolStop = True End Sub Public Sub Absenden() If bolStop Then If MsgBox("Protokolldatei versenden?", 36, "Abfrage") = 7 Then Exit Sub Worksheets(strTabelle).Copy ActiveSheet.Shapes.SelectAll Selection.Delete ActiveWorkbook.SendMail "DeinEmpfaenger@keineAhnung.de", "Protokolldatei von " & Date ActiveWorkbook.Close SaveChanges:=False ThisWorkbook.Close SaveChanges:=True End Sub
Du musst noch den Tabellennamen und den Emailempfänger anpassen.
Gruß
Nepumuk

Hallo Sabine
Ja, Nepumuk hat schon Recht. Es sind wirklich noch ein paar Fragen offen.
Trotzdem hab ich mal versucht, eine Lösung zu erstellen.
Aber...weil...Fragen offen ;-)...
Vorausetzung:
1. Alle Dateien müssen im selben Ordner sein
2. Ich habe Outlook als Mailprogramm verwendet
3. Die Einträge befinden sich in Spalte A ab Zelle A1
So, vielleicht hilft Dir ja mein Vorschlag, wenn Du es Deinen Bedürfnissen angepasst hast. Handelt sich um VBA. Ohne VBA ist so etwas wohl nicht möglich.
Hier der Code:

Sub FileSuche()
    Dim Zeile As Integer, Mailtext As String
    Dim Datei As String
    Dim ol, mail As Object

    'Bildschirmaktualisierung wird deaktiviert
    Application.ScreenUpdating = False

    Zeile = 1

    'in Spalte A wird die erste leere Zeile ermittelt; davon ausgegangen, dass keine leerenZeilen zwischen den Einträgen bestehen
        Do Until Range("A" & Zeile).Value = ""
            Zeile = Zeile + 1
        Loop

    'hier wird der Bereich gelöscht mit den schon vorhandenen Einträgen (Dateinamen); beginnend von A1 bis vorher ermittelte leere Zelle
    Range("A1:A" & Zeile).Value = ""

    'hier wird im Verzeichnis C:\ nach allen ZIP-Dateien gesucht; musst Du anpassen
    Datei = Dir("C:\*.zip")

    Zeile = 1

    'es wird, beginnend in A1 jeder Dateiname der gefundenen ZIP-Dateien eingetragen
        Do Until Datei = ""
            Range("A" & Zeile).Value = Datei

            'hier wird die Liste für die Mail generiert
            Mailtext = Mailtext & Range("A" & Zeile).Value & vbCrLf

            Datei = Dir
            Zeile = Zeile + 1
        Loop

    'hier wird
    Set ol = CreateObject("Outlook.Application")
    Set mail = ol.CreateItem(0)

    'die Betreffzeile
    mail.Subject = "test"

    'erster Empfänger
    mail.To = "DeinEmpfaenger@keineAhnung.de"

    'wenn gewünscht, weitere Empfänger
    mail.cc = "DeinEmpfaenger@keineAhnung.de;DeinEmpfaenger@keineAhnung.de"

    'wenn gewünscht, die Empfänger in mail.bcc sind nicht sichtbar für die anderen Empfänger
    mail.bcc = "DeinEmpfaenger@keineAhnung.de"

    'mail.body ist der Bereich, in dem Du normalerweise Deinen Text schreibst. Hier wird die Dateiliste eingefügt
    mail.body = Mailtext

    'diese Zeile kannst Du löschen, wenn alles funktioniert. mail.display zeigt die erstellte Mail nur an, und versendet sie nicht
    mail.display

    'diese Zeile solltest Du erst aktivieren (das Hochkomma löschen), wenn alles funktioniert. mail.send verschickt JEDE auch noch fehlerhafte mail an die eingetragenen Empfänger :-)
    'mail.send

    'hier wird genau das eben durchgeführte Makro in 5 Minuten wiederholt
    Application.OnTime Now + TimeValue("00:05:00"), "filesuche"

    'Bildschirmaktualisierung wird aktiviert
    Application.ScreenUpdating = True
End Sub

Du musst diesen Code komplett in ein allgemeines Modul im VBA-Editor (Alt + F11) einfügen.
Danach kannst Du es in Excel über Extras/Makro/Makros auswählen.
Viel Erfolg :-)
Hoffe, dass ich helfen konnte.
Ciao
Thorsten

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

### Verzeichnis prüfen ###

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread