Re: Änderungen in Echtzeit anzeigen
01.04.2003 15:15:37
ChrisL
Hallo FrankVielleicht findest du in der Recherche unter MultiUserEditing etwas brauchbares.
https://www.herber.de/cgi-bin/searchstruct.pl?begriff=MultiUserEditing
Ansonsten hätte ich noch folgende Idee. Je nach Aufbau der Datei kannst du die Daten evtl. in ein Userform (z.B. Listbox) in einer anderen Datei (ReadOnly) laden. Das Laden erfolgt in dem das Makro die andere Datei öffnet, Daten entnimmt und automatisch wieder schliesst. In der Recherche gibt es Beispiele, um vorher zu prüfen, ob die Datei bereits geöffnet ist. Da der Ladevorgang aber nur wenige Sekunden dauert, sollte es nicht zu oft vorkommen, dass die Datei bereits geöffnet ist. Ich habe hier zusätzlich mal einen Code abgeändert, der wenn die Datei besetzt ist automatisch ein Paar Sekunden wartet, dann erneut probiert etc.
Function DateiIstFrei(ByVal sDateiname As String) As Boolean
'Funktion zur Überpfüfung, ob Datei bereits geöffnet
Dim hFile As Integer
On Error Resume Next
hFile = FreeFile()
Open sDateiname For Random Access Read Lock Read Write As #hFile
If Err Then
DateiIstFrei = False
Else
DateiIstFrei = True
End If
Close #hFile
End Function
Sub oeffnen()
Dim newHour As Date, newMinute As Date, newSecond As Date, WaitTime As Date
Dim i As Integer
Application.Cursor = xlWait
Application.ScreenUpdating = False
Besetzt = False
If DateiIstFrei(DBPfad) = True Then
Workbooks.Open DBPfad
Exit Sub
Else
'1. Datei ist besetzt, deshalb 3 Sekunden warten und erneut testen
newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 3
WaitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait WaitTime
'2. Erneut prüfen, falls besetzt 5 Sekunden warten
If DateiIstFrei(DBPfad) = True Then
Workbooks.Open DBPfad
Exit Sub
Else
newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 5
WaitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait WaitTime
'3. Versuch und sonst abbrechen
If DateiIstFrei(DBPfad) = True Then
Workbooks.Open DBPfad
Exit Sub
Else
MsgBox "Fehler: Die Datenbank konnte nicht geöffnet werden, da bereits durch einen anderen User in Bearbeitung."
Application.Cursor = xlDefault
Besetzt = True
Application.ScreenUpdating = True
Exit Sub
End If
End If
End If
End Sub
Sub DB1oeffnen()
DBPfad = "C:\Test.xls"
Call oeffnen
If Besetzt = True Then Exit Sub
End Sub
Ob es anderst nicht besser ginge kann ich nicht sagen, aber vielleicht gibt es dir ein paar Ideen.
Gruss
Chris