Pfad einmal suchen und diesen speichern

Hallo Freunde,
bisher speicher ich ein Blatt in einem neuen Ordner mit folgenden Anweisungen (Auszug):
.
.
ChDir "C:\Eigene Dateien\KW"
ActiveSheet.Copy
ActiveSheet.Name = sWch
sKW = Range("B3") '= KW09
sYY = Range("B2") '= 2004
sYY = Format(Date, "YY")
ActiveWorkbook.SaveAs ("KW" & sKW & "_" & sYY & ".xls") '= KW09_04.xls
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub
So weit so gut.Nun wollte ich ChDir... ersetzen z.B. mit der Anweisung
"Application.Dialogs(xlDialogOpen).Show" , um den Ordner "KW" zu finden, wenn dieser (und alle anderen dazu notwendigen Dateien/Ordner) auf einem anderen PC und einem anderen Pfad kopiert wurden.
Der einmal gefundene Pfad sollte gespeichert werden, um diesen beim Speichern eines neuen Blattes nicht wieder suchen zu müssen.Auch sollte die oben erwähnte Anweisung "ActiveWorkbook.SaveAs...." erhalten bleiben.
Meine tagelangen Versuche haben bisher nichts gebracht und der (Kurz-)Urlaub ist auch schon wieder vorbei.(schnief)
Vielen Dank im voraus und Grüße an alle
Dieter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Dieter,
das wäre eine Möglichkeit:


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 KW", "")
.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 KW", "KW", "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) = "KW" Then Exit Do
If MsgBox("Sie haben nicht den Ordner KW ausgewählt.", 37, "Hinweis") = 2 Then Exit Sub
strPfad = ""
Loop
SaveSetting "Ordner KW", "KW", "Pfad", strPfad
Application.ScreenUpdating = False
ActiveSheet.Copy
ActiveSheet.Name = sWch
ActiveWorkbook.SaveAs (strPfad & "\" & "KW" & Range("B3") & "_" & Format(Date, "YY") & ".xls") '= KW09_04.xls
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub

Code eingefügt mit: Excel Code Jeanie
Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Pfad einmal suchen und diesen speichern

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

209 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Pfad einmal suchen und diesen speichern

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

209 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread