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