GetSaveAsFilename: Fixer InitialFileName möglich
18.05.2017 15:09:43
Nepumuk
Hallo,
das geht auch mit Dateianzeige:
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal DirPath As String) As Long
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.dll" ( _
ByRef lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32.dll" ( _
ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32.dll" Alias "lstrcatA" ( _
ByVal lpStr1 As String, _
ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" ( _
ByVal pList As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function SendMessageA Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByRef wParam As Any, _
ByRef lParam As Any) As Long
Private Declare Function ILCreateFromPath Lib "shell32.dll" Alias "#157" ( _
ByVal sPath As String) 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
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_EDITBOX = &H10
Private Const BIF_VALIDATE = &H20
Private Const BIF_NEWDIALOGSTYLE = &H40
Private Const BIF_BROWSEINCLUDEURLS = &H80
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const BIF_BROWSEINCLUDEFILES = &H4000
Private Const BIF_SHAREABLE = &H8000
Private Const SM_CXFULLSCREEN = &H10
Private Const SM_CYFULLSCREEN = &H11
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = &H1
Private lstrInitDir As String
Private Function GetFolder( _
Optional ByVal opvstrMsg As String = "Bitte wählen Sie ein Verzeichnis", _
Optional ByVal opvlngFlag As Long = BIF_RETURNONLYFSDIRS, _
Optional ByVal opvstrInitDir As String = "C:\", _
Optional ByVal opvstrOnlyInRoot As String = vbNullString) As String
Dim udtInfo As InfoT
Dim lngIDList As Long, lngReturn As Long
Dim strPath As String
lstrInitDir = opvstrInitDir
With udtInfo
.hwnd = Application.hwnd
.Root = ILCreateFromPath(StrConv(opvstrOnlyInRoot, vbUnicode))
.Title = lstrcat(opvstrMsg, "")
.Flags = opvlngFlag
.FName = Callback(AddressOf BrowseCallback)
End With
lngIDList = SHBrowseForFolder(udtInfo)
If lngIDList <> 0 Then
strPath = Space$(256)
Call SHGetPathFromIDList(lngIDList, strPath)
Call CoTaskMemFree(lngIDList)
strPath = Trim$(strPath)
strPath = Left$(strPath, Len(strPath) - 1)
End If
GetFolder = strPath
End Function
Private Function BrowseCallback( _
ByVal pvlngHwnd As Long, _
ByVal pvlngMsg As Long, _
ByVal pvlngwParam As Long, _
ByVal pvlnglParam As Long) As Long
If pvlngMsg = BFFM_INITIALIZED Then
Call SendMessageA(pvlngHwnd, BFFM_SETSELECTION, _
ByVal 1&, ByVal lstrInitDir)
Call CenterDialog(pvlngHwnd)
End If
BrowseCallback = 0
End Function
Private Function Callback( _
ByVal pvlngParam As Long) As Long
Callback = pvlngParam
End Function
Private Sub CenterDialog( _
ByVal pvlngHwnd As Long)
Dim udtWinRect As RECT
Dim lngScrWidth As Long, lngScrHeight As Long
Dim lngDlgWidth As Long, lngDlgHeight As Long
Call GetWindowRect(pvlngHwnd, udtWinRect)
lngDlgWidth = udtWinRect.Right - udtWinRect.Left
lngDlgHeight = udtWinRect.Bottom - udtWinRect.Top
lngScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
lngScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
Call MoveWindow(pvlngHwnd, (lngScrWidth - lngDlgWidth) / 2, _
(lngScrHeight - lngDlgHeight) / 2, lngDlgWidth, lngDlgHeight, 1)
End Sub
Public Sub test()
Const PRE_SELECT As String = "C:\Users\Public\"
Dim strFolder As String
If Cbool(MakeSureDirectoryPathExists(PRE_SELECT)) Then
strFolder = GetFolder("Zielverzeichnis auswählen", BIF_BROWSEINCLUDEFILES, PRE_SELECT)
If strFolder <> "" Then MsgBox strFolder
Else
MsgBox "Kein Zugriff auf Ordner " & PRE_SELECT
End If
End Sub
Gruß
Nepumuk