Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1104to1108
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

per Code Unterverzeichnis anlegen

per Code Unterverzeichnis anlegen
Volker
Hallo liebe Excelgemeinde,
ich habe eine Code, mit den eien Sicherheitskopie erstellt wird. Im Code habe ich eine feste Speicheradresse hinterlegt. Wenn aber auf dem Rechner die Verzeichnisse und Unterverzeichnisse nicht vorhanden sind, wird mir ja eine Fehler angezeigt, bzw. die Kopie nicht gespeichert. Nach vielen Selbstversuchen, kann mir einer von Euch den Code-Block schreiben, das wenn das hinterlegt Verzeichnis nicht vorhanden ist, eine Inputbox nach der Speicheradresse fragt, und dann ggf. die Verzeichnisse anlegt?
AW: per Code Unterverzeichnis anlegen
23.09.2009 12:15:44
Tino
Hallo,
so müsste es eigendlich funktionieren.
kommt als Code in Modul1
Option Explicit 
 
Private Declare Function apiCreateFullPath _
Lib "imagehlp.dll" Alias "MakeSureDirectoryPathExists" (ByVal lpPath As String) As Long 
 
Sub Beispiel() 
Dim strFile As String 
Dim lngPath As Long, strPath As String 
Dim strPathNeu As String 
 
strFile = "Test.xls" 'Dateiname 
strPath = "V:\Dokumente\Berichtswesen\Monatsreporting\02 Februar\" 'Normaler Pfad 
 
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" 
lngPath = apiCreateFullPath(strPath) 
 
 
 
  
    If lngPath = 1 Then 'Ordner vorhanden oder konnte angelegt werden 
        ThisWorkbook.SaveAs strPath & strFile 
     
    Else 'Ordner nicht vorhanden oder konnte nicht angelegt werden 
          
        strPathNeu = fncGetFolder("Wählen Sie einen Ordner zur Installation aus") 
        If Right$(strPathNeu, 1) <> "\" Then strPathNeu = strPathNeu & "\" 
         
        strPathNeu = strPathNeu & Right$(strPath, Len(strPath) - 3) 
        lngPath = apiCreateFullPath(strPathNeu) 
 
        If lngPath = 1 Then 
         ThisWorkbook.SaveAs strPathNeu & strFile 
        Else 
         MsgBox "Ordner konnte nicht angelegt oder gefunden werden", vbCritical 
        End If 
      
     End If 
 
End Sub 
 
kommt als Code in Modul2
Option Explicit 
 
Private Declare Function MoveWindow Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long 
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long 
Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByRef lpRect As RECT) As Long 
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
    lpbi As InfoT) As Long 
Private Declare Function CoTaskMemFree Lib "ole32" ( _
    ByVal hMem As Long) As Long 
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
    ByVal lpStr1 As String, _
    ByVal lpStr2 As String) As Long 
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
    ByVal pList As Long, _
    ByVal lpBuffer As String) As Long 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassname As String, _
    ByVal lpWindowName As String) As Long 
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    wParam As Any, _
    lParam As Any) As Long 
Private Type InfoT 
    hwnd As Long 
    Root As Long 
    DisplayName As Long 
    Title As Long 
    Flags As Long 
    FName As Long 
    lParam As Long 
    Image As Long 
End Type 
 
Private Type RECT 
    Left As Long 
    Top As Long 
    Right As Long 
    Bottom As Long 
End Type 
 
Public Enum BIF_Flag 
    BIF_RETURNONLYFSDIRS = &H1 
    BIF_DONTGOBELOWDOMAIN = &H2 
    BIF_STATUSTEXT = &H4 
    BIF_RETURNFSANCESTORS = &H8 
    BIF_EDITBOX = &H10 
    BIF_VALIDATE = &H20 
    BIF_NEWDIALOGSTYLE = &H40 
    BIF_BROWSEINCLUDEURLS = &H80 
    BIF_BROWSEFORCOMPUTER = &H1000 
    BIF_BROWSEFORPRINTER = &H2000 
    BIF_BROWSEINCLUDEFILES = &H4000 
    BIF_SHAREABLE = &H8000 
End Enum 
 
Private Const SM_CXFULLSCREEN = &H10 
Private Const SM_CYFULLSCREEN = &H11 
 
Private Const BFFM_SETSELECTION = &H466 
Private Const BFFM_INITIALIZED = &H1 
 
Private s_BrowseInitDir As String 
Private Function BrowseCallback( _
        ByVal hwnd As Long, _
        ByVal uMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long 
    If uMsg = BFFM_INITIALIZED Then 
        Call SendMessage(hwnd, BFFM_SETSELECTION, ByVal 1&, ByVal s_BrowseInitDir) 
        Call CenterDialog(hwnd) 
    End If 
    BrowseCallback = 0 
End Function 
 
Private Function FuncCallback(ByVal nParam As Long) As Long 
    FuncCallback = nParam 
End Function 
 
Private Sub CenterDialog(ByVal hwnd As Long) 
    Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer 
    Dim DlgWidth As Integer, DlgHeight As Integer 
    GetWindowRect hwnd, WinRect 
    DlgWidth = WinRect.Right - WinRect.Left 
    DlgHeight = WinRect.Bottom - WinRect.Top 
    ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN) 
    ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN) 
    MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
        (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1 
End Sub 
 
Public Function fncGetFolder( _
        Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
        Optional ByVal lFlag As BIF_Flag = BIF_RETURNONLYFSDIRS, _
        Optional ByVal sPath As String = "C:\") As String 
    Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String 
    s_BrowseInitDir = sPath 
    With xl 
        .hwnd = FindWindow("XLMAIN", vbNullString) 
        .Root = 0 
        .Title = lstrcat(sMsg, "") 
        .Flags = lFlag 
        .FName = FuncCallback(AddressOf BrowseCallback) 
    End With 
    IDList = SHBrowseForFolder(xl) 
    If IDList <> 0 Then 
        FolderName = Space(256) 
        RVal = SHGetPathFromIDList(IDList, FolderName) 
        CoTaskMemFree (IDList) 
        FolderName = Trim$(FolderName) 
        FolderName = Left$(FolderName, Len(FolderName) - 1) 
    End If 
    fncGetFolder = FolderName 
End Function 
Gruß Tino
Anzeige
AW: per Code Unterverzeichnis anlegen
23.09.2009 13:48:36
Volker
Hallo Tino,
danke erst einmal für die schnell Hilfe. Werde es am Nachmittag ausprobieren. Was läuft den da in Modul2 alles ab, bei so einem langen Code.
AW: per Code Unterverzeichnis anlegen
23.09.2009 14:23:53
Tino
Hallo,
ist für einen Ordnerdialog um einen Ordner auszuwählen.
Gruß Tino
AW: per Code Unterverzeichnis anlegen
23.09.2009 16:52:16
Volker
Hallo Tino, kann man das nicht vieleicht so machen, das wenn des den Ordner nicht gibt, man per Code diesen anlegt? Sonst ist deine Hilfe (der Code ) super.
AW: per Code Unterverzeichnis anlegen
23.09.2009 17:55:47
Tino
Hallo,
Es wird versucht die Ordner hier anzulegen
lngPath = apiCreateFullPath(strPath)
Geht dies nicht, weil z. Bsp. das Laufwerk fehlt, geht der Dialog auf um einen Ort auszuwählen.
An diesem Ort werden die Ordner und Unterordner angelegt.
lngPath = apiCreateFullPath(strPathNeu)
Geht dies auch nicht, weil z. Bsp. die rechte fehlen Ordner anzulegen kommt die Meldung.
Gruß Tino
Anzeige
AW: per Code Unterverzeichnis anlegen
23.09.2009 14:28:39
fcs
Hallo Volker,
hier mein Vorschlag.
Gruß
Franz
'Erstellt unter Excel 2003
Sub aaTest()
'Sicherheitskopie der aktiven Datei erstellen
If ActiveWorkbook.Saved = False Then ActiveWorkbook.Save
If fncSicherheitsKopie(wb:=ActiveWorkbook, _
strDir:="C:\LokaleDaten\Test\Secure", _
strFile:=Format(Now, "YYYYMMDD_hhmmss_") & ActiveWorkbook.Name) = False Then
MsgBox "Es wurde keine Sicherheitskopie erstellt!", vbCritical + vbOKOnly, _
"Sicherheitskopie erstellen"
Else
MsgBox "Sicherheitskopie erstellt!", vbInformation + vbOKOnly, _
"Sicherheitskopie erstellen"
End If
End Sub
'Diese Function muss in einem allgemeinen Modul des VBA-Projects gespeichert werden
Public Function fncSicherheitsKopie(wb As Workbook, strDir As String, _
Optional strFile As String) As Boolean
'Erstellt eine Kopie der Arbeitsmappe wb im Verzeichnis strDir unter dem optionalen _
Namen strFile _
Wird der Name weggelassen, wird "Kopie_" vor den Dateinamen gesetzt.
If strFile = "" Then strFile = "Kopie_" & wb.Name
If Dir(Pathname:=strDir, Attributes:=vbDirectory) = "" Then
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Vorgegebenes Verzeichnis nicht vorhanden - " _
& "Bitte Verzeichnis für Sicherungskopie auswählen"
.ButtonName = "Auswählen"
.InitialView = msoFileDialogViewDetails
If .Show  False Then
strDir = .SelectedItems(1)
wb.SaveCopyAs FileName:=strDir & Application.PathSeparator & strFile
fncSicherheitsKopie = True
Else
fncSicherheitsKopie = False
End If
End With
Else
wb.SaveCopyAs FileName:=strDir & Application.PathSeparator & strFile
fncSicherheitsKopie = True
End If
End Function

Anzeige
AW: per Code Unterverzeichnis anlegen
23.09.2009 16:40:05
Volker
Hallo Franz, steh aus der Leitung.
allgemeines Modul= Modul und den erste Teil in z.B. Tabelle1 oder diese Arbeitsmappe? Richtig?
AW: per Code Unterverzeichnis anlegen
24.09.2009 10:36:20
fcs
Hallo Volker,
der erste Teil kann beliebig in anderen Prozeduren eingebaut werden. Er ist ein Beispiel wie die Function aufgerufen werden kann.
Wenn du die die Sicherheits-Kopie beim Öffnen der Datei automatisch erstellen willst, dann unter DieseArbeitsmappe, aber eingebunden in die Workbook_Open-Ereignisprozedur.
Gruß
Franz
Private Sub Workbook_Open()
'Sicherheitskopie der aktiven Datei erstellen
'Bei der Kopie wird die Datum+Uhrzeit dem Namen vorangestellt.
'Wert des Parameters "strDir" anpassen!                         #ACHTUNG#
If fncSicherheitsKopie(wb:=ActiveWorkbook, _
strDir:="C:\Lokale Daten\Test\Kopie", _
strFile:=Format(Now, "YYYYMMDD_hhmmss_") & ActiveWorkbook.Name) = False Then
MsgBox "Es wurde keine Sicherheitskopie erstellt!", vbCritical + vbOKOnly, _
"Sicherheitskopie erstellen"
Else
MsgBox "Sicherheitskopie erstellt!", vbInformation + vbOKOnly, _
"Sicherheitskopie erstellen"
End If
End Sub

Anzeige
AW: per Code Unterverzeichnis anlegen
24.09.2009 19:51:08
Volker
Hallo Franz, danke dir für die Hilfe und Erklärungen. Sind sehr hilfreich. Schönen Abend noch.

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige