AW: PDF - Dateien drucken
15.02.2012 14:56:04
Frank
Hallo Dirk,
mit folgendem Code (aus mehreren Foren zusammenglaubt und verändert) kann man die Dateien in einem Ordner umbenennen. Wenn Du den Teil, in dem umbenannt wird, entsprechend abänderst, dann könnte es klappen. Der Code unterscheidet allerdings (noch) nicht zwischen verschiedenen Dateiformaten.
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
lParam 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 GetAOrdner() As String
Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
With xl
.hwnd = FindWindow("xlmain", vbNullString)
' .hwnd = FindWindow("", "Auswahl") ' Userform Auswahl
.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
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*. _
*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard= _
False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
ReDim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
Private Sub CommandButton1_Click()
Dim Zeile As Variant
Dim sFile As String, sPattern As String, sPath As String
Dim iRow As Integer
Dim iColumn As Integer
Dim objFiles() As Object, lngRet As Long, lngIndex As Long
Dim strNewName As String
Dim Datei As String
Dim iCount As Integer
On Error GoTo EndOfMacro
iCount = 0
iRow = 2
iColumn = 10
sPath = GetAOrdner
If sPath = "" Then GoTo EndOfMacro
lngRet = FileSearchINFO(objFiles, sPath, "*", True)
If Right(sPath, 1) "\" Then sPath = sPath & "\"
sPattern = "*.*"
sFile = Dir(sPath & sPattern)
Do Until sFile = "" ' Diese Do-Schleife muss geändert werden
iCount = iCount + 1
Datei = sPath & sFile
strNewName = sPath & Cells(iRow, iColumn).Value
Name Datei As strNewName
iRow = iRow + 1
sFile = Dir()
Loop
Cells(2, 9) = iCount
MsgBox "Es wurden " & iCount & " Dateien umbenannt.", vbOKOnly, "Fertig!"
EndOfMacro:
End Sub
Gruß
Frank