AW: VBA Excel speichern unter Auswahlmöglichkeit?
17.06.2015 13:15:50
Hajo_Zi
Ordner Auswahl.
Option Explicit
' von Nepumuk
Private Type InfoT
hwnd As Long
Root As Long
DisplayName As Long
Title As Long
Flags As Long
FName As Long
lParm As Long
Image As Long
End Type
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
Function GetAOrdner1() As String
Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
With xl
.hwnd = FindWindow("xlmain", vbNullString)
.Title = lstrcat("Bitte wählen Sie ein Verzeichnis für die Ablage der HTM-Datei", "")
.Flags = 1
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
If Right(FolderName, 1) "\" And Len(FolderName) > 0 Then FolderName = FolderName & "\"
GetAOrdner1 = FolderName
End Function
Function GetAOrdner2() As String
' nicht notwendig da XLA nich ab 2007
' If BoFehler Then On Error GoTo Errorhandler1
' With Application.FileDialog(msoFileDialogFolderPicker)
' If .Show = -1 Then
' GetAOrdner2 = .SelectedItems(1) & "\"
' Else
' GetAOrdner2 = ""
' End If
' End With
' Exit Function
'Errorhandler1:
' Fehlerbehandlung 1, 167
End Function
Sub Start123()
Dim StOrdner12 As String
StOrdner12 = GetAOrdner1
End Sub
Auch für vor 2007.
ab 2007
Option Explicit ' Variablendefinition erforderlich
Option Private Module ' Keine Anzeige in Makroliste
Option Compare Text ' keine Unterscheidung Groß- _
Kleinbuchstaben
'* H. Ziplies *
'* 14.11.13 *
'* erstellt von HajoZiplies@WEB.de *
'* http://Hajo-Excel.de
Function GetAOrdner1() As String
If BoFehler Then On Error GoTo Errorhandler1
MsgBox "Es ist nicht vorgesehen das Sie eine XLAM Datei in einer Excel Version vor 2007 _
benutzen!!!" & Chr(13) & 70
Exit Function
Errorhandler1:
Fehlerbehandlung 1, 168
End Function
Function GetAOrdner2() As String
If BoFehler Then On Error GoTo Errorhandler1
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
GetAOrdner2 = .SelectedItems(1) & "\"
Else
GetAOrdner2 = ""
End If
End With
Exit Function
Errorhandler1:
Fehlerbehandlung 1, 167
End Function
Sub Start123()
Dim StOrdner12 As String
StOrdner12 = GetAOrdner2
End Sub