Hallo Franz,
heut nun der Test im Original
Respektive in der Kopie des Originals
Der Aufbau entspricht der gestrigen Testversion. Nur hier heißen die Dateien P1 und WZ Stammdaten.
Folgendes passiert:
P1 löschen: Excel Fehlermeldung Weiter nichts passiert mehr (des nachfolgende Makro funktioniert natürlich dann nicht, da die Datei ja fehlt)
irgendwas fehlt hier noch... hier müsste eigentlich auch die MessageBox kommen das die Datei bzw der Aufbau fehlerhaft ist und eine Nachricht an mich erfolgen sollte?!
In der Formel den Pfad ändern: Excel Fehlermeldung Weiter MessageBox Ok klicken Formel ist korrigiert Datei funktioniert tadellos - echt super
In der Formel den Dateinamen ändern: MessageBox Datei inkorrekt Ok klicken Datei schließt sich jetzt kommt die Excel Fehlermeldung Weiter nichts passiert mehr (Datei ist ja schon geschlossen)
Hier müsste nur noch die Excel Fehlermeldung am Ende noch verhindert werden - sonst super
Bei Neustart der Datei dasselbe Bild. MessageBox, Datei schließt sich
Speichern unter MessageBox Ok funktioniert prima
Was mir auffiel die F8 Funktion lässt sich nur in dem Bereich Sub Workbook Open durchführen. Ist das so? Bzw soll das so sein?
Ich habe mich auch gleich mal an das Problem mit der schon geöffneten Datei gemacht. Hab den Link den du mir geschickt hast geprüft und den Code mit eingebaut.
Leider funktioniert das bei mir nicht so schön.
In dem Text steht der Hinweis, dass der Code nicht bei gesperrten Arbeitsblättern funktioniert. Dies konnte ich nicht testen bis dahin bin ich nicht gekommen. Beim F8 durchlauf bleibt er in der Zeile
#If Not VBA6 Then
Hängen. Dort kommt die Fehlermeldung Laufzeitfehler `6`: Überlauf
Ich hab die Stelle im Code markiert.
Was will das mir sagen? Was kann ich da tun?
Ich habe den kompletten Code mal unten angehangen vielleicht hab ich ja was vermasselt beim basteln? Kannst du bitte mal drüber schauen?
LG bassi
Option Explicit
'Makro unter "DieseArbeitsmappe" in den Dateien mit Verknüpfungen
Private bolCloseAutomatic As Boolean 'Variable zur Steuerung des Speicherns vor dem Schliessen
' Verzeichnis der Dateien
Private Const strPfad As String = "G:\boninfo\VTest"
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If bolCloseAutomatic = True Then Exit Sub 'Bei Problemen mit den Verküpfungen _
oder Speicherort wird Datei ohne Speichern geschlossen
'Immer speichern vor dem schliessen - ggf. weitere Aktionen
Me.Save
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If SaveAsUI = True Then
MsgBox "Diese Datei " & vbLf & _
Me.FullName & vbLf & _
"darf nicht per ""Speichern unter"" - Dialog gespeichert werden!", _
vbInformation + vbOKOnly, "Hinweis - Speichern unter"
Cancel = True
Else
If LCase(Me.Path) LCase(strPfad) Then
'Durch die Prüfung des Pfads beim Öffnen der Datei sollte dieser Weg _
eigentlich nicht vorkommen
Cancel = True
bolCloseAutomatic = True
MsgBox "Diese Datei darf nur gespeichert werden, wenn sie sich im Verzeichnis" _
& vbLf & strPfad & vbLf & "befindet!" & vbLf & vbLf _
& "Aktuelles Verzeichnis der Datei:" & vbLf _
& Me.Path & vbLf & vbLf _
& "Bitte Datei schliessen oder normal Speichern!", _
vbInformation + vbOKOnly, "Prüfung Dateiverzeichnis"
End If
End If
End Sub
Private Sub Workbook_Open()
'Prüfen der verknüpften Dateien
Dim varItem, intIndex As Integer
Dim arrFiles(1 To 2) As String, strDatei As String, strVerzeichnis As String
Dim bolKorrekt As Boolean
'Namen der verknüpften Dateien
arrFiles(1) = "P1.xls"
arrFiles(2) = "WZ Stammdaten.xls"
'Prüfung ob Datei aus dem korrekten Verzeichnis geöffnet wurde
If LCase(Me.Path) LCase(strPfad) Then
MsgBox "Bitte nur Datei """ & Me.Name & """ im Verzeichnis """ & strPfad _
& """ öffnen" & vbLf & vbLf _
& "Datei wird automatisch wieder geschlossen!"
bolCloseAutomatic = True
Me.Close savechanges:=False
Else
'Prüfen/Korrigieren der Verknüpfungen
varItem = Me.LinkSources(Type:=xlExcelLinks) 'Wert=Leer wenn keine Verknüpfungen vorhanden
If IsEmpty(varItem) Then
MsgBox "Keine Formeln mit Verküpfungen vorhanden in der Datei " & vbLf & Me.FullName, _
vbInformation + vbOKOnly, "Prüfung Verknüpfungen"
Else
For Each varItem In Me.LinkSources(Type:=xlExcelLinks)
strDatei = Mid(varItem, InStrRev(varItem, Application.PathSeparator) + 1)
strVerzeichnis = Left(varItem, InStrRev(varItem, Application.PathSeparator) - 1)
'Dateiname prüfen durch Vergleich mit Liste
bolKorrekt = False
For intIndex = 1 To 2
If LCase(strDatei) = LCase(arrFiles(intIndex)) Then
bolKorrekt = True
Exit For
End If
Next intIndex
If bolKorrekt = True Then
'Verzeichnisse vergleichen
If LCase(strPfad) LCase(strVerzeichnis) Then
'Link korrigieren
Me.ChangeLink Name:=varItem, _
NewName:=strPfad & Application.PathSeparator & strDatei, Type:=xlExcelLinks
MsgBox "Falsche Verküpfung """ & varItem & """ wurde korrigiert"
End If
Else
MsgBox "Verknüpfung """ & varItem & " verweist auf inkorrekte Datei!" & vbLf & vbLf _
& "Bitte XYZ (Tel. 1234) informieren" & vbLf & vbLf _
& "Datei wird automatisch wieder geschlossen!"
bolCloseAutomatic = True
Me.Close savechanges:=False
End If
Next varItem
End If
End If
End Sub
Private Sub TestVBA()
'// Just change the file to test here
Const strFileToOpen As String = "G:\boninfo\VTest\WZ Stammdaten.xls"
If IsFileOpen(strFileToOpen) Then
MsgBox strFileToOpen & " is already Open" & _
vbCrLf & "By " & LastUser(strFileToOpen), vbInformation, "File in Use"
Else
MsgBox strFileToOpen & " is not open", vbInformation
End If
End Sub
Private Function IsFileOpen(strFullPathFileName As String) As Boolean
'// VBA version to check if File is Open
Dim hdlFile As Long
'// Error is generated if you try
'// opening a File for ReadWrite lock >> MUST BE OPEN!
On Error GoTo FileIsOpen:
hdlFile = FreeFile
Open strFullPathFileName For Random Access Read Write Lock Read Write As hdlFile
IsFileOpen = False
Close hdlFile
Exit Function
FileIsOpen:
'// Someone has it open!
IsFileOpen = True
Close hdlFile
End Function
Private Function LastUser(strPath As String) As String
Dim strXl As String
Dim strFlag1 As String, strflag2 As String
Dim i As Integer, j As Integer
Dim hdlFile As Long
Dim lNameLen As Byte
strFlag1 = Chr(0) & Chr(0)
strflag2 = Chr(32) & Chr(32)
hdlFile = FreeFile
Open strPath For Binary As #hdlFile
strXl = Space(LOF(hdlFile))
Get 1, , strXl
Close #hdlFile
j = InStr(1, strXl, strflag2)
'hier stopt das
#If Not VBA6 Then
'// Xl97
For i = j - 1 To 1 Step -1
If Mid(strXl, i, 1) = Chr(0) Then Exit For
Next
i = i + 1
#Else
'// Xl2000+
i = InStrRev(strXl, strFlag1, j) + Len(strFlag1)
#End If
'// IFM
lNameLen = Asc(Mid(strXl, i - 3, 1))
LastUser = Mid(strXl, i, lNameLen)
End Function