Nochmal: Datei speichern - Hilfe!!!!

Moin Leute!

Hab bisher keine Vernünftige Lösung für mein Problem!

Hier nochmal die Frage:

Mit folgender Funktion will ich verhindern, daß die Datei unter "Dateiname" gespeichert wird! Leider kommt bei der Eingabe eben dieses Namens lediglich das zur Speicherung gehörende Fenster "Datei existiert bereits! Soll sie überschrieben werden?usw..." Mit Schreibschutz kann ich nicht arbeiten, da SetAttrib laut Excel- Hilfe nur bei geschlossenen Dateien funktioniert, ich jedoch diesen wahlweise ein - oder ausschalten können müßte, deshalb der Code:

On Error Resume Next
Select Case MsgBox("Sie haben nicht die Berechtigung, die Datei unter dem Originalnamen zu speichern! Wollen sie sie unter einem anderen Namen sichern?", vbYesNo)
Case vbYes
Do
fname = Application.GetSaveAsFilename("DateinameKopie.xls", "Microsoft Excel-Arbeitsmappe (*.xls), *xls")
Loop Until fname <> False And fname <> "Dateiname.xls"
ActiveWorkbook.SaveAs fname
End Select

Kann mir jemand helfen? Ist die Loop- Anweisung oder das Format des Dateinamens evtl. falsch? Bin echt verzweifelt!!!

MfG Madman

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Madman

Problem ist, dass fname den gesamten Pfad enthält, du aber nur den Dateinamen überprüfst. In XL2000 wäre es mit InstrRev lösbar, aber ich habe dir nachstehend eine Versionen-unabhängige Variante.

Anstatt die berechtigten User mit einem Passwort abzufragen, schlage ich dir vor mit Environ direkt den Windows Benutzername abzufragen:

Option Explicit


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim fName As Variant, ffName As String, MsgBoxAntwort As Variant
Dim Vorschlag As String
If Environ("Username") <> "DEIN-WINDOWS-BENUTZERNAME" Then
On Error GoTo ErrorHandler
Cancel = True
Vorschlag = "DateinameKopie.xls"
Start:
fName = Application.GetSaveAsFilename(Vorschlag, "Microsoft Excel-Arbeitsmappe (*.xls), *xls")
If fName = False Then Exit Sub
ffName = fName
Do Until InStr(ffName, "\") = 0
ffName = Right(ffName, Len(ffName) - InStr(ffName, "\"))
Loop
If ffName = "Dateiname.xls" Then
MsgBoxAntwort = MsgBox("Sie haben nicht die Berechtigung, die Datei unter dem Originalnamen zu speichern! Wollen sie sie unter einem anderen Namen sichern?", vbYesNo)
If MsgBoxAntwort = vbNo Then
Exit Sub
Else
GoTo Start
End If
End If
If Dir(fName) <> "" Then
MsgBoxAntwort = MsgBox("Datei existiert bereits. Wollen Sie die bestehende Datei überschreiben?", vbQuestion + vbYesNo)
If MsgBoxAntwort = vbNo Then GoTo Start
End If
Application.DisplayAlerts = False
Application.EnableEvents = False
ActiveWorkbook.SaveAs fName
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
ErrorHandler:
MsgBox "Fehler: Datei konnte nicht gespeichert werden.", vbCritical
Application.DisplayAlerts = True
Application.EnableEvents = True
End If
End Sub

Gruss
Chris

Beliebteste Forumthreads (12 Monate)

Nochmal: Datei speichern - Hilfe!!!!

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread