Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1132to1136
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Hallo Sepp, Speichern verhindern bei Konflikt

Hallo Sepp, Speichern verhindern bei Konflikt
Dietmar
Hallo Sepp,
ich habe Deinen Code mal mit meiner Idee angepasst, aber es funktioniert so noch nicht.
Was ist suche ist folgendes:
- User öffnet die Datei1
- Es erfolgt dann auch immer eine Zwangsspeicherung unter C:\OrdnerXY\Datei 1 (damit Updates die Datei finden können).
- Nun geht ein User hin und speichert die Datei, sagen wir unter "Datei2" irgendwo ab, denkt sich nichts dabei und schließt die Datei2 dann wieder
- Einige Zeit später arbeitet er (so wie es sein soll) mit Datei 1 weiter, die dadurch ja hinsichtlich des Änderungsdatums aktueller wird; dann schließt er die Datei wieder usw.
- Eines Tages kommt er auf die Idee seine unter "Datei2" gespeicherte Version zu öffnen, wo ja aufgrund des Makros die Zwangsspeicherung abläuft). NUN soll die Warnung erscheinen
Könntest Du den Code nochmals in diese Denkrichtung checken ?
Herzlichen Dank!
Viele Grüße
Dietmar aus Aachen
Danke für Deine Hilfe
Option Explicit
Const cstrSaveAsName As String = "C:\OrdnerXY\datei1.xls"
Private Sub Workbook_Open()
If Dir("C:\OrdnerXY\datei1.xls", vbDirectory) = "" Then
MsgBox "Ihr Abrechnungsprogramm wird wie folgt gespeichert: C:\OrdnerXY\datei1.xls",  _
vbInformation, "Hinweis"
Else
End If
Application.DisplayAlerts = False   'Nachfrage ausschalten
ActiveWorkbook.SaveAs Filename:="C:\OrdnerXY\datei1.xls"
Application.DisplayAlerts = True    'Nachfrage einschalten
Dim bSave As Boolean
bSave = True
If Dir(cstrSaveAsName) = "C:\OrdnerXY\datei1.xls" Then
If checkFileTime(cstrSaveAsName, Me.FullName) Then
bSave = MsgBox("Die Datei die Sie speichern wollen, ist älter" & vbLf & _
"als die bereits vorhandene Datei!" & vbLf & vbLf & "Wollen Sie" & _
" trotzdem fortsetzen?", vbInformation + vbYesNo + vbDefaultButton2, _
"Hinweis") = vbYes
End If
End If
If bSave Then
Application.DisplayAlerts = False
Me.SaveAs cstrSaveAsName
Application.DisplayAlerts = True
End If
End Sub

Private Function checkFileTime(ByVal strOldFile As String, ByVal strNewFile As String) As  _
Boolean
Dim objFSO As Object, objFile As Object
Dim dblOldFTime As Double, dblNewFTime As Double
If Dir(strOldFile) = "" Then Exit Function
If Dir(strNewFile) = "" Then Exit Function
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile(strOldFile)
dblOldFTime = objFile.DateLastModified
Set objFile = objFSO.GetFile(strNewFile)
dblNewFTime = objFile.DateLastModified
checkFileTime = dblOldFTime > dblNewFTime
Set objFile = Nothing
Set objFSO = Nothing
End Function

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Hallo Sepp, Speichern verhindern bei Konflikt
03.02.2010 08:08:51
Josef
Hallo Dietmar,

na dann ein neuer Versuch.

' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Const cstrSaveAsName As String = "C:\OrdnerXY\datei1.xls"

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Dim strFile As String
  If SaveAsUI Then
    Application.EnableEvents = False
    If Dir(cstrSaveAsName) <> "" Then
      Cancel = True
      strFile = _
        Application.GetSaveAsFilename(FileFilter:="Excel Dateien (*.xls; *.xlsx; *.xlsm)," _
        & "*.xls; *.xlsx; *.xlsm")
      
      If strFile = CStr(False) Then GoTo ErrExit
      If strFile = cstrSaveAsName Then
        If checkFileTime(Me.FullName, strFile) Then
          If MsgBox("Die Datei die Sie speichern wollen, ist älter" & vbLf & _
            "als die bereits vorhandene Datei!" & vbLf & vbLf & _
            "Wollen Sie trotzdem fortsetzen?", vbInformation + vbYesNo + _
            vbDefaultButton2, "Hinweis") = vbYes Then
            Me.SaveAs strFile
          End If
        Else
          Me.SaveAs strFile
        End If
      Else
        Me.SaveAs strFile
      End If
    End If
  End If
  ErrExit:
  Application.EnableEvents = True
End Sub

Private Sub Workbook_Open()
  If Dir(cstrSaveAsName, vbDirectory) = "" Then
    MsgBox "Ihr Abrechnungsprogramm wird wie folgt gespeichert: " & _
      cstrSaveAsName, vbInformation, "Hinweis"
    Me.SaveAs cstrSaveAsName
  End If
End Sub


Private Function checkFileTime(ByVal strOldFile As String, ByVal strNewFile As String) As _
    Boolean

  Dim objFSO As Object, objFile As Object
  Dim dblOldFTime As Double, dblNewFTime As Double
  
  If Dir(strOldFile) = "" Then Exit Function
  If Dir(strNewFile) = "" Then Exit Function
  
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  
  Set objFile = objFSO.GetFile(strOldFile)
  dblOldFTime = objFile.DateLastModified
  
  Set objFile = objFSO.GetFile(strNewFile)
  dblNewFTime = objFile.DateLastModified
  
  checkFileTime = dblOldFTime < dblNewFTime
  
  Set objFile = Nothing
  Set objFSO = Nothing
End Function

Gruß Sepp

Anzeige
Hallo Sepp, ja fast perfekt
03.02.2010 09:30:15
Dietmar
Guten Morgen Sepp,
das ist schon super!
Damit könnte ich auch gut klarkommen. Was jetzt gut funktioniert ist, dass die Datei 2 (wenn sie die ältere ist) die Datei 1 nicht überschreibt. Sie wird stattdessen als Datei 2 geöffnet.
Was noch nicht funktioniert ist, dass die Warnmeldung mit der anschließenden Auswahlmöglichkeit, die Speicherung als Datei1 dennoch zu zu lassen.
Aber wie gesagt, wenns zu aufwändig wäre: ich käme auch damit gut klar; nur dass dann die ganze Prozedur in Richtung Warnmeldung überflüssig wäre.
Danke für die tolle Hilfe!
Viele Grüße aus Aachen
Dietmar
Anzeige
AW: Hallo Sepp, ja fast perfekt
03.02.2010 11:06:40
Josef
Hallo Dietmar,

ein anderer Ansatz, immer wenn eine Datei die nicht den festgelegten Namen hat unter dem hinterlegten Namen gespeichert werden soll, wird der Dialog, ob überschrieben werden soll oder nicht, eingeblendet, das scheint mir der sicherste Weg zu sein.

' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Const cstrSaveAsName As String = "C:\OrdnerXY\datei1.xls"

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Dim strFile As String, dblT() As Double
  If SaveAsUI Then
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    If Dir(cstrSaveAsName) <> "" Then
      Cancel = True
      strFile = _
        Application.GetSaveAsFilename(FileFilter:="Excel Dateien (*.xls; *.xlsx; *.xlsm)," _
        & "*.xls; *.xlsx; *.xlsm")
      
      If strFile = CStr(False) Then GoTo ErrExit
      If strFile = cstrSaveAsName And Me.FullName <> cstrSaveAsName Then
        dblT = checkFileTime(Me.FullName, strFile)
        If MsgBox("Soll die Datei" & "'" & vbLf & strFile & CDate(dblT(0)) & "'" & vbLf & _
          vbLf & "durch" & vbLf & "'" & Me.FullName & CDate(dblT(1)) & "'" & vbLf & vbLf & _
          "Ersetzt werden?", vbQuestion + vbYesNo, "Hinweis") = vbYes Then
          Me.SaveAs strFile
        End If
      Else
        Me.SaveAs strFile
      End If
    End If
  End If
  ErrExit:
  Application.EnableEvents = True
  Application.DisplayAlerts = True
End Sub

Private Sub Workbook_Open()
  If Dir(cstrSaveAsName, vbDirectory) = "" Then
    MsgBox "Ihr Abrechnungsprogramm wird wie folgt gespeichert: " & _
      cstrSaveAsName, vbInformation, "Hinweis"
    Me.SaveAs cstrSaveAsName
  End If
End Sub


Private Function checkFileTime(ByVal strOldFile As String, ByVal strNewFile As String) As _
    Variant

  Dim objFSO As Object, objFile As Object
  Dim dblOldFTime As Double, dblNewFTime As Double
  Dim dblTime(1) As Double
  
  If Dir(strOldFile) = "" Then Exit Function
  If Dir(strNewFile) = "" Then Exit Function
  
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  
  Set objFile = objFSO.GetFile(strOldFile)
  dblOldFTime = objFile.DateLastModified
  
  Set objFile = objFSO.GetFile(strNewFile)
  dblNewFTime = objFile.DateLastModified
  
  dblTime(0) = dblOldFTime
  dblTime(1) = dblNewFTime
  checkFileTime = dblTime
  
  Set objFile = Nothing
  Set objFSO = Nothing
End Function

Gruß Sepp

Anzeige
Danke Sepp > Perfektissimo!
03.02.2010 11:41:26
Dietmar
Hallo Sepp,
das ist absolut spitze!
Mein Respekt vor Deinen Kenntnissen wächst mit jeder Nachfrage :-)
Und dann muss ich einfach mal wieder sagen: Danke für Deine scheinbar grenzenlose Geldud!
Viele Grüße
Dietmar aus Aachen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige