Hallo
Hab das ganze mal etwas umgebschrieben und die Speicherorte gleich mit aufgenommen.
Diese müssen zwar noch bestätigt werden, sollte aber prinzipiell möglich sein.
Um einen neuen Zielordner in deinem Basisverzeichnis anlegen willst, musst du bei der entsprechenden Dialogabfrage auf "Abbrechen" klicken.
In der Datei "C:\LastFolder.ini" werden die ganzen Folder-Einstellungen gespeichert.
Option Explicit
'Variablen Deklaration
' Funktion um Einträge aus einer INI Datei zu Lesen
Private Declare
Function ReadINIString Lib "kernel32" _
Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault$, _
ByVal lpReturnedString$, ByVal nSize As Long, _
ByVal lpFileName$) As Long
' Funktion, um Einträge in eine INI Datei zu schreiben
Private Declare
Function WriteINIString& Lib _
"kernel32" Alias "WritePrivateProfileStringA" _
(ByVal AppName$, ByVal KeyName$, _
ByVal keydefault$, ByVal FileName$)
'Einstellungen der letzten Ordner werden hier gespeichert
Private Const INI_File = "c:\LastFolder.ini"
'Einstellungen der letzten Ordner werden in diesen Section's gespeichert
Private Const LastFolder As String = "LastFolder"
Private Const BaseFolder As String = "BaseFolder"
Function SaveMyFolder(mysection As String, newFolder As String)
'1. Zuletzt verwendeten Ordner speichern
WriteINIString mysection, mysection, newFolder, INI_File
End Function
Function GetMyFolder(mysection As String, LastFolder As String) As String
Dim tmpRead As String
'Variablengrösse bestimmen
'255 Zeichen lang
tmpRead = String(255, 0)
ReadINIString mysection, LastFolder, vbNullString, tmpRead, 255, INI_File
GetMyFolder = Left$(tmpRead, InStr(1, tmpRead, Chr(0)) - 1)
End Function
Sub Rename_and_MoveFiles()
'(C) Ramses
'Verschiebt alle DQM und PS Dateien in einem Ordner
'in einen Zielordner und nummeriert diese neu
Dim tmpName As String, tarName As String, tarPath As String, srcPath As String
Dim myFSO As Object, myFld As Object, myFldFiles As Object, myFile As Object
Dim objFolder As Object, objFolderItem As Object, objShell As Object
Dim psCount As Integer, dqmCount As Integer, dqmCounter As Integer, psCounter As Integer
Dim Qe As Integer
Dim fSearch As FileSearch
Dim myErr As Integer
'ErrorHandler starten
'On Error GoTo myErrorHandler
'Erstellen des FileSystemObjectes
Set myFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
'Quellordner bestätigen
Set objFolder = objShell.BrowseForFolder(0&, "Quell Ordner auswählen...", 0&, GetMyFolder(BaseFolder, BaseFolder))
If objFolder Is Nothing Then Exit Sub
Set objFolderItem = objFolder.Self
srcPath = objFolderItem.Path
If Not myFSO.folderexists(srcPath) Then
MsgBox "Der Ordner :"" " & srcPath & " "" existiert nicht.", vbCritical + vbOKOnly, "Abbruch"
Exit Sub
End If
'Wenn neuer Quellordner definiert wurde diesen speichern
If srcPath <> GetMyFolder(BaseFolder, BaseFolder) Then
SaveMyFolder BaseFolder, srcPath
End If
'Zielordner auswählen
Set objFolder = objShell.BrowseForFolder(0&, "Ziel Ordner auswählen...", 0&, GetMyFolder(LastFolder, LastFolder))
If objFolder Is Nothing Then
'Bei Abbrechen !!!! wenn neuer Zielordner im Basisfolder erstellt werden soll !!!
Qe = MsgBox("Möchten Sie einen neuen Zielordner erstellen ?", vbQuestion + vbYesNo, "Ziel ändern ?")
If Qe = vbYes Then
Set objFolder = objShell.BrowseForFolder(0&, "Ziel Ordner auswählen...", 0&, GetMyFolder(BaseFolder, BaseFolder))
If objFolder Is Nothing Then Exit Sub
Else
Exit Sub
End If
End If
Set objFolderItem = objFolder.Self
tarPath = objFolderItem.Path
If Not myFSO.folderexists(tarPath) Then
MsgBox "Der Ordner :"" " & tarPath & " "" existiert nicht.", vbCritical + vbOKOnly, "Abbruch"
Exit Sub
End If
'Wenn neuer Zielordner definiert wurde diesen speichern
If tarPath <> GetMyFolder(LastFolder, LastFolder) Then
SaveMyFolder LastFolder, tarPath
End If
'File Search Initialisieren um die Anzahl Dateien zu bestimmen
Set fSearch = Application.FileSearch
With fSearch
'ermitteln der Anzahl von *.dqm - Files im Zielordner
.NewSearch
.LookIn = tarPath
.SearchSubFolders = False '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.FileName = "*.dqm"
.Execute
dqmCount = .FoundFiles.Count + 1
'ermitteln der Anzahl von *.ps - Files im Zielordner
.NewSearch
.LookIn = tarPath
.SearchSubFolders = False '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.FileName = "*.ps"
.Execute
psCount = .FoundFiles.Count + 1
End With
'Move Schleife starten
'Zuweisen des Quellpfades wo die Dateien herkommen
Set myFld = myFSO.GetFolder(srcPath)
'Zuweisund der Dateien in diesem Ordner
Set myFldFiles = myFld.Files
For Each myFile In myFldFiles
tmpName = myFile.Name
'Das INI File vom Kopiervorgang ausschliessen
'INI_File ist die globale Variable !!!
If Right(tmpName, 3) <> "ini" Then
If Right(tmpName, 3) = "dqm" Then
tarName = tarPath & "\Mp" & Format(dqmCount, "000") & ".dqm"
'DQM Zähler hochsetzen
dqmCounter = dqmCounter + 1
dqmCount = dqmCount + 1
ElseIf Right(tmpName, 2) = "ps" Then
tarName = tarPath & "\Mp" & Format(psCount, "000") & ".ps"
'PS Zähler hochsetzen
psCounter = psCounter + 1
psCount = psCount + 1
End If
myFSO.MoveFile myFile, tarName
End If
MoveRestart:
Next
MsgBox "Es wurden "" " & dqmCounter & " dqm-Files "" und "" " & Chr$(13) & _
psCounter & " ps-Files "" Dateien verschoben"
'Fehlerbehandlung Ende
myErrorExit:
Exit Sub
'Fehlerbehandlung starten
myErrorHandler:
Select Case Err
Case 58
Qe = MsgBox("Die Datei "" " & myFile & " "" mit dem neuen Namen: "" " & tarName & _
" "" existiert bereits im Folder " & tarPath & Chr$(13) & _
"Soll das Makro abgebrochen werden ?" & Chr$(13) & _
"Bei NEIN wird versucht die restlichen Dateien zu verschieben ?! ", _
vbCritical + vbYesNoCancel, "Doppelte Datei")
If Qe = vbYes Then
MsgBox "Makro wird abgebrochen"
Resume myErrorExit
Exit Sub
End If
Case Else
MsgBox Err.Number & ": " & Err.Description, vbCritical + vbOKOnly, "Unerwarteter Fehler > Abbruch File-Move Action"
Resume myErrorExit
End Select
End Sub
Habe das ganze mal mehrfach mit ein paar hundert Dateien probiert und funktioniert problemlos.
Gruss Rainer