Ich habe in der Recherche folgenden Code gefunden.
Ich habe im Netzlaufwerk H: einen Ordner mit Namen Muster angelegt.
Dann änderte ich im Code KW auf Muster.
Beim Starten des Makros "speichern" und dem Versuch der Ordnerauswahl erhalte ich trotzdem den Fehler "Sie haben nicht den Ordner Muster ausgewählt."
Wo habe ich mich bitte hier geirrt?
Danke
Josef
Option Explicit
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
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 Function GetAOrdner() 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 das Verzeichnis Muster", "")
.Flags = &H1
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
GetAOrdner = FolderName
End Function
Public Sub speichern()
Dim strPfad As String
strPfad = GetSetting("Ordner Muster", "Muster", "Pfad")
Do
If strPfad "" Then
If Dir(strPfad, vbDirectory) = "" Then strPfad = GetAOrdner
Else
strPfad = GetAOrdner
End If
If strPfad = "" Then Exit Sub
If Right(strPfad, 2) = "Muster" Then Exit Do
If MsgBox("Sie haben nicht den Ordner Muster ausgewählt.", 37, "Hinweis") = 2 Then Exit Sub
strPfad = ""
Loop
SaveSetting "Ordner Muster", "Muster", "Pfad", strPfad
Application.ScreenUpdating = False
'ActiveSheet.Copy
'ActiveSheet.Name = sWch
ActiveWorkbook.SaveAs (strPfad & "\" & "Muster" & "_" & Format(Date, "YY") & ".xls") '= KW09_04.xls
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub