Ouvrir un fichier Word ou Excel, s'il est ouvert, une copie en lecture seule s'ouvre

Commenter

Contenu du snippet 

Private Const OF_SHARE_EXCLUSIVE = &H10
Private Declare Function lopen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As  Long
Private Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long
Function OpenDocXlsFile(FileToOpen As String) As Long
'   retourne  :
'   -1  -> erreur
'   0   -> fichier déjà ouvert, ouverture en lecture  seule
'   1   -> ouverture première  instance
    OpenDocXlsFile = -1
    
    Dim sExt        As String
    Dim NomAppli    As String
'   type de fichier  par son extension
    If LenB(FileToOpen) < 16 Then
        Exit Function
    Else
        sExt = LCase$(RightB$(FileToOpen, 8))
        If sExt = ".doc" Or sExt = ".rtf" Then
            NomAppli = "Word"
        ElseIf sExt = ".xls" Or sExt = ".csv" Then
            NomAppli = "Excel"
        Else
            Exit Function
        End If
    End If
'   ouverture  office
    Dim MonApp      As Object
    Dim MonDoc      As Object
    Dim hFile       As Long
    
    hFile = lopen(FileToOpen, OF_SHARE_EXCLUSIVE)
    If hFile <> -1 Then 'pas  ouvert
        lclose (hFile)
        Set MonApp = CreateObject(NomAppli &  ".Application")
        If NomAppli = "Word" Then
            Set MonDoc = MonApp.Documents.Open(FileToOpen)
        Else
            Set MonDoc = MonApp.Workbooks.Open(FileToOpen)
        End If
        OpenDocXlsFile = 1
    ElseIf (hFile = -1) And (Err.LastDllError = 32) Then  'déjà ouvert
        lclose (hFile)
        Set MonApp = CreateObject(NomAppli &  ".Application")
        If NomAppli = "Word" Then
            On Local Error Resume Next
            Set MonDoc = MonApp.Documents.Open(FileToOpen, , True)
            If Err.Number = 4198 Then
'               word 2000, utilisateur fait  ANNULER
                Err.Clear
                GoTo Lbl_Exit
            End If
            On Error GoTo 0
        Else
            Set MonDoc = MonApp.Workbooks.Open(FileToOpen, , True)
        End If
        OpenDocXlsFile = 0
    End If
    MonApp.Visible = True
    
Lbl_Exit:
    Set MonDoc = Nothing
    Set MonApp = Nothing
End Function

'    EXEMPLE
Private Sub Form_Load()
    Debug.Print "Word : " & OpenDocXlsFile("C:\Nouveau  Document Microsoft Word.doc")
    Debug.Print "Excel : " & OpenDocXlsFile("C:\test.xls")
    
    Unload Me
End Sub

Compatibilité : VB6, VBA

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (mortalino)