[AC-2010] Ouvrir une diaporama de PowerPoint avec Access VBA [Résolu]

[toumack]

Bonjour à tous,

J'ai créé une diaporama avec PowerPoint (.ppsm) qui se trouve dans ce répertoire: c:\Auto-Caisse\LogoOuverture.ppsm
Lorsque je clique 2 fois sur ce fichier à l'extérieur d'Access, le diaporama s'ouvre en mode plein écran, puis grâce à une minuterie, se ferme automatiquement après quelques secondes et Microsoft PowerPoint ne s'ouvre pas. Exactement l'effet désiré.

J'ai créé un module "Utility Functions" dans Access avec le code suivant:

Code :

1
2
3
4
5
Public Function OpenDiaporama() As Boolean
DoCmd.Maximize
Application.FollowHyperlink "c:\auto-caisse\LogoOuverture.ppsm"
DoCmd.OpenForm "Connexion1"
End Function

Dans ma macro autoexec :
Exécuter code
Nom de la fonction: OpenDiaporama()


Lorsque j'ouvre mon application, LogoOuverture.ppsm s'exécute, mais il y a une barre dans le haut qui montre que c'est un fichier powerpoint, (Diaporama PowerPoint - [LogoOuverture.ppsm] - Microsoft PowerPoint

de plus, sous cette barre, "Fin du diaporama, cliquez pour quitter"

Il faut donc que je clique sur la diapositive pour quitter le diaporama, contrairement lorsque je clique directement à l'extérieur d'Access.

de plus Microsoft PowerPoint s'ouvre et reste ouvert.

Est-ce possible que ce fichier ppsm s'exécute de la même façon dans Access que lorsqu'on clique 2 fois dessus à partir de Windows Explorer.

"Microsoft PowerPoint 14.0 Object Library" est ticker dans mes références VBA

Par VBA si possible, merci de votre aide.

Claude du Québec

[Godzestla]

Bonjour,

sans VBA, je n'ai pas de solution, mais avec VBA et via l'utilisation de ShellExecuteEx, tu peux lancer, comme tu le fais manuellement en double-cliquant sur le fichier, l'application de gestion de ce fichier et ainsi le visualiser.
Via le Hwnd récupéré, tu peux ensuite tuer depuis access l'application ouverte, si besoin est.

Voici le code :

Déclarations a mettre en debut de module (ou en Global selon le besoin)

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Private Type SHELLEXECUTEINFO
    cbSize As Long
    fMask As Long
    hWnd As Long
    lpVerb As String
    lpFile As String
    lpParameters As String
    lpDirectory As String
    nShow As Long
    hInstApp As Long
    lpIDList As Long
    lpClass As String
    hkeyClass As Long
    dwHotKey As Long
    hIcon As Long
    hProcess As Long
End Type
 
'OpenProgram
Private Declare Function ShellExecuteEx Lib "shell32.dll" _
(SEI As SHELLEXECUTEINFO) As Long
 
'CloseProgram
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
 
Private Declare Function TerminateProcess Lib "kernel32" _
(ByVal hProcess As Long, ByVal uExitCode As Long) As Long
 
 
 
Dim PhWnd                   As Long

Appel :

Code :

       PhWnd = OpenProgram("c:\auto-caisse\LogoOuverture.ppsm", 0)

Fonctions.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
' ***********************************************************
' *
' * Lance le programme par défaut associé à un fichier (en fonction de son
' * extension ) et retourne le hWnd de la fênetre du programme lançé.
' *
' ***********************************************************
 
Public Function OpenProgram(ByRef Filename As String, ByRef OwnerhWnd As Long) As Long
    Dim SEI As SHELLEXECUTEINFO
 
    On Error GoTo ErrorHandler
 
    'Vérifie si le fichier à lancer est un exécutable (.exe)
    If GetExtension(Filename) = "exe" Then
        If vbNo = MsgBox("ATTENTION, êtes-vous sûr de vouloir lancer ce programme exécutable ?", vbExclamation + vbYesNo) _
        Then
            OpenProgram = 0
            Exit Function
        End If
    End If
 
    With SEI
        .cbSize = Len(SEI)
        .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_FLAG_NO_UI
        .hWnd = OwnerhWnd
        .lpVerb = "open"
        .lpFile = Filename
        .lpParameters = vbNullChar
        .lpDirectory = vbNullChar
        .nShow = SW_SHOW
        .hInstApp = OwnerhWnd
    End With
 
    OpenProgram = ShellExecuteEx(SEI)
 
    If SEI.hInstApp <= 32 Then
    'Erreurs
        OpenProgram = 0
 
        Select Case SEI.hInstApp
            Case SE_ERR_FNF
                OpenProgram = SEI.hProcess
            Case SE_ERR_PNF
                MsgBox "Le chemin du fichier à ouvrir est incorrect.", vbExclamation
            Case SE_ERR_ACCESSDENIED
                MsgBox "Accès au fichier refusé.", vbExclamation
            Case SE_ERR_OOM
                MsgBox "Mémoire insuffisante.", vbExclamation
            Case SE_ERR_DLLNOTFOUND
                MsgBox "Dynamic-link library non trouvé.", vbExclamation
            Case SE_ERR_SHARE
                MsgBox "Le fichier est déjà ouvert.", vbExclamation
            Case SE_ERR_ASSOCINCOMPLETE
                MsgBox "Information d'association du fichier incomplète.", vbExclamation
            Case SE_ERR_DDETIMEOUT
                MsgBox "Opération DDE dépassée.", vbExclamation
            Case SE_ERR_DDEFAIL
                MsgBox "Opération DDE echouée.", vbExclamation
            Case SE_ERR_DDEBUSY
                MsgBox "Opération DDE occupée.", vbExclamation
            Case SE_ERR_NOASSOC
                'Ouvrir avec...
                Call Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " + Filename, vbNormalFocus)
        End Select
    Else
        'Retourne le hWnd du programme lançé par ShellExecuteEx
        OpenProgram = SEI.hProcess
    End If
 
    Exit Function
ErrorHandler:
    OpenProgram = 0
End Function
 
' ***********************************************************
' *
' * Ferme un programme à partir du hWnd de sa fenêtre.
' *
' ***********************************************************
 
Public Function CloseProgram(hWnd As Long) As Boolean
    Dim lExitCode As Long
 
    If hWnd = 0 Then
        Exit Function
    End If
 
    On Error Resume Next
    CloseProgram = CBool(TerminateProcess(hWnd, lExitCode))
    'On Error Resume Next
    CloseHandle hWnd
    DoEvents
    Sleep (100)
 
End Function
 
Public Function GetExtension(Filename As String) As String
Dim tablo() As String
tablo = Split(Filename, ".")
GetExtension = tablo(UBound(tablo))
End Function

[toumack]

Merci beaucoup Godzestla,

J'ai créé le module OpenDiaporama, j'ai collé ton code et dans mon autoexec j'ai exécuter le code et tout s'est passé exactement comme je le désirais. Super!

À charge de revanche

Amicalement
Claude du Québec

[Godzestla]

You are welcome.