Kopieren von Bildern

[Gockel67]

Moin Gemeinde,

im Forum www.ms-office-forum.net bekam ich Hilfe um Bilddateien zu sichern. Bevor ich aber die letzte Antowrt einsehen konnte war das Forum leider zu.

Es geht um folgendes:

Ich möchte aus einer Access-Anwendung Bilder von einem Ort zu einem anderen kopieren. Dabei werden nur die Bilder kopiert die im Zielverzeichnis noch nicht vorhanden sind. Das funktioniert auch super. Jetzt soll die Routine noch um Unterverzeichnise erweiter werden. Und da scheitern leider meine Kenntnisse.

Könnte mir hier einer weiterhelfen?

Um folgenden Code geht es:

Code [Auswählen] Erweitern

Sub CopyFiles()
  Dim fso As Object           ' Scripting.FileSystemObject
  Dim fls As Object           ' Scripting.Files
  Dim fil As Object           ' Scripting.File
 
  pfadquelle = CurrentProject.path & "\Bilder\"
  pfadziel = Ziel & "Bilder\"
 
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set fls = fso.GetFolder(pfadquelle).Files   ' < anpassen
 
  Dim f As Folder
  Set f = fso.GetFolder(pfadquelle)
 
  On Error GoTo err_handler
 
  For Each fil In fls
  Counter = Counter + 1
    ProgressBar.Width = PBB / (f.Files.Count) * Counter
    lblProzent.Caption = Round(100 / (f.Files.Count) * Counter, 0) & " %"

Select Case fso.GetExtensionName(fil.Name)
      Case "jpg", "jpeg", "png", "bmp", "tif"
      fil.Copy pfadziel, False         ' < anpassen
 Case Else
        ' Nothing todo
    End Select

  Next
 
err_exit:
  ' Cleanup
  Set fil = Nothing
  Set fls = Nothing
  Set fso = Nothing
  Exit Sub

err_handler:
  If Err.Number = 58 Then           ' Datei existiert bereits!
    ' Nothing todo
    Resume Next
  Else
    Debug.Print "Error:"; Err.Number, Err.Description
  End If
 
  Resume err_exit
 
End Sub

Wünsche allen ein schönes Wochenende
Jörg

[Hondo]

Hallo,
versuch mal folgendes:

Code [Auswählen] Erweitern

Sub CopyFiles()
  Dim fso As Object
  Set fso = CreateObject("Scripting.FileSystemObject")
  fso.movefolder pfadquelle, pfadziel
  ...


[Gockel67]

Danke. Werde ich mir morgen mal anschauen.
P.S. Habe gerade nach MoveFolder geschaut. Die Bilder sollen nur kopiert aber nicht verschoben werden.

[Debus]

Hey, habe Dir mal eine kleine Demo angehangen.

Du kannst das Quellverzeichnis wählen und das Zielverzeichnis. Die Unterverzeichnisse werden mit kopiert und angelegt. Vorhandene Datei werden übergangen und im Zielverzeichnis wird noch ein Logfile angelegt.
Vielleicht ist es ja sowas wie Du suchst.

Holger

[knobbi38]

Hallo Jörg,

hier zwei Module, die dir bei deiner Aufgabe hilfreich sein könnten. Aufrufsyntax und eine kleine Hilfe im Modul.

Im Prinzip erstellst du eine Liste der zu kopierenden Dateien und arbeitest dies dann einfach ab. Mit FileExists() prüfst du, ob die Datei vorhanden ist und reagierst entsprechend darauf.

[Debus]

Hallo Ulli,

ich habe das ja so in der Demo gemacht.

Hier mal der Code aus dem Modul

Code [Auswählen] Erweitern

Option Compare Database
Option Explicit

Sub CopyImageFiles()
    Dim fDialog As Object
    Dim sourceFolder As String
    Dim targetFolder As String
    Dim logFilePath As String
    Dim logFile As Integer
    Dim fileSystem As Object

   
    Set fDialog = CreateObject("Shell.Application").BrowseForFolder(0, "Wähle das Quellverzeichnis aus:", 0)

    If Not fDialog Is Nothing Then
        sourceFolder = fDialog.Items().Item().Path

       
        Set fDialog = CreateObject("Shell.Application").BrowseForFolder(0, "Wähle das Zielverzeichnis aus:", 0)

        If Not fDialog Is Nothing Then
            targetFolder = fDialog.Items().Item().Path

           
            logFilePath = targetFolder & "\Logfile.txt"
            logFile = FreeFile

           
            Set fileSystem = CreateObject("Scripting.FileSystemObject")

           
            Open logFilePath For Output As #logFile

           
            Call CopyFiles(fileSystem, sourceFolder, targetFolder, logFile)

           
            Close #logFile

            MsgBox "Kopieren abgeschlossen! Logfile wurde erstellt: " & logFilePath

        Else
            MsgBox "Zielverzeichnis wurde nicht ausgewählt."
        End If

    Else
        MsgBox "Quellverzeichnis wurde nicht ausgewählt."
    End If

End Sub

Sub CopyFiles(fileSystem As Object, sourceFolder As String, targetFolder As String, logFile As Integer)
    Dim folderObj As Object
    Dim fileObj As Object
    Dim subfolderObj As Object
    Dim newTargetFolder As String

   
    Set folderObj = fileSystem.GetFolder(sourceFolder)

   
    If Not fileSystem.FolderExists(targetFolder) Then
        fileSystem.CreateFolder targetFolder
    End If

   
    For Each fileObj In folderObj.Files

        '''''''''''' Hier die Dateitypen festlegen ''''''''''''''''''
       
        If LCase(fileSystem.GetExtensionName(fileObj.Name)) Like "*bmp" Or _
           LCase(fileSystem.GetExtensionName(fileObj.Name)) Like "*jpg" Or _
           LCase(fileSystem.GetExtensionName(fileObj.Name)) Like "*jpeg" Or _
           LCase(fileSystem.GetExtensionName(fileObj.Name)) Like "*png" Or _
           LCase(fileSystem.GetExtensionName(fileObj.Name)) Like "*gif" Then

            On Error Resume Next

           
            newTargetFolder = targetFolder & Mid(fileObj.Path, Len(sourceFolder) + 1)

           
            If Not fileSystem.FolderExists(fileSystem.GetParentFolderName(newTargetFolder)) Then
                fileSystem.CreateFolder fileSystem.GetParentFolderName(newTargetFolder)
            End If

           
            If Not fileSystem.FileExists(newTargetFolder) Then
               
                fileSystem.CopyFile fileObj.Path, newTargetFolder

                Print #logFile, "Kopiert: " & fileObj.Path & " nach " & newTargetFolder

            Else
                Print #logFile, "Übergangen: " & newTargetFolder & " (bereits vorhanden)"
            End If

            On Error GoTo 0

        End If

    Next fileObj

   
    For Each subfolderObj In folderObj.SubFolders

        Call CopyFiles(fileSystem, subfolderObj.Path, targetFolder & Mid(subfolderObj.Path, Len(sourceFolder) + 1), logFile)

    Next subfolderObj

End Sub


Gruß
Holger

[knobbi38]

Hallo Holger,

natürlich kann man das so machen und individuell eine rekursive Routine zu schreiben.

Mit der Modulfunktion geht es auch darum, auf einen fertige, getestete und optimierte Funktion zurückzugreifen. Warum das Rad immer wieder neu erfinden? So werden z.B. die gesuchten Dateimuster und ob Unterordner durchsucht werden sollen als Argumente übergeben und man braucht sich um nichts mehr kümmern.

Für die Ordnerabfrage würde ich allerdings einfach auf das Filedialog-Objekt zurückgreifen, anstatt die Shell-Automaton zu bemühen, aber das ist Geschmackssache. Genauso ist es mit dem Logfile. Wenn schon das FSO bemüht wird, kann man das dafür auch gleich mit verwenden.

Kleine Anmerkung am Rande:
Wenn hierbei verschachtelte Unterordner angelegt werden müssen,  könnte man dafür die API Funktion "SHCreateDirectoryEx" verwenden.


 

[Debus]

Hallo Ulli,

Du hast natürlich recht, aber ich habe das schonmal so für andere Dateitypen machen müssen mit dem LogFile daher kam das einfach mal so.

Gruß und ein schönes Wochenende
Holger

[knobbi38]

@Debus

Ja sicher, wenn man so etwas schon in der Schublade hat, warum nicht?
Die Details sind sicherlich für den einen oder anderen sehr Hilfreich, z.B. BrowseForFolder für die Office-Anwendungen, wo es keinen Filedialog gibt.
Auf diese Weise kann man sich auch mal schnell den Aufbau einer rekursiven Funktion oder das Anlegen von verschachtelten Ordern anschauen, um etwas zu lernen.

Grüße
Ulrich

[Gockel67]

Danke an Holger und Ulrich. Ihr seid meine Helden. Das File von Holger war genau das was ich gesucht habe. Jetzt kann ich meine zwei Datenbanken endlich um eine Datensicherung erweitern.
Wünsche allen einen schönen und geruhsamen Sonntag.

[Debus]

Auf Wunsch von Gockel nochmal angepasst:

Holger

[Gockel67]

Hallo Holger,
einen ganz dicken Dank an dich und deine Arbeit. Jetzt funktioniert alles so wie es soll.
Werde dich lobend in mein Nachtgebet mit einschliessen 

[Debus]

Auf Wunsch ohne ocx von MS welches man ja nicht wirklich anpassen kann also Farbe etc.

Hier habe ich es mit zwei Rechtecken gemacht, wo man ja das Design anpassen kann.

Holger

Frage @ alle kann man bei den privaten Messages auch Dateianlangen versenden?  Habe ich nicht gefunden

[knobbi38]

Frage @ alle kann man bei den privaten Messages auch Dateianlangen versenden?  Habe ich nicht gefunden

Nein, meines Wissens ist das nicht vorgesehen.

[Köbi]

Hallo Holger
Vielen Dank für deine DB zum Kopieren von Dateien von einem Verzeichnis zum andern.
Dazu habe ich noch folgende Fragen und Anmerkungen.

Diese Codezeile

Code [Auswählen] Erweitern

Me.ProgressBar.Value = 0 in der Sub CopyImageFiles() verursacht beim Debuggen einen Fehler. Kann meiner Meinung nach weggelassen werden. Dann funktioniert die Progressbar trotzdem.

2.   Frage: Weshalb zeigt die Progressbar nach einer längeren Kopiererein höchstens 99% an, und nie 100%?
3.   Logfile. In der früheren Version wurde ein Logfile erstellt. Das ist jetzt auch noch so, aber die Datei «logfile.txt» bleibt leer. Dafür wird der Ablauf im Formular angezeigt. Das ist nett, aber nach dem Schliessen des Formulars ist der Verlauf weg. Ich meine, das logfile sollte weiterhin als Datei vorhanden sein. Als Beleg dafür, wer und wann jemand Dateien kopiert hat.