Controllare se un file excel è già aperto

[ilnonno13]

Buongiorno,

ho una macro che permette di aggiornare determinati dati scritti su un file Excel su un altro file Excel.
Tutto risulta funzionante.

Il problema nasce nel momento in cui file da aggiornare risulta già essere aperto. Ho provato a gestire la cosa con l'istruzione IsFileOpen ma mi da l'errore "Sub o Function non definita".

A parte il fatto non capire il perché dell'errore, c'è un altro modo per poter gestire la situazione?

[scossa]

A parte il fatto non capire il perché dell'errore

IsFileOpen è una funzione che devi "fornire" tu.

..... c'è un altro modo per poter gestire la situazione?

Un modo:

Codice: Seleziona tutto

  'dichiarazioni esistenti
  '..... CUT .........
  Dim wbTo As Workbook

  On Error Resume Next
  Set wbTo = workbooks("nome_del_file_da_aggiornre.xls") '<--- da modificare a coerenza
  On Error GoTo 0
  If wbTo Is Nothing Then
      Set wbTo = Workbooks.Open("C:\Percorso_File\nome_del_file_da_aggiornre.xls") '<--- da modificare a coerenza
  End If
 
  '............. CUT ............
  '....... resto del codice .....
 

Aggiusta nome e percorso del file.

[ilnonno13]

Grazie scossa della tempestiva risposta.

Entro più nello specifico.
Quello che vorrei è far si che nel momento in cui il file risultasse già aperto inserire un ritardo nell'operazione e poi proseguire con il resto del codice.

Il file che serve per aggiornare, in parole povere, apre il file lo aggiorna e subito lo richiude. Tempo 1 secondo.

A me serve che se due utenti aggiornano il file nello stesso momento un piccolo ritardo gestisca il fatto che il file è aperto perché aggiornato dall'altro utente, in modo tale che nessuno si accorge di nulla e che il "database" venga correttamente aggiornato.

[ilnonno13]

Aggiungo che quindi chiaramente il controllo non deve esser fatto sulla propria sessione di lavoro ma sul server dove è posizionato il file.

Set wbTo = workbooks("nome_del_file_da_aggiornre.xls") .... Questa istruzione mi controlla sicuramente se il file risulta aperto nella mia sessione, ma non mi controlla il fatto se è un altro utente a tener aperto il file...

[scossa]

Aggiungo che quindi chiaramente il controllo non deve esser fatto sulla propria sessione di lavoro ma sul server dove è posizionato il file.

Set wbTo = workbooks("nome_del_file_da_aggiornre.xls") .... Questa istruzione mi controlla sicuramente se il file risulta aperto nella mia sessione, ma non mi controlla il fatto se è un altro utente a tener aperto il file...

Un modo (poco elegante) ma funzionante:
1) Apro il file
2) è in sola lettura?
- 2a) Sì -> lo chiudo, rimetto wbTo a Nothing, torno al punto 1)
- 2b) No -> procedo
3) faccio quello che devo

Codice: Seleziona tutto

Public Sub prova()
  Dim wbTo As Workbook

  On Error Resume Next
  With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
  End With
  Do While wbTo Is Nothing
      Set wbTo = Workbooks.Open("Z:\EXCEL\Test\Prova.xlsx") '<--- da modificare a coerenza
      If wbTo.ReadOnly Then
        wbTo.Close
        Set wbTo = Nothing
      End If
  Loop
  On Error GoTo 0
  With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With

  MsgBox "ho aperto il file " & wbTo.Name
 
  Set wbTo = Nothing
End Sub

P.S.: On Error Resume Next si potrebbe eliminare, visto che il file viene aperto comunque ....

[ilnonno13]

Ho provato ad inserire il codide...

Il sistema non riesce a rilevare se il file è effettivamente di solo lettura o meno. Aperto o chiuso dopo un giro di loop il codice va per aprire il file e quindi genera l'errore...

[ilnonno13]

A parte il fatto non capire il perché dell'errore

IsFileOpen è una funzione che devi "fornire" tu.


Non è più semplice riprendere il discorso da qui... Mi sembra il metodo più semplice. Impostare un piccolo ritardo alle operazioni successive se il sistema trova il file già aperto...

EDIT Flash - Eliminato post duplicato e quotato dallo stesso autore

[scossa]

Ho provato ad inserire il codide...

Il sistema non riesce a rilevare se il file è effettivamente di solo lettura o meno. Aperto o chiuso dopo un giro di loop il codice va per aprire il file e quindi genera l'errore...

