Hier der Code
02.08.2005 11:26:37
Manhartm
Hier noch der ganze Code
Public
Sub Aktualisieren(ByVal lblProgress As MSForms.Label, _
ByVal lblProgressTxt As MSForms.Label, _
ByVal fraProgress As MSForms.Frame, _
ByVal lblProgress2 As MSForms.Label, _
ByVal lblProgressTxt2 As MSForms.Label, _
ByVal lblProgressTxt3 As MSForms.Label, _
ByVal lblProgressTxt4 As MSForms.Label, _
ByVal lblProgressTxt5 As MSForms.Label, _
ByVal lblProgressTxt6 As MSForms.Label, _
ByVal fraProgress2 As MSForms.Frame)
' Generieren der Zusammenfassung (Cockpit) In/Out/Event
Dim t As Long
t = Timer
Dim fs, pfad1, name1, pfad2, name2, I, III, nCellsCnt, nRowsMax, nRowsMax2, dblProgress, dblProgress2
Dim Verz(60)
Dim Dateien(500)
Dim Markierbereich, AnzahlZeilen, LetzteZeile, AktuelleZeile, AktuelleSpalte
Dim Merker1, Merker2, Z1, Z2, Pruefung
Dim Kennwort, KWort, MailWort
Kennwort = "******"
MailWort = "ja"
KWort = InputBox("VB-SCRIPT PROGRAMMING:" & Chr(10) & "DM-Planning-Team" & Chr(10) & Chr(10) & _
" Bitte deaktivieren Sie jetzt als erstes, die Antivirensoftware! " & Chr(10) _
& " Rechte Maustaste auf Tasksymbol des Virenprogramms, " & Chr(10) & " Snooze auf 10 Minuten einstellen. " & _
Chr(10) & Chr(10) & "Geben Sie anschliessend bitte das" & Chr(10) & "Kennwort für den Start ein!")
If KWort <> Kennwort Then
MsgBox "SORRY" & Chr(10) & "Sie haben ein falsches Kennwort eingegeben"
End
End If '
Set fs = Application.FileSearch
With Application
.Calculation = xlManual
End With
Grundstellung
Application.AutoRecover.Enabled = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'lblProgressTxt.ForeColor = vbBlack
AktuelleZeile = 8
LetzteZeile = Range("A9").CurrentRegion.Rows.Count + 8
Markierbereich = "9:" & LetzteZeile
Rows(Markierbereich).Delete Shift:=xlUp
' pfad1 = "J:\AKTIONEN\AKTIONEN2005\"
Application.ScreenUpdating = False
pfad1 = Cells(2, 6)
name1 = Dir(pfad1, vbDirectory) ' Ersten Eintrag abrufen.
I = 0
Z1 = 0
Z2 = 0
Merker2 = ActiveWorkbook.Name
Sheets("Zusammenfassung").Range("J3").Value = Merker2
Do While name1 <> "" ' Schleife beginnen.
' Aktuelles und übergeordnetes Verzeichnis ignorieren.
If name1 <> "." And name1 <> ".." Then
' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein
' Verzeichnis ist.
If (GetAttr(pfad1 & name1) And vbDirectory) = vbDirectory Then
'Eintrag nur verwenden, wenn es sich um ein Verzeichnis handelt
I = I + 1
Verz(I) = name1
End If
End If
name1 = Dir ' Nächsten Eintrag abrufen.
Loop
With fs
.LookIn = pfad1
.SearchSubFolders = True
.Filename = "*.xls"
If .Execute > 0 Then
nRowsMax = .FoundFiles.Count
End If
End With
III = nRowsMax
lblProgressTxt4.Caption = nRowsMax
Application.ShowWindowsInTaskbar = False
Do While I > 0
'Zähler rückstellen für Statusbar2
nRowsMax2 = 0
name2 = Verz(I)
pfad2 = pfad1 & name2 & "\"
name1 = Dir(pfad2, vbNormal)
Do While name1 <> "" ' Schleife beginnen.
' Aktuelles und übergeordnetes Verzeichnis ignorieren.
If name1 <> "." And name1 <> ".." Then
' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein Verzeichnis ist.
If (GetAttr(pfad2 & name1) And vbDirectory) <> vbDirectory Then
' Eintrag nur verwenden, wenn es sichum ein Verzeichnis handelt.
'On Error GoTo OpenWS
'--- Code-Beginn für Fortschrittsleiste ---
'dblProgress berechnen:
dblProgress = (nRowsMax - III) / nRowsMax
If dblProgress > 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 ---
'--- Code-Beginn für Fortschrittsleiste2 ---
If Z2 < 1 Then
With fs
.LookIn = pfad2
.SearchSubFolders = True
.Filename = "*.xls"
If .Execute > 0 Then
nRowsMax2 = .FoundFiles.Count
III = III - Z1
Z2 = nRowsMax2
Z1 = Z2
End If
lblProgressTxt3.Caption = nRowsMax - III
End With
lblProgressTxt2.ForeColor = vbBlack
lblProgressTxt6.Caption = nRowsMax2
End If
'dblProgress2 berechnen:
dblProgress2 = (nRowsMax2 - Z2) / nRowsMax2
If dblProgress2 > 0.45 Then
lblProgressTxt2.ForeColor = vbWhite
End If
'Prozent-Angaben auf Label2 aktualisieren
lblProgressTxt2.Caption = Format(dblProgress2, "0 %")
'Breite des Labels2 aktualisieren
lblProgress2.Width = dblProgress2 * (fraProgress2.Width)
'Anzeige auf UserForm aktualisieren
DoEvents
Z2 = Z2 - 1
lblProgressTxt5.Caption = nRowsMax2 - Z2
End If
'--- Code-Ende für Fortschrittsleiste2 ---
Workbooks.Open Filename:=pfad2 & name1, ReadOnly:=True, UpdateLinks:=0
If Workbooks(name1).Sheets(1).Range("T1").Value <> "Meldeblatt Aktionen/EinAusl" Then
' falls kein Aktionexcel gleich wieder schliessen
' Workbooks.Close
Workbooks(name1).Close (False)
Else
'Hier Daten ab Aktionsexcel
'Dies ist er Update-Script Bereich, hier sollte das Script stehen
End If
End If
name1 = Dir() ' Nächsten Eintrag abrufen.
Loop
I = I - 1
Loop
lblProgressTxt5.Caption = nRowsMax2 - Z2
lblProgressTxt3.Caption = nRowsMax - III
DoEvents
Application.ShowWindowsInTaskbar = True
' Abschliessen des Makro mit Aktivierung der Zelle A1
'Workbooks(Merker2).Sheets("Zusammenfassung").Cells(2, 10) = ""
Application.AutoRecover.Enabled = False
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveSheet.Range("J5").Value = Now ', "mm:hh:ss"
ActiveSheet.Range("M5").Value = Format((Timer - t) / 86400, "hh:mm:ss")
ActiveSheet.Range("N5").Value = Application.UserName
Sheets("Zusammenfassung").Select
Range("A1").Select
MsgBox Format((Timer - t) / 86400, "hh:mm:ss")
ThisWorkbook.Save
End Sub
