AW: Pfad festlegen
07.07.2006 10:39:17
Ramses
Hallo
Option Explicit
'############################################################################################'
' Die folgenden Makros durchsuchen einen Ordner und seine Unterordner '
' Modified by Ramses '
' Der Code besteht zu TeilFragmenten aus Forumsbeiträgen
' Die einzelnen Verfasser sind mir leider nicht mehr bekannt. '
'############################################################################################'
'############################################################################################'
'Dieser Bereich kann entfallen, wenn der Variable 'Laufwerk' ein fester Wert zugewiesen wird.'
Public Type BROWSEINFO '
hOwner As Long '
pidlRoot As Long '
pszDisplayName As String '
lpszTitle As String '
ulFlags As Long '
lpfn As Long '
lParam As Long '
iImage As Long '
End Type '
Declare
Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Msg) As String
Dim myInfo As BROWSEINFO
Dim mypath As String
Dim Root As Long, ID As Long, pos As Integer
With myInfo
.pidlRoot = 0&
.lpszTitle = Msg
.ulFlags = &H1
End With
ID = SHBrowseForFolder(myInfo)
mypath = VBA.Space$(512)
Root = SHGetPathFromIDList(ByVal ID, ByVal mypath)
If Root Then
pos = InStr(mypath, VBA.Chr$(0))
GetDirectory = VBA.Left(mypath, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub Select_Path()
'Ausführen zum speichern
Dim Msg As String, mypath As String
Msg = "Wählen Sie ein Verzeichnis aus," & vbCrLf & "dessen Inhalt angezeigt werden soll:"
mypath = GetDirectory(Msg)
If Len(mypath) > 0 Then
MsgBox "Sie haben das Verzeichnis: " & mypath & " ausgewählt"
Else
MsgBox "Nichts ausgewählt"
End If
'Datei speichern
'ActiveWorkbook.SaveAs mypath & "\" & ActiveWorkbook.name
End Sub
Gruss Rainer