AW: Arbeitsblatt ohne Symbolleisten anzeigen
03.02.2005 15:55:05
Matthias
Hallo Josef,
Oder, noch etwas verfeinert:
in "DieseArbeitsmappe":
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim pfad As String, fn As String
fn = ActiveSheet.[B1]
Cancel = True
pfad = Ordnerauswahl(ThisWorkbook.Path, "Bitte Speicherort für " & fn & " auswählen")
If pfad = "" Then Exit Sub 'Abbrechen geklickt
If Right(pfad, 1) <> "\" Then pfad = pfad & "\"
On Error Resume Next
Application.EnableEvents = False
MsgBox pfad & fn
ThisWorkbook.SaveAs Filename:=pfad & fn
If Err.Number > 0 Then
MsgBox "Datei konnte nicht gespeichert werden!", vbCritical, "Fehler beim Speichern"
Err.Clear
Else
MsgBox "Datei wurde unter " & ThisWorkbook.FullName & " gespeichert."
End If
Application.EnableEvents = True
End Sub
und in ein normales Modul:
Private Type BROWSEINFO
hWndOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpFn As Long
lParam As String
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (ByRef lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Const WM_USER As Long = &H400
Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SETSELECTION As Long = (WM_USER + 102)
Private Const MAX_PATH As Long = 260
Public Function GetFolderInternal(ByVal Caption As String, _
ByVal default As String) As String
Dim BI As BROWSEINFO
Dim ListIdx As Long
Dim Path As String
With BI
.lpszTitle = Caption
.ulFlags = BIF_RETURNONLYFSDIRS
.lpFn = MakeFktnPtr(AddressOf BrowseCallbackProc)
.lParam = default
End With
Path = String$(MAX_PATH + 1, vbNullChar)
ListIdx = SHBrowseForFolder(BI)
If SHGetPathFromIDList(ListIdx, Path) Then
GetFolderInternal = Left$(Path, InStr(Path, vbNullChar) - 1)
End If
CoTaskMemFree ListIdx
End Function
Private Function BrowseCallbackProc(ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
On Error Resume Next
If Msg = BFFM_INITIALIZED Then
SendMessage hWnd, BFFM_SETSELECTION, 1&, lpData
End If
End Function
Private Function MakeFktnPtr(ByVal FktnPtr As Long) As Long
MakeFktnPtr = FktnPtr
End Function
Function Ordnerauswahl(default As String, Optional Msg)
If IsMissing(Msg) Then Msg = "Ordner auswählen:"
Dim Verzeichnis As String
Dim verzeichnis2 As String
Verzeichnis = default
verzeichnis2 = GetFolderInternal(Msg, Verzeichnis)
Ordnerauswahl = verzeichnis2
End Function
(letzerer Code ist nicht von mir, hab ich irgendwo aus dem Web)
Gruß Matthias