Re: Speichern unter und Registernamen
22.11.2002 16:29:58
Nepumuk
Hallo Rudi,1. Speichern in festgelegtes Verzeichnis (Beispiel):
ActiveWorkbook.SaveAs "C:\Eigene Dateien\Eigene Tabellen\" & (Range("ORDNER") & ".xls")
2. Speichern in ein frei wählbares Verzeichnis:
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, PrgName As String
With xl
.hwnd = FindWindow("", "Auswahl")
.Title = lstrcat("Bitte wählen Sie ein Verzeichnis", "")
.Flags = 1
End With
IDList = SHBrowseForFolder(xl)
If IDList <> 0 Then
PrgName = Space(256)
RVal = SHGetPathFromIDList(IDList, PrgName)
CoTaskMemFree (IDList)
PrgName = LTrim(RTrim(PrgName))
End If
GetAOrdner = PrgName
End Function
Private Sub Workbook_BeforeClose(Cancel As Boolean)
ActiveWorkbook.Save
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Verzeichnis As String
Application.EnableEvents = False
Verzeichnis = GetAOrdner
If Verzeichnis <> "" Then
Verzeichnis = Mid(Verzeichnis, 1, Len(Verzeichnis) - 1)
ActiveWorkbook.SaveAs Verzeichnis & "\" & (Range("ORDNER") & ".xls")
Application.EnableEvents = True
End If
Cancel = True
End Sub
3. Verschieben oder kopieren von Tabellen:
Sheets("tab").Copy Before:=Workbooks("X").Sheets(1) für kopieren
Sheets("tab").Move Before:=Workbooks("X").Sheets(1) für verschieben
Gruß
Nepumuk