BrowseForFolder

Bild

Betrifft: BrowseForFolder
von: Henry
Geschrieben am: 23.09.2015 13:14:20

Moin,
ist es hier möglich zu bestimmen welches Startordner angezeigt werden soll ?
Beste Grüße
Henry

Function BrowseForFolder(Optional OpenAt As String) As String
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.path
    On Error GoTo 0
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then
            BrowseForFolder = ""
        End If
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then
            BrowseForFolder = ""
        End If
    Case Else
        BrowseForFolder = ""
    End Select
ExitFunction:
    Set ShellApp = Nothing
End Function

Bild

Betrifft: AW: BrowseForFolder
von: matthias
Geschrieben am: 23.09.2015 13:20:38
Hallo Henry,
in deinem Code gibt es bereits eine Variable dafür, du musst ihr nur einen Pfad zuweisen:

OpenAt = "D:\Ordner1\Ordner2"
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
lg Matthias

Bild

Betrifft: AW: BrowseForFolder
von: Henry
Geschrieben am: 23.09.2015 13:40:29
Hallo Matthias,
danke!Habe ich so eingefügt.
Merkwürdigerweise öffnet er trotdessen nicht im OpenAt definierten Laufwerk / Pfad.
Hat das evtl mit den Optionen ",0" irgendwas auf sich ?

Bild

Betrifft: AW: BrowseForFolder
von: matthias
Geschrieben am: 23.09.2015 14:05:21
Ahh, ich sehe grad, dass OpenAt in der Funktion beim Aufruf erfolgreich übergeben wird. Was jedoch nicht der Fall ist, ist dass BrowseForFolder darauf reagiert. Ich kann es dir leider nicht erklären warum, aber sobald ich OpenAt an eine andere Variable (hier Pfad) übergebe, funktioniert es.

Sub Test()
Dim x As String
x = "J:\Projects\04 VW EA288 AGW"
BrowseForFolder (x)
End Sub
Function BrowseForFolder(OpenAt As String) As String
     Dim ShellApp As Object
     Pfad = OpenAt
     Set ShellApp = CreateObject("Shell.Application"). _
     BrowseForFolder(0, "Please choose a folder", 0, Pfad)
     On Error Resume Next
     '...
End Function
lg Matthias

Bild

Betrifft: AW: BrowseForFolder
von: Henry
Geschrieben am: 23.09.2015 14:52:17
Hi Matthias,
bitte entschuldige das ich nochmal nachfragen muss...habe es genauso einkopiert. Jetzt meckert er wieder "Argument is nicht optional"
Wäre das okay wenn ich hier nochmal den Code im gnazen zitiere und du mir anhand dessen zeigst was geändert werden muss ?
Es ist ein Outlook Makro
Modul 1:

Option Explicit
'Public lf As New LogFile
 
Sub SaveAllEmails_ProcessAllSubFolders()
    Dim i               As Long
    Dim j               As Long
    Dim n               As Long
    Dim StrSubject      As String
    Dim StrName         As String
    Dim StrFile         As String
    Dim StrReceived     As String
    Dim StrSavePath     As String
    Dim StrFolder       As String
    Dim StrFolderPath   As String
    Dim StrSaveFolder   As String
    Dim Prompt          As String
    Dim Title           As String
    Dim iNameSpace      As NameSpace
    Dim myOlApp         As Outlook.Application
    Dim SubFolder       As MAPIFolder
    Dim mItem           As MailItem
    Dim FSO             As Object
    Dim ChosenFolder    As Object
    Dim Folders         As New Collection
    Dim EntryID         As New Collection
    Dim StoreID         As New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myOlApp = Outlook.Application
    Set iNameSpace = myOlApp.GetNamespace("MAPI")
    Set ChosenFolder = iNameSpace.PickFolder
    If ChosenFolder Is Nothing Then
GoTo ExitSub:
    End If
    Prompt = "Please enter the path to save all the emails to."
    Title = "Folder Specification"
    StrSavePath = BrowseForFolder
    If StrSavePath = "" Then
GoTo ExitSub:
    End If
    If Not Right(StrSavePath, 1) = "\" Then
        StrSavePath = StrSavePath & "\"
    End If
   ' lf.name = StrSavePath + "Post.log"
    Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
     
    For i = 1 To Folders.Count
        StrFolder = StripIllegalChar(Folders(i))
        n = InStr(3, StrFolder, ChosenFolder)
        StrFolder = Mid(StrFolder, n, 256)
        StrFolderPath = StrSavePath & StrFolder & "\"
        StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
        Call PfadErstellen(StrFolderPath)
        
        Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
        On Error Resume Next
        For j = 1 To SubFolder.Items.Count
            Set mItem = SubFolder.Items(j)
'            StrReceived = ArrangedDate(mItem.ReceivedTime)
            StrReceived = Format(mItem.ReceivedTime, "yyyy-mm-dd_hh-nn-ss")
            StrSubject = mItem.Subject
            StrName = StripIllegalChar(StrSubject)
            StrFile = StrSaveFolder & StrReceived & "_" & StrName
            StrFile = Left(StrFile, 200) & ".msg"
            'lf.LFInfo StrReceived & "<|>" & StrName & "<|>" & mItem.Sender.name & "<|>" &  _
mItem.To & "<|>" & mItem.CC & "<|>" & StrFile
            mItem.SaveAs StrFile, 3
        Next j
        On Error GoTo 0
    Next i
ExitSub:
End Sub
 
Function StripIllegalChar(StrInput)
    Dim RegX            As Object
    Set RegX = CreateObject("vbscript.regexp")
    RegX.Pattern = "[\" & Chr(34) & Chr(10) & Chr(13) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\ _
;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True
    StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
    Set RegX = Nothing
End Function
 
Function ArrangedDate(StrDateInput)
    Dim StrFullDate     As String
    Dim StrFullTime     As String
    Dim StrAMPM         As String
    Dim StrTime         As String
    Dim StrYear         As String
    Dim StrMonthDay     As String
    Dim StrMonth        As String
    Dim StrDay          As String
    Dim StrDate         As String
    Dim StrDateTime     As String
    Dim RegX            As Object
    Set RegX = CreateObject("vbscript.regexp")
    If Not Left(StrDateInput, 2) = "10" And _
    Not Left(StrDateInput, 2) = "11" And _
    Not Left(StrDateInput, 2) = "12" Then
        StrDateInput = "0" & StrDateInput
    End If
    StrFullDate = Left(StrDateInput, 10)
    If Right(StrFullDate, 1) = " " Then
        StrFullDate = Left(StrDateInput, 9)
    End If
    StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")
    If Len(StrFullTime) = 10 Then
        StrFullTime = "0" & StrFullTime
    End If
    StrAMPM = Right(StrFullTime, 2)
    StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
    StrYear = Right(StrFullDate, 4)
    StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
    StrMonth = Left(StrMonthDay, 2)
    StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
    If Len(StrDay) = 1 Then
        StrDay = "0" & StrDay
    End If
    StrDate = StrYear & "-" & StrMonth & "-" & StrDay
    StrDateTime = StrDate & "_" & StrTime
    RegX.Pattern = "[\:\/\ ]"
    RegX.IgnoreCase = True
    RegX.Global = True
    ArrangedDate = RegX.Replace(StrDateTime, "-")
ExitFunction:
    Set RegX = Nothing
End Function
 
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As  _
MAPIFolder)
    Dim SubFolder       As MAPIFolder
    Folders.Add Fld.FolderPath
    EntryID.Add Fld.EntryID
    StoreID.Add Fld.StoreID
    For Each SubFolder In Fld.Folders
        GetFolder Folders, EntryID, StoreID, SubFolder
    Next SubFolder
ExitSub:
    Set SubFolder = Nothing
End Sub
 
Function BrowseForFolder(Optional OpenAt As String) As String
    Dim ShellApp As Object
    OpenAt = "C:\"
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.path
    On Error GoTo 0
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then
            BrowseForFolder = ""
        End If
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then
            BrowseForFolder = ""
        End If
    Case Else
        BrowseForFolder = ""
    End Select
ExitFunction:
    Set ShellApp = Nothing
End Function
Modul 2:
Sub PfadErstellen(Pfad As String)
Dim PfadTeile
Dim Pfad1
Dim i As Long
PfadTeile = Split(Pfad, "\")
Pfad1 = PfadTeile(0)
For i = 1 To UBound(PfadTeile)
    Pfad1 = Pfad1 & "\" & PfadTeile(i)
    If Dir(Pfad1, vbDirectory) = "" Then MkDir Pfad1
Next
End Sub


Bild

Betrifft: AW: BrowseForFolder
von: matthias
Geschrieben am: 23.09.2015 15:02:26
Hihi,
das ist ein Fehler meinerseits, da ich etwas rumprobiert hatte.
Die erste Zeile der Funktion muss natürlich wie in deinem Ausgangspost lauten:
Function BrowseForFolder(Optional OpenAt As String) As String
lg Matthias

Bild

Betrifft: AW: BrowseForFolder
von: matthias
Geschrieben am: 23.09.2015 15:09:58
An dieser Stelle rufst du deine Funktion auf:
-> StrSavePath = BrowseForFolder
um einen Standard-Ordner anzugeben kann dieser in Klammern angehängt werden:
-> StrSavePath = BrowseForFolder("D:\Ordner1\Ordner2")
Das spiegelt sich auch in deiner Funktion wieder:
-> Function BrowseForFolder(Optional OpenAt As String) As String
Der beim Aufruf in Klammern angegebene Wert wird als OpenAt übernommen.
lg Matthias

Bild

Betrifft: AW: BrowseForFolder
von: Henry
Geschrieben am: 23.09.2015 15:29:17
Hi Matthias,
nix, nada, niente :) Ich muss mich leider immer noch bis zum Speicherort duchklicken.
Najs prinzipell funktioniert das tool ja nur leider unpraktisch für denjenigen wenn man nicht im Zielordner landet und sich durchklicken muss :(
Hattest du das Modul bei dir einkopiert und ausprobiert ?

Bild

Betrifft: AW: BrowseForFolder
von: Rudi Maintaire
Geschrieben am: 23.09.2015 15:40:40
Hallo,
na wenn du hier

    OpenAt = "C:\"
den Pfad auf c:\ setzt, ist das kein Wunder.
Gruß
Rudi
Warum eigentlich so kompliziert?
Application.FileDialog(msoFileDialogFolderPicker) ist viel einfacher.

Bild

Betrifft: AW: BrowseForFolder
von: Henry
Geschrieben am: 23.09.2015 15:57:35
Moin Rudi,
das OpenAt = "C:\" hatte ich bereits gelöscht aber trotzdem kann ich den Pfad nicht über StrSavePath = BrowseForFolder("H:\") festlegen.
Alternativen sind gern willkommen wie könnte ich denn Application.FileDialog(msoFileDialogFolderPicker einbauen und das BrowseForFolder ersetzen ?

Bild

Betrifft: AW: BrowseForFolder
von: Rudi Maintaire
Geschrieben am: 23.09.2015 16:29:37
Hallo,

Sub aaa()
  Dim strSavePfad As String
  strSavePfad = BrowseForFolder("c:\test")
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
  If Right(OpenAt, 1) <> "\" Then OpenAt = OpenAt & "\"
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Bitte Ordner wählen"
    .InitialFileName = OpenAt
    If .Show = -1 Then
      BrowseForFolder = .SelectedItems(1)
    End If
  End With
End Function
Gruß
Rudi

Bild

Betrifft: AW: BrowseForFolder
von: Henry
Geschrieben am: 23.09.2015 16:41:36
Danke Rudi & Mathias,
ich bin echt geplättet und gebe für heute auf.
leider immer noch nicht.
Nur falls Ihr es schafft bzw noch die Muse habt mich da auf den richtigen Pfad zu bringen hier nochmal das komplette Modul 1 + zugehörige Modul 2.
Vlcht könntest ihr das soweit einbauen weil ich verstehe es heute einfach nicht.
Ihr habt mir bisher aber super Weit geholfen und besten Dank dafür !!!!!
Ziel ist wirklich nur die Vorbelegung des Pfads C:\ oder einen anderen den ich definieren kann.
Modul 1:

Option Explicit
'Public lf As New LogFile
 
Sub SaveAllEmails_ProcessAllSubFolders()
    Dim i               As Long
    Dim j               As Long
    Dim n               As Long
    Dim StrSubject      As String
    Dim StrName         As String
    Dim StrFile         As String
    Dim StrReceived     As String
    Dim StrSavePath     As String
    Dim StrFolder       As String
    Dim StrFolderPath   As String
    Dim StrSaveFolder   As String
    Dim Prompt          As String
    Dim Title           As String
    Dim iNameSpace      As NameSpace
    Dim myOlApp         As Outlook.Application
    Dim SubFolder       As MAPIFolder
    Dim mItem           As MailItem
    Dim FSO             As Object
    Dim ChosenFolder    As Object
    Dim Folders         As New Collection
    Dim EntryID         As New Collection
    Dim StoreID         As New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myOlApp = Outlook.Application
    Set iNameSpace = myOlApp.GetNamespace("MAPI")
    Set ChosenFolder = iNameSpace.PickFolder
    If ChosenFolder Is Nothing Then
GoTo ExitSub:
    End If
    Prompt = "Please enter the path to save all the emails to."
    Title = "Folder Specification"
    StrSavePath = BrowseForFolder
    If StrSavePath = "" Then
GoTo ExitSub:
    End If
    If Not Right(StrSavePath, 1) = "\" Then
        StrSavePath = StrSavePath & "\"
    End If
   ' lf.name = StrSavePath + "Post.log"
    Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
     
    For i = 1 To Folders.Count
        StrFolder = StripIllegalChar(Folders(i))
        n = InStr(3, StrFolder, ChosenFolder)
        StrFolder = Mid(StrFolder, n, 256)
        StrFolderPath = StrSavePath & StrFolder & "\"
        StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
        Call PfadErstellen(StrFolderPath)
        
        Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
        On Error Resume Next
        For j = 1 To SubFolder.Items.Count
            Set mItem = SubFolder.Items(j)
'            StrReceived = ArrangedDate(mItem.ReceivedTime)
            StrReceived = Format(mItem.ReceivedTime, "yyyy-mm-dd_hh-nn-ss")
            StrSubject = mItem.Subject
            StrName = StripIllegalChar(StrSubject)
            StrFile = StrSaveFolder & StrReceived & "_" & StrName
            StrFile = Left(StrFile, 200) & ".msg"
            'lf.LFInfo StrReceived & "<|>" & StrName & "<|>" & mItem.Sender.name & "<|>" &  _
mItem.To & "<|>" & mItem.CC & "<|>" & StrFile
            mItem.SaveAs StrFile, 3
        Next j
        On Error GoTo 0
    Next i
ExitSub:
End Sub
 
Function StripIllegalChar(StrInput)
    Dim RegX            As Object
    Set RegX = CreateObject("vbscript.regexp")
    RegX.Pattern = "[\" & Chr(34) & Chr(10) & Chr(13) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\ _
;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True
    StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
    Set RegX = Nothing
End Function
 
Function ArrangedDate(StrDateInput)
    Dim StrFullDate     As String
    Dim StrFullTime     As String
    Dim StrAMPM         As String
    Dim StrTime         As String
    Dim StrYear         As String
    Dim StrMonthDay     As String
    Dim StrMonth        As String
    Dim StrDay          As String
    Dim StrDate         As String
    Dim StrDateTime     As String
    Dim RegX            As Object
    Set RegX = CreateObject("vbscript.regexp")
    If Not Left(StrDateInput, 2) = "10" And _
    Not Left(StrDateInput, 2) = "11" And _
    Not Left(StrDateInput, 2) = "12" Then
        StrDateInput = "0" & StrDateInput
    End If
    StrFullDate = Left(StrDateInput, 10)
    If Right(StrFullDate, 1) = " " Then
        StrFullDate = Left(StrDateInput, 9)
    End If
    StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")
    If Len(StrFullTime) = 10 Then
        StrFullTime = "0" & StrFullTime
    End If
    StrAMPM = Right(StrFullTime, 2)
    StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
    StrYear = Right(StrFullDate, 4)
    StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
    StrMonth = Left(StrMonthDay, 2)
    StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
    If Len(StrDay) = 1 Then
        StrDay = "0" & StrDay
    End If
    StrDate = StrYear & "-" & StrMonth & "-" & StrDay
    StrDateTime = StrDate & "_" & StrTime
    RegX.Pattern = "[\:\/\ ]"
    RegX.IgnoreCase = True
    RegX.Global = True
    ArrangedDate = RegX.Replace(StrDateTime, "-")
ExitFunction:
    Set RegX = Nothing
End Function
 
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As  _
MAPIFolder)
    Dim SubFolder       As MAPIFolder
    Folders.Add Fld.FolderPath
    EntryID.Add Fld.EntryID
    StoreID.Add Fld.StoreID
    For Each SubFolder In Fld.Folders
        GetFolder Folders, EntryID, StoreID, SubFolder
    Next SubFolder
ExitSub:
    Set SubFolder = Nothing
End Sub
 
 
 
Function BrowseForFolder(Optional OpenAt As String) As String
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.path
    On Error GoTo 0
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then
            BrowseForFolder = ""
        End If
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then
            BrowseForFolder = ""
        End If
    Case Else
        BrowseForFolder = ""
    End Select
ExitFunction:
    Set ShellApp = Nothing
End Function
Modul 2 :
Sub PfadErstellen(Pfad As String)
Dim PfadTeile
Dim Pfad1
Dim i As Long
PfadTeile = Split(Pfad, "\")
Pfad1 = PfadTeile(0)
For i = 1 To UBound(PfadTeile)
    Pfad1 = Pfad1 & "\" & PfadTeile(i)
    If Dir(Pfad1, vbDirectory) = "" Then MkDir Pfad1
Next
End Sub


Bild

Betrifft: AW: BrowseForFolder
von: Namenloser
Geschrieben am: 23.09.2015 17:53:38
Hallo
der 4. Parameter der Methode .BrowseForFolder muss zwingend vom Typ Variant sein
d.h. entweder den Parameter klammern
...= CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a folder", 0, (OpenAt))
oder den optionale Parameter OpenAt deiner Funktion in einen Varianten wandeln.
Function BrowseForFolder(Optional OpenAt As Variant) As String

Bild

Betrifft: AW: BrowseForFolder
von: Henry
Geschrieben am: 24.09.2015 08:47:16
Moin Namenloser ,
super damit hat es jetzt geklappt :)


 Bild

Beiträge aus den Excel-Beispielen zum Thema "TextBoxen prüfen"