Lire fermé

Bonjour Modeste,


Je n'ai pas cet environnement mais voici le contenu d'un fil sur le sujet : Est-ce pertinent ?

Réponse de Frédéric Sigonneau.


'--------------------------------------------
Y'a-t-il une commande qui permettrait de savoir si une personne utilise un
fichier (Excel ou Word) d'un répertoire donnée ?

Une commande, pas à ma connaissance. Mais on peut obtenir ce que tu souhaites
avec, par exemple, une fonction personnalisée pour tester si un fichier partagé
est en cours d'utilisation (IsFileOpen) puis une deuxième qui utilise la première
pour tester si dans un répertoire donné l'un des fichiers est en cours d 'utilisation,
le tout appelé dans une procédure qui détruit le répertoire en question si les deux
fonctions fournissent des réponses négatives. Le code serait à améliorer si le
répertoire peut comprendre des sous-répertoires.

FS

Sub delDossier()
Dim Chemin$, FSO

Chemin = "C:tmp"
If Not FichierUtiliséDansDossier(Chemin & "") Then
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.DeleteFolder Chemin
MsgBox "Le dossier '" & Chemin & "' a été supprimé"
Else
MsgBox "Impossible de supprimer '" & Chemin & "'"
End If

End Sub

Function FichierUtiliséDansDossier(Dossier$) As Boolean
Dim Fichier$
Fichier = Dir(Dossier & "*.xls")
Do
If IsFileOpen(Dossier & Fichier) Then
FichierUtiliséDansDossier = True
Exit Do
End If
Fichier = Dir()
Loop Until Fichier = ""
End Function

Function IsFileOpen(filename As String)
'auteur inconnu, mpep
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
'--------------------------------------------





"Modeste" <Gee-dee-@discussions.microsoft.com> a écrit dans le message de
news:195f901c44d5a$14e601f0$a601280a@phx.gbl...
Bonjour ,
une fois n'est pas coutume... une question !!!

grace à notre ami Herdet, j'utilise avec grand succès la
possibilité de récupérer des infos dans un classeur
fermé, et ceci dans un contexte réseau...

comment détecter que le classeur visé est en cours de
modification ou lecture seule ????
pour by_passer l'éxécution, ceci à fin d'éviter d'autres
problemes plus complexes (en effet dans ce cas une
instance lecture seule s'ouvre sur mon poste)

le code essentiel est ici :
Ce classeur doit comporter une référence à la bibliothèque
'Microsoft ActiveX Data Objects 2.x Library.

Sub GetExternalData(srcFile As String, _
srcSheet As String, _
srcRange As String, _
TTL As Boolean, _
OutArr As Variant)
'renvoie les valeurs d'une plage de cellules (srcRange)
'd'une feuille (srcSheet) d'un fichier (srcFile) fermé
'dans un tableau (outArr)
'le paramètre TTL indique si la plage a ou non une ligne
d'entêtes
'--------------d'après Héctor Miguel, mpep
Dim NewConn As ADODB.Connection, NewCmd As ADODB.Command
Dim HDR As String, NewRS As ADODB.Recordset, RS_n As
Integer, RS_f As Integer
Dim NewTbl
Set NewConn = New ADODB.Connection
If TTL = True Then HDR = "Yes" Else HDR = "No"
NewConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & srcFile & ";" & _
"Extended Properties=""Excel 8.0;" & _
"HDR=" & HDR & ";IMEX=1;"""
Set NewCmd = New ADODB.Command
NewCmd.ActiveConnection = NewConn
If srcSheet = "" _
Then NewCmd.CommandText = "SELECT * from `" &
srcRange & "`" _
Else NewCmd.CommandText = "SELECT * from `" &
srcSheet & "$" & srcRange & "`"
Set NewRS = New ADODB.Recordset
NewRS.Open NewCmd, , adOpenKeyset, adLockOptimistic
ReDim NewTbl(1 To NewRS.RecordCount, 1 To
NewRS.Fields.Count)
NewRS.MoveFirst
Do While Not NewRS.EOF
For RS_n = 1 To NewRS.RecordCount 'lignes
For RS_f = 0 To NewRS.Fields.Count - 1 'colonnes
NewTbl(RS_n, RS_f + 1) = NewRS.Fields(RS_f).Value
Next
NewRS.MoveNext
Next
Loop
NewConn.Close
Set NewRS = Nothing
Set NewCmd = Nothing
Set NewConn = Nothing
OutArr = NewTbl
End Sub

@+