Ob Datei schon geöffnet ist

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Private Function DateiGeoeffnet(DerPfad As String) As Boolean ' Bei shared Workbooks, schreibgeschützten Mappen o.ä.. kann dies auch ein falsch zurückgeben. On Error Resume Next Open DerPfad For Binary Access Read Lock Read As #1 Close #1 If Err.Number 0 Then DateiGeoeffnet = True Err.Clear End If End Function

Hallo,
ich würde es in etwa so angehen.

Sub Beispiel_()
Dim strFullname$, FileObject As Workbook
'Pfad zur Datei 
strFullname$ = "C:\Ordner\MeineDatei.xls"

Set FileObject = File_Oben(strFullname)

If Not FileObject Is Nothing Then
    'hier kann mit der Datei FileObject gearbeitet werden 
    'Code 
    '... 
    '... 
    '... 
End If
End Sub

Function File_Oben(strFullname$) As Workbook
Dim FileObject As Workbook

'prüfen ob offen 
For Each FileObject In Workbooks
    If FileObject.FullName = strFullname Then
        Set File_Oben = FileObject
        Exit For
    End If
Next FileObject

If File_Oben Is Nothing Then 'Datei nicht geöffnet? 
    'Abfrage ob geöffnet werden soll 
    If MsgBox("Datei ist nicht offen!" & vbCr & "Soll die Datei geöffnet werden?!", _
              vbExclamation + vbYesNo, "Datei öffnen?") = vbYes Then
        'Error Behandlung, z. Bsp. Datei mit selben Namen bereits offen 
        On Error GoTo ErrorH:
            Set File_Oben = Workbooks.Open(strFullname)
            'Datei Schreibgeschützt, Datei war nicht offen 
            If File_Oben.ReadOnly Then
                File_Oben.Close False
                GoTo ErrSchreibschutz
            End If
    End If
Else
    'Datei Schreibgeschützt, bereits geöffnet 
    If File_Oben.ReadOnly Then
        GoTo ErrSchreibschutz
    End If
End If

Exit Function

'Fehlerbehandlungen ***** 
ErrorH:
MsgBox Err.Description, vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
Set File_Oben = Nothing
Exit Function

ErrSchreibschutz:
MsgBox "Datei ist Schreibgeschützt", vbCritical
Set File_Oben = Nothing
End Function

Gruß Tino

Sub Test() MsgBox Offen("c:\test\MeineDatei.xls") End Sub Function Offen(PfadDatei As String) As Boolean Dim wkb As Workbook For Each wkb In Workbooks If wkb.FullName = PfadDatei Then PfadDatei = True Exit For End If Next wkb End Function

Sub Test() MsgBox Offen("c:\test\Beispiel1.xls") End Sub Function Offen(PfadDatei As String) As Boolean Dim wkb As Workbook For Each wkb In Workbooks If UCase(wkb.FullName) = UCase(PfadDatei) Then Offen = True Exit For End If Next wkb End Function

Sub Test() MsgBox Offen("c:\test\Beispiel1.xls") End Sub Function Offen(Datei as String) as Boolean Dim wb As Workbook On Error Resume Next set wb = Workbooks(Datei) on Error Goto 0 Offen = not(wb is Nothing) End Function

Beliebteste Forumthreads (12 Monate)

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread