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:\DQM\LastFolder.ini"
'Einstellungen der letzten Ordner werden in diesen
'INI-Section's gespeichert
Private Const LastFolder As String = "LastFolder"
Private Const BaseFolder As String = "C:\DQM\Messung"
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 Schleife_Start()
frmProgress.Show
End Sub
Sub Rename_and_MoveFiles(ByVal lblProgress As MSForms.Label, _
ByVal lblProgressTxt As MSForms.Label, _
ByVal fraProgress As MSForms.Frame, _
ByVal lblProgressTxt3 As MSForms.Label, _
ByVal lblProgressTxt4 As MSForms.Label, _
ByVal lblProgressTxt5 As MSForms.Label)
'Verschiebt alle DQM und PS Dateien in einem Ordner
'in einen Zielordner und nummeriert diese neu
'Die Einstellungen BaseFolder und LastFolder werden in einer INI-Datei gespeichert
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
Dim CounterTotal, TotalCount As Integer
Dim dblProgress As Long
frmProgress.Caption = "In Arbeit,bitte warten...."
'ErrorHandler starten
On Error GoTo myErrorHandler
'Erstellen des FileSystemObjectes
Set myFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
'Zielordner auswählen
NewTargetPath:
Set objFolder = objShell.BrowseForFolder(0&, "Ziel Ordner auswählen..." & Chr$(13) & _
"ABBRECHEN um neuen Zielordner im Basisverzeichnis: """ & BaseFolder & """ zu erstellen.", 1&, _
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
'Prüfung ob Quell und Zielordner gleich sind
If BaseFolder = tarpath Then
Qe = MsgBox("Der Quell- und der Zielpfad sind gleich." & Chr$(13) & _
"Neuen Ordner auswählen ?", vbCritical + vbYesNo, "Abbruch ?")
If Qe = vbNo Then
Exit Sub
Else
GoTo NewTargetPath
End If
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 ' 0.45 Then
lblProgressTxt.ForeColor = vbWhite
End If
'Prozent-Angaben auf Label aktualisieren
lblProgressTxt.Caption = Format(dblProgress, "0 %")
'Breite des Labels aktualisieren
lblProgress.Width = dblProgress * (fraProgress.Width)
'Anzeige auf UserForm aktualisieren
DoEvents
'--- Code-Ende für Fortschrittsleiste ---
Next
'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 Ordner " & 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
Resume MoveRestart
Case Else
MsgBox Err.Number & ": " & Err.Description, vbCritical + vbOKOnly, "Unerwarteter Fehler > _
Abbruch File-Move Action"
Resume myErrorExit
End Select
End Sub
Gruß Rene