AW: Ordner kopieren und umbenennen
30.06.2003 20:45:55
Nepumuk
Hallo Tobias,
da war noch ein grober Fehler drin. Aber jetzt geht's:
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 ein Verzeichnis", "")
.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
GetAOrdner = FolderName
End Function
Public Sub umbenennen()
Dim FsyObjekt As Object, FolObjekt As Object, FilObjekt As Object
Dim Ordner As String, index As Integer, Tabelle As Worksheet, Neu As String
Dim xlApp As New Excel.Application
Ordner = GetAOrdner
If Ordner <> "" Then
Application.ScreenUpdating = False
Neu = Cells(1, 1)
Set FsyObjekt = CreateObject("Scripting.FileSystemObject")
Set FolObjekt = FsyObjekt.GetFolder(Ordner)
Ordner = Left(Ordner, Len(Ordner) - Len(Neu)) & Neu
FolObjekt.Copy (Ordner)
With Application.FileSearch
.LookIn = Ordner
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 1 Then
For index = 1 To .FoundFiles.Count
If ThisWorkbook.FullName <> .FoundFiles(index) Then
xlApp.Workbooks.Open .FoundFiles(index)
For Each Tabelle In xlApp.ActiveWorkbook.Sheets
Tabelle.Name = Left(Tabelle.Name, Len(Tabelle.Name) - Len(Neu)) & Neu
Next
xlApp.ActiveWorkbook.Close True
Set FilObjekt = FsyObjekt.GetFile(.FoundFiles(index))
FilObjekt.Name = Left(FilObjekt.Name, Len(FilObjekt.Name) - Len(Neu) - 4) & Neu & ".xls"
End If
Next
End If
End With
Application.ScreenUpdating = True
End If
End Sub
Gruß
Nepumuk