Non capisco quello che dici, che errore ti genera?
Prova a integrare l'istruzione con il parametro notify:

Codice: Seleziona tutto

Set wbTo = Workbooks.Open("Z:\EXCEL\Test\Prova.xlsx", notify:=false) '<--- da modificare a coerenza

Hai corretto il percorso/nome del file (ovviamente "Z:\EXCEL\Test\Prova.xlsx" è inventato)?

Io quel codice l'ho provato su un file su nas aperto da un'altra postazione, e finché non viene chiuso sul mio pc resta in loop.
Dovresti mostrare tutto il codice che stai usando.

[scossa]

A parte il fatto non capire il perché dell'errore

IsFileOpen è una funzione che devi "fornire" tu.


Non è più semplice riprendere il discorso da qui... Mi sembra il metodo più semplice. Impostare un piccolo ritardo alle operazioni successive se il sistema trova il file già aperto...

EDIT Flash - Eliminato post duplicato e quotato dallo stesso autore

http://www.cpearson.com/excel/ISFILEOPEN.ASPX

[ilnonno13]

Codice: Seleziona tutto

Dim wbTo As Workbook
   
   
    Application.ScreenUpdating = False
   
    Sheets("foglio1").Unprotect

Sheets("DATI").Visible = True
Sheets("DATI").Activate
    Range("A3:Q3").Select
    Selection.Copy

On Error Resume Next
    With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
  End With
  Do While wbTo Is Nothing
  ChDrive "Z"
    Set wbTo = Workbooks.Open("Z:\Scambio\DATABASE\FIRSTDATABASE.xlsm")
    If wbTo.ReadOnly Then
    wbTo.Close
     Set wbTo = Nothing
      End If
  Loop
  On Error GoTo 0
  With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With


Range("X2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
    Range("AP2").Select ' Inizio incremento ID
    ActiveCell.FormulaR1C1 = ActiveCell.FormulaR1C1 + 1
    Range("AP2").Select
    Selection.Copy
    Range("W2").Select
    ActiveSheet.Paste ' Fine incremento ID
   
    Range("W2:AN2").Select
    Selection.Copy
   
    Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
   
    ActiveWorkbook.Save 'Salva
    ActiveWindow.Close ' Chiude
   
    'ChDrive "Z"
    'Perc2 = "Z:\scambio\nuova cartella\"
    'NewPerc2 = "Z:\Segreteria\"
    'NFile2 = "FIRSTDATABASE.xlsm"
    'ChDrive "Z"
    'Name Perc2 & NFile2 As NewPerc2 & NFile2
   
   
    MsgBox ("CONTATTO AGGIUNTO CON SUCCESSO!")
   
   
   
    Sheets("foglio1").Activate     'pulisco i campi di inserimento
    Range( _
        "D24:G24,J24:M24,P24:S24,U24:X24,D28:Q28,S28:AA28,AC28:AD28,D31:M31,Q31,S31:AD31,D34:AD34,D37:R46,W37:AC37,W40:AC40,W46:AC46" _
        ).Select
    Range("W46").Activate
    Selection.ClearContents
    Range("D24:G24").Select
   
    Sheets("foglio1").Protect
   
    Sheets("DATI").Visible = False
   
    Application.ScreenUpdating = True
   

   
 Set wbTo = Nothing
End Sub

[scossa]

Non hai precisato che errore ti da (quale messaggio, su quale riga di codice)!

[ilnonno13]

Tenendo aperto il file da controllare su una postazione diversa e eseguendo il codice passo passo non riesce a controllare se il file é effettivamente aperto, é come se per lui fosse sempre chiuso, quindi va avanti e quando deve salvarlo chiaramente mi dice che é di solo lettura e quindi da errore...

[scossa]

Tenendo aperto il file da controllare su una postazione diversa e eseguendo il codice passo passo

Ma, eseguendo il codice passo-passo, quando arrivi a questa istruzione:

Codice: Seleziona tutto

If wbTo.ReadOnly Then

se PRIMA di eseguirla nella finestra immediata scrivi:

Codice: Seleziona tutto

?wbTo.ReadOnly

cosa ottieni?

[scossa]

Comunque, tagliamo la testa al toro:

Codice: Seleziona tutto

Option Explicit
Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modIsFileOpen
' By Chip Pearson, www.cpearson.com , chip@cpearson.com
' www.cpearson.com/Excel/IsFileOpen.aspx
' This module contains the IsFileOpen procedure whict tests whether
' a file is open.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Function IsFileOpen(FileName As String, Optional ResultOnBadFile As Variant) As Variant
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsFileOpen
' This function determines whether a the file named by FileName is
' open by another process. The fuction returns True if the file is open
' or False if the file is not open. If the file named by FileName does
' not exist or if FileName is not a valid file name, the result returned
' if equal to the value of ResultOnBadFile if that parameter is provided.xd
' If ResultOnBadFile is not passed in, and FileName does not exist or
' is an invalid file name, the result is False.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim FileNum As Integer
Dim ErrNum As Integer
Dim V As Variant

On Error Resume Next

''''''''''''''''''''''''''''''''''''''''''''
' If we were passed in an empty string,
' there is no file to test so return FALSE.
''''''''''''''''''''''''''''''''''''''''''''
If Trim(FileName) = vbNullString Then
    If IsMissing(ResultOnBadFile) = True Then
        IsFileOpen = False
    Else
        IsFileOpen = ResultOnBadFile
    End If
    Exit Function
End If

''''''''''''''''''''''''''''''''''''''''''''
' if the file doesn't exist, it isn't open
' so get out now
''''''''''''''''''''''''''''''''''''''''''''
V = Dir(FileName, vbNormal)
If IsError(V) = True Then
    ' syntactically bad file name
    If IsMissing(ResultOnBadFile) = True Then
        IsFileOpen = False
    Else
        IsFileOpen = ResultOnBadFile
    End If
    Exit Function
ElseIf V = vbNullString Then
    ' file doesn't exist.
    If IsMissing(ResultOnBadFile) = True Then
        IsFileOpen = False
    Else
        IsFileOpen = ResultOnBadFile
    End If
    Exit Function
End If

FileNum = FreeFile()
'''''''''''''''''''''''''''''''''''''''
' Attempt to open the file and lock it.
'''''''''''''''''''''''''''''''''''''''
Err.Clear
Open FileName For Input Lock Read As #FileNum
ErrNum = Err.Number
''''''''''''''''''''
' Close the file.
''''''''''''''''''''
Close FileNum
On Error GoTo 0

''''''''''''''''''''''''''''''''''''''
' Check to see which error occurred.
''''''''''''''''''''''''''''''''''''''
Select Case ErrNum
    Case 0
        ''''''''''''''''''''''''''''''''''''''''''''
        ' No error occurred.
        ' File is NOT already open by another user.
        ''''''''''''''''''''''''''''''''''''''''''''
        IsFileOpen = False
    Case 70
        ''''''''''''''''''''''''''''''''''''''''''''
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        ''''''''''''''''''''''''''''''''''''''''''''
        IsFileOpen = True
    Case Else
        ''''''''''''''''''''''''''''''''''''''''''''
        ' Another error occurred. Assume open.
        ''''''''''''''''''''''''''''''''''''''''''''
        IsFileOpen = True
End Select

End Function




Public Sub prova()
  'dichiarazioni esistenti
  '..... CUT .........
  Dim wbTo As Workbook

  On Error Resume Next
  With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
  End With
  Do While IsFileOpen("Z:\EXCEL\Marketing\Test\Prova.xlsx")
    Application.Wait (Now + TimeValue("0:00:01"))
  Loop
  On Error GoTo 0
  Set wbTo = Workbooks.Open("Z:\EXCEL\Marketing\Test\Prova.xlsx")
  With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With
  MsgBox "ho aperto il file " & wbTo.Name
 
  'Application.DisplayAlerts = True
  '............. CUT ............
  '....... resto del codice .....
  Set wbTo = Nothing
End Sub

Ovviamente sostituisci "Z:\EXCEL\Marketing\Test\Prova.xlsx" a coerenza.

[Zer0Kelvin]

Ciao.
Una versione "molto" semplificata, ma funzionale, è questa

Codice: Seleziona tutto

Public Function fOpenError(filename As String) As Integer
Dim fNum As Integer
    On Error Resume Next
    fNum = FreeFile()
    Open filename For Input Lock Read As #fNum
    Close fNum
    fOpenError = Err
    On Error GoTo 0
End Function

Public Sub TestOpen()
    Select Case fOpenError("Ciccio.xls") ' al posto di Ciccio.xls ci va il PERCORSO COMPLETO del tuo file
        Case 0 ' nessun errore
            MsgBox "Puoi aprire il file"
        Case 70 ' il file è già aperto
            MsgBox "Il file è attualmente in uso"
        Case Else ' altro errore
            MsgBox "Altro errore, probabilmente il file richiesto non esiste, oppure non hai diritti sufficienti per accedere al file."
    End Select
End Sub

[ilnonno13]

Comunque, tagliamo la testa al toro:

Codice: Seleziona tutto

Option Explicit
Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modIsFileOpen
' By Chip Pearson, www.cpearson.com , chip@cpearson.com
' www.cpearson.com/Excel/IsFileOpen.aspx
' This module contains the IsFileOpen procedure whict tests whether
' a file is open.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Function IsFileOpen(FileName As String, Optional ResultOnBadFile As Variant) As Variant
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsFileOpen
' This function determines whether a the file named by FileName is
' open by another process. The fuction returns True if the file is open
' or False if the file is not open. If the file named by FileName does
' not exist or if FileName is not a valid file name, the result returned
' if equal to the value of ResultOnBadFile if that parameter is provided.xd
' If ResultOnBadFile is not passed in, and FileName does not exist or
' is an invalid file name, the result is False.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim FileNum As Integer
Dim ErrNum As Integer
Dim V As Variant

On Error Resume Next

''''''''''''''''''''''''''''''''''''''''''''
' If we were passed in an empty string,
' there is no file to test so return FALSE.
''''''''''''''''''''''''''''''''''''''''''''
If Trim(FileName) = vbNullString Then
    If IsMissing(ResultOnBadFile) = True Then
        IsFileOpen = False
    Else
        IsFileOpen = ResultOnBadFile
    End If
    Exit Function
End If

''''''''''''''''''''''''''''''''''''''''''''
' if the file doesn't exist, it isn't open
' so get out now
''''''''''''''''''''''''''''''''''''''''''''
V = Dir(FileName, vbNormal)
If IsError(V) = True Then
    ' syntactically bad file name
    If IsMissing(ResultOnBadFile) = True Then
        IsFileOpen = False
    Else
        IsFileOpen = ResultOnBadFile
    End If
    Exit Function
ElseIf V = vbNullString Then
    ' file doesn't exist.
    If IsMissing(ResultOnBadFile) = True Then
        IsFileOpen = False
    Else
        IsFileOpen = ResultOnBadFile
    End If
    Exit Function
End If

FileNum = FreeFile()
'''''''''''''''''''''''''''''''''''''''
' Attempt to open the file and lock it.
'''''''''''''''''''''''''''''''''''''''
Err.Clear
Open FileName For Input Lock Read As #FileNum
ErrNum = Err.Number
''''''''''''''''''''
' Close the file.
''''''''''''''''''''
Close FileNum
On Error GoTo 0

''''''''''''''''''''''''''''''''''''''
' Check to see which error occurred.
''''''''''''''''''''''''''''''''''''''
Select Case ErrNum
    Case 0
        ''''''''''''''''''''''''''''''''''''''''''''
        ' No error occurred.
        ' File is NOT already open by another user.
        ''''''''''''''''''''''''''''''''''''''''''''
        IsFileOpen = False
    Case 70
        ''''''''''''''''''''''''''''''''''''''''''''
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        ''''''''''''''''''''''''''''''''''''''''''''
        IsFileOpen = True
    Case Else
        ''''''''''''''''''''''''''''''''''''''''''''
        ' Another error occurred. Assume open.
        ''''''''''''''''''''''''''''''''''''''''''''
        IsFileOpen = True
End Select

End Function




Public Sub prova()
  'dichiarazioni esistenti
  '..... CUT .........
  Dim wbTo As Workbook

  On Error Resume Next
  With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
  End With
  Do While IsFileOpen("Z:\EXCEL\Marketing\Test\Prova.xlsx")
    Application.Wait (Now + TimeValue("0:00:01"))
  Loop
  On Error GoTo 0
  Set wbTo = Workbooks.Open("Z:\EXCEL\Marketing\Test\Prova.xlsx")
  With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With
  MsgBox "ho aperto il file " & wbTo.Name
 
  'Application.DisplayAlerts = True
  '............. CUT ............
  '....... resto del codice .....
  Set wbTo = Nothing
End Sub

Ovviamente sostituisci "Z:\EXCEL\Marketing\Test\Prova.xlsx" a coerenza.

Funziona perfettamente!!!

Grazie!