Progressbar
13.08.2005 10:03:02
Rene
Ich weiss das diese Frage schon mehrmals gestellt wurde, aber leider komm ich auch damit nicht weiter. Hier nun mal mein Problem.
Ich habe diesen Code:
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:\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 Rename_and_MoveFiles()
'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
'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 ' .FileType = msoFileTypeAllFiles
.FileName = "*.dqm"
.Execute
dqmCount = .FoundFiles.Count
'ermitteln der Anzahl von *.ps - Files im Zielordner
.NewSearch
.LookIn = tarPath
.SearchSubFolders = False ' .FileType = msoFileTypeAllFiles
.FileName = "*.ps"
.Execute
psCount = .FoundFiles.Count
End With
'Move Schleife starten
Set myFld = myFSO.GetFolder(BaseFolder)
'Zuweisung der Dateien in diesem Ordner
Set myFldFiles = myFld.Files
For Each myFile In myFldFiles
tmpName = myFile.name
'Andere Files vom Kopiervorgang ausschliessen
If Right(tmpName, 3) = "dqm" Or Right(tmpName, 2) = "ps" 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 "" und "" " & Chr$(13) & _
psCounter & " ps "" 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
Resume MoveRestart
Case Else
MsgBox Err.Number & ": " & Err.Description, vbCritical + vbOKOnly, "Unerwarteter Fehler > Abbruch File-Move Action"
Resume myErrorExit
End Select
End Sub
Der klappt auch prima da es aber sehr lange dauert wollte ich gerne ein Progressbar mit einbinden.Nun habe ich diesen Code hier gefunden:
Modul:
' macros written 25. november 1998 by Ole P. Erlandsen, ope@edc.bizhosting.com
Option Explicit
Sub ShowDialog()
Load ProgressDlg
ProgressDlg.Show
End Sub
Sub Main()
Dim i As Long, max As Long
max = 1005000
ProgressDlg.Caption = "In Arbeit,bitte warten..."
For i = 1 To max
If i Mod 5 = 0 Then ProgressBar i / max
' do something
Next i
Unload ProgressDlg
End Sub
Sub ProgressBar(PctDone As Single)
With ProgressDlg
.lblDone.Width = PctDone * (.lblRemain.Width - 2)
.lblPct.Caption = Format(PctDone, "0%")
End With
'The DoEvents statement is responsible for the form updating
DoEvents
End Sub
Userform:
Private Sub UserForm_Activate()
Call Main
End Sub
Private Sub UserForm_Initialize()
With Me.lblDone ' set the "progress bar" to it's initial length
.Top = Me.lblRemain.Top + 1
.Left = Me.lblRemain.Left + 1
.Height = Me.lblRemain.Height - 2
.Width = 0
End With
End Sub
Habe bei diesem Code nur das genommen was für mich interessant ist (original sind noch zwei weitere)
Nun weiß ich aber leider nicht wo ich das in dem meinem Modul einbinden muß,das der Balken solange läuft bis mein Macro zu Ende ist.Die Zeit ist kein Problem wenn ich den Code einfüge läuft der Balken und wenn dieser Ende ist dann führt es erst mein Macro aus.Wenn es aber machbar ist wollte ich es so haben das Balken läuft und im Hintergrund mein Macro läuft.
Ich hoffe ich habe mich verständlich ausgedrückt und es kann mir jemand helfen.
Danke Gruß Rene