refuser l'ouverture d'un classeur deja ouvert

Option Explicit

'VériTi ... [url=http://excel.veriti.net]site des amis d'excel - veriti[/url]
'dans l'évènement Open du classeur...
Private Sub Workbook_Open()
ThisWorkbook.IsAddin = False
End Sub

'dans l'évènement BeforeSave ou BeforeClose du classeur...
Private Sub Workbook_BeforeClose(Cancel As Boolean)
ThisWorkbook.IsAddin = True
End Sub

'ainsi, si on ouvre le classeur alors que les options de sécurité bloquent l'exécution des macros, le classeur reste invisible...(mais pas VBA)

'Fonction pour empecher l'ouverture d'un fichier en Lecture Seule
Function IsFileOpen(filename As String)
' (code Microsoft :
' http://support.microsoft.com/default.aspx?scid=kb;EN-US;q138621)
Dim filenum As Integer, errnum As Integer

  On Error Resume Next   ' Turn error checking off.
  filenum = FreeFile()   ' Get a free file number.
  ' Attempt to open the file and lock it.
  Open filename For Input Lock Read As #filenum
  Close filenum          ' Close the file.
  errnum = Err           ' Save the error number that occurred.
  
  On Error GoTo 0        ' Turn error checking back on.

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

End Function

Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer
On Error Resume Next
filenum = FreeFile()
Open filename For Input Lock Read As #filenum
Close filenum
errnum = Err
On Error GoTo 0
Select Case errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
Case Else
Error errnum
End Select
End Function

Option Explicit

Sub Essai()
Consigne "Toto", 123.45, False
End Sub

Sub Consigne(ParamArray T())
Dim Chemin As String, NomFic As String, C As Long
Chemin = ThisWorkbook.Path & "\Communication"
ChDrive Chemin
On Error Resume Next: ChDir Chemin
If Err Then MkDir Chemin: ChDir Chemin
On Error GoTo 0
NomFic = "Com" & Format(Now, "yymmddhhmm") & _
   Format(VBA.Timer * 100, "0000") & ".txt"
Open NomFic For Output Access Write As 1
For C = LBound(T) To UBound(T): Write #1, T(C): Next C
Close #1
End Sub

Sub Récupérer()
Dim Chemin As String, NomFic As String, L As Long, TNomF() As String, _
   TRés(), C As Long
Chemin = ThisWorkbook.Path & "\Communication"
ChDrive Chemin
On Error Resume Next: ChDir Chemin
If Err Then Exit Sub
On Error GoTo 0
NomFic = Dir("Com*.txt")
While NomFic <> "": L = L + 1
   ReDim Preserve TNomF(1 To L)
   TNomF(L) = NomFic
   NomFic = Dir: Wend
ReDim TRés(1 To L, 1 To 4)
For L = 1 To UBound(TNomF)
   TRés(L, 1) = FileDateTime(TNomF(L))
   C = 1
   Open TNomF(L) For Input Access Read As #1
   While Not EOF(1)
      C = C + 1
      Input #1, TRés(L, C): Wend
      Close #1: Next L
Feuil1.Cells(60000, "A").End(xlUp).Offset(1) _
   .Resize(UBound(TRés, 1), UBound(TRés, 2)).Value = TRés
ThisWorkbook.Save
For L = 1 To UBound(TNomF)
   Kill TNomF(L): Next L
End Sub

Application.OnTime Now + TimeSerial(0, 0, 5), "Récupérer"

Input #1, TRés(L, C)

Sub ÉcrirePlage(ByVal Plage As Range)
Dim Chemin As String, Te(), Le As Long, Ts() As String, C As Long
Chemin = ThisWorkbook.Path & "\Communication"
ChDrive Chemin
Te = Plage.Value
Open "TableauCentral.txt" For Output Access Write As #1
ReDim Ts(0 To UBound(Te, 2) - 1)
For Le = 1 To UBound(Te, 1)
   For C = 1 To UBound(Te, 2)
      Select Case VarType(Te(Le, C))
         Case vbString: Ts(C - 1) = """" & Replace(Te(Le, C), """", """""") & """"
         Case vbDouble: Ts(C - 1) = Te(Le, C):
         Case Else: Ts(C - 1) = "": End Select: Next C
   Print #1, Join(Ts, vbTab): Next Le
Close #1
End Sub

Sub LirePlage(ByVal Plage As Range, Optional ByVal CelHeure As Range, Optional ByVal Abandonner As Boolean = True)
Dim Chemin As String, DatHMàJ As Date, DatHFic As Date, Te() As String, Ts(), Ls As Long, Z As String, C As Long
Chemin = ThisWorkbook.Path & "\Communication"
ChDrive Chemin
If Not CelHeure Is Nothing Then
   DatHMàJ = CelHeure.Value
   Do: DatHFic = FileDateTime("TableauCentral.txt")
      If DatHFic > DatHMàJ Then Exit Do
      If Abandonner Then Exit Sub
      DoEvents: Loop
   CelHeure.Value = DatHFic: End If
ReDim Ts(1 To 50000, 1 To 100)
Open "TableauCentral.txt" For Input Access Read As #1
While Not EOF(1)
   Line Input #1, Z: Te = Split(Z, vbTab)
   If UBound(Te) + 1 > UBound(Ts, 2) Then ReDim Preserve Ts(1 To 50000, 1 To UBound(Te) + 1)
   For C = 0 To UBound(Te)
      Ls = Ls + 1
      If Left$(Te(C), 1) = """" Then
         Ts(Ls, C + 1) = Replace$(Mid$(Te(C), 2, Len(Te(C)) - 1), """""", """")
      ElseIf IsNumeric(Te(C)) = "" Then
         Ts(Ls, C + 1) = CDbl(Te(C))
         End If: Next C
   Close #1: Wend
Plage.ClearContents
Plage.Resize(Ls, UBound(Ts, 2)).Value = Ts
End Sub

Sub Récupérer()
Dim Chemin As String, NomFic As String, TNomF() As String, _
   Ti(), Li As Long, C As Long, Cible As Range
Chemin = ThisWorkbook.Path & "\Communication"
ChDrive Chemin
On Error Resume Next: ChDir Chemin
If Err Then Exit Sub
On Error GoTo 0
NomFic = Dir("Com*.txt")
While NomFic <> "": Li = Li + 1
   ReDim Preserve TNomF(1 To Li)
   TNomF(Li) = NomFic
   NomFic = Dir: Wend
If Li = 0 Then Exit Sub
ReDim Ti(1 To Li, 1 To 4)
For Li = 1 To UBound(TNomF)
   Ti(Li, 1) = FileDateTime(TNomF(Li))
   C = 1
   Open TNomF(Li) For Input Access Read As #1
   While Not EOF(1)
      C = C + 1
      Input #1, Ti(Li, C): Wend
   Close #1: Next Li
Feuil1.Cells(60000, "A").End(xlUp).Offset(1) _
   .Resize(UBound(Ti, 1), UBound(Ti, 2)).Value = Ti
ThisWorkbook.Save
For Li = 1 To UBound(TNomF): Kill TNomF(Li): Next Li
End Sub