Dateien zu Ordner hinzufügen

Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _ ByVal DirPath As String) As Long Sub makeDir() Dim strPath As String, strInitialPath As String Dim res As Long, intI As Integer Dim varSF() As Variant strInitialPath = "F:\Temp" 'Stammverzeichnis - anpassen! strPath = ActiveCell If Trim(strPath) = "" Then Exit Sub varSF = Array("Finanzen", "AVOR", "Korrespondenz", "Diverses") 'Unterordner If Right(strPath, 1) "\" Then strPath = strPath & "\" If Right(strInitialPath, 1) "\" Then strInitialPath = strInitialPath & "\" res = MakeSureDirectoryPathExists(strInitialPath & strPath) If res 0 Then For intI = 0 To UBound(varSF) MakeSureDirectoryPathExists (strInitialPath & strPath & varSF(intI) & "\") Next Else MsgBox "Verzeichnis konnte nicht erstellt werden!", vbInformation, "Fehler" End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Benedikt,
schau mal ob du damit zurecht kommst.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Long

Sub makeDir()
Dim strPath As String, strInitialPath As String
Dim res As Long, intI As Integer, intC As Integer
Dim varSF() As Variant
'!!!
Dim varFiles(2, 1) As Variant 'erste Dimension an die Anzahl der zu kopierenden Dateien-1 anpassen!

strInitialPath = "F:\Temp" 'Stammverzeichnis - anpassen!

strPath = ActiveCell

If Trim(strPath) = "" Then Exit Sub

varSF = Array("Finanzen", "AVOR", "Korrespondenz", "Diverses") 'Unterordner

'!!!
'Dateien angeben
varFiles(0, 0) = "Finanzen" 'Ordner in den die Datei kopiert werden soll
varFiles(0, 1) = "C:\Dokumente\Ordner.doc" 'Kompletter Pfad und Dateiname der Datei

varFiles(1, 0) = "Finanzen"
varFiles(1, 1) = "C:\Dokumente\irgentwas.txt"

varFiles(2, 0) = "AVOR"
varFiles(2, 1) = "C:\Vorlagen\einanderesfile.txt"

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

If Right(strInitialPath, 1) <> "\" Then strInitialPath = strInitialPath & "\"

res = MakeSureDirectoryPathExists(strInitialPath & strPath)

If res <> 0 Then
    For intI = 0 To UBound(varSF)
        MakeSureDirectoryPathExists (strInitialPath & strPath & varSF(intI) & "\")
        'Dateien kopieren
        On Error Resume Next
        For intC = 0 To UBound(varFiles, 1)
            If varFiles(intC, 0) = varSF(intI) Then
                FileCopy varFiles(intC, 1), strInitialPath & strPath & varSF(intI) & "\" & Datei_aus_Pfad(varFiles(intC, 1))
            End If
        Next
        On Error GoTo 0
    Next
Else
    MsgBox "Verzeichnis konnte nicht erstellt werden!", vbInformation, "Fehler"
End If

End Sub

Private Function Datei_aus_Pfad(ByVal strFile As String) As String
' ab xl 2000
Datei_aus_Pfad = Right(strFile, InStr(1, StrReverse(strFile), "\") - 1)
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread