Insérer une image par défault

Bonjour a toutes et tous, Forum bonjour

(1) Lorsque je clic sur un film en colonne A cela déclenche windows media player qui me lit le film jusque la OK

(2) Cela m'affiche également l'affiche du film jusque la OK

(3) je souhaiterai SVP au cas ou je n'aurai pas une affiche du film voulu, insérer a la place et par défault une autre image que j'ai baptiser (Liberty.jpg)

Je joint le bout de code concerner, car programme trop lourd 2Tonnes, hihihi

'*** LANCE UN FILM SUR DOUBLE CLIC DANS LA LISTE COLONNE A
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Chemin As String: Dim Fichier As String: Dim Shp As Shape

Application.ScreenUpdating = False
If Not Intersect(Target, Range("A2:A" & [A3000].End(xlUp).Row)) Is Nothing Then
Cancel = True
Chemin = "E:\Videos\"
Fichier = "E:\Affiche\" & Target.Value & ".jpg"
End If

'*** APPEL DU FILM CHOISI DANS LA COLONNE A
Shell """C:\Program Files\Windows Media Player\wmplayer.exe"" """ & Chemin & Target & ".avi", vbMaximizedFocus

'*** APPEL DE L'IMAGE CORRESPONDANT AU FILM                     L    T    W    H
Set Shp = Feuil1.Shapes.AddPicture(Fichier, msoFalse, msoCTrue, 945, 196, 194, 240)
Application.ScreenUpdating = True

'*** ARRET DU LECTEUR ET EFFACE L'AFFICHE
'If Retval = -1 Then MsgBox "Windows média player est arrêter."
'Shp.Delete
End Sub

Merci de votre aide un bon Dimanche a tous

Raymond

Bonjour raymond,

Essaie avec ce code :

    '*** LANCE UN FILM SUR DOUBLE CLIC DANS LA LISTE COLONNE A
    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Chemin As String: Dim Fichier As String: Dim Shp As Shape

    Application.ScreenUpdating = False
    If Not Intersect(Target, Range("A2:A" & [A3000].End(xlUp).Row)) Is Nothing Then
    Cancel = True
    Chemin = "E:\Videos\"
    Fichier = "E:\Affiche\" & Target.Value & ".jpg"
    End If

    '*** APPEL DU FILM CHOISI DANS LA COLONNE A
    Shell """C:\Program Files\Windows Media Player\wmplayer.exe"" """ & Chemin & Target & ".avi", vbMaximizedFocus

    '*** APPEL DE L'IMAGE CORRESPONDANT AU FILM                     L    T    W    H
    On Error Resume Next
    Set Shp = Feuil1.Shapes.AddPicture(Fichier, msoFalse, msoCTrue, 945, 196, 194, 240)
    On Error GoTo 0
    Fichier = IIf(Shp Is Nothing, "E:\Affiche\Liberty.jpg", Fichier)
    Set Shp = Feuil1.Shapes.AddPicture(Fichier, msoFalse, msoCTrue, 945, 196, 194, 240)
    Application.ScreenUpdating = True

    '*** ARRET DU LECTEUR ET EFFACE L'AFFICHE
    'If Retval = -1 Then MsgBox "Windows média player est arrêter."
    'Shp.Delete
    End Sub

C'est la partie de code suivante qui détecte si le fichier image existe ou non :

    '*** APPEL DE L'IMAGE CORRESPONDANT AU FILM                     L    T    W    H
   On Error Resume Next
    Set Shp = Feuil1.Shapes.AddPicture(Fichier, msoFalse, msoCTrue, 945, 196, 194, 240)
    On Error GoTo 0
    Fichier = IIf(Shp Is Nothing, "E:\Affiche\Liberty.jpg", Fichier)
    Set Shp = Feuil1.Shapes.AddPicture(Fichier, msoFalse, msoCTrue, 945, 196, 194, 240)

Re bonjour a tous, forum

Bonjour Vba-new

Merci pour ta réponse ca fonctionne presque sauf que il veux pas effacer l'image avec le code Shp.Delete

vois les deux commentaires svp

'*** ARRET DU LECTEUR ET EFFACE L'AFFICHE
If Retval = -1 Then MsgBox "Windows média player est arrêter."   'ca affiche bien mon message OK

Shp.Delete                    'que l'image soit bonne ou pas de toutes facons il veut pas effacer, MAIS je n'ai pas d'erreur

End Sub

je ne trouve pour effacer l'image autrement si encore c'est possible snif snif

au plaisir de relire et bon Dimanche

Raymond

Re,

Avec le code suivant, l'image est effacée à la fin du programme.

 '*** LANCE UN FILM SUR DOUBLE CLIC DANS LA LISTE COLONNE A
   Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Chemin As String: Dim Fichier As String: Dim Shp As Shape

    Application.ScreenUpdating = False
    If Not Intersect(Target, Range("A2:A" & [A3000].End(xlUp).Row)) Is Nothing Then
    Cancel = True
    Chemin = "E:\Videos\"
    Fichier = "E:\Affiche\" & Target.Value & ".jpg"
    End If

    '*** APPEL DU FILM CHOISI DANS LA COLONNE A
   Shell """C:\Program Files\Windows Media Player\wmplayer.exe"" """ & Chemin & Target & ".avi", vbMaximizedFocus

    '*** APPEL DE L'IMAGE CORRESPONDANT AU FILM                     L    T    W    H
   On Error Resume Next
    Set Shp = Feuil1.Shapes.AddPicture(Fichier, msoFalse, msoCTrue, 945, 196, 194, 240)
    On Error GoTo 0
    Fichier = IIf(Shp Is Nothing, "E:\Affiche\Liberty.jpg", Fichier)
    Set Shp = Feuil1.Shapes.AddPicture(Fichier, msoFalse, msoCTrue, 945, 196, 194, 240)
    Application.ScreenUpdating = True

    '*** ARRET DU LECTEUR ET EFFACE L'AFFICHE
   'If Retval = -1 Then MsgBox "Windows média player est arrêter."
   Shp.Delete
   End Sub

Par contre, je ne vois pas trop où tu veux en venir avec le code que tu viens de poster.

C'est peut-être ça que tu veux ?

If Retval = -1 Then
MsgBox "Windows média player est arrêter."   'ca affiche bien mon message OK

Shp.Delete                    'que l'image soit bonne ou pas de toutes facons il veut pas effacer, MAIS je n'ai pas d'erreur
End If

Re vba-new

Merci pour la réponse c'est bien cela que je veux faire ca fonctionne SAUF que ca n'efface pas l'image

le code Shp.delete se fait bien (pas d'erreur)

Mais ca n'efface pas l'image, (avant ma demande ce code fonctionnais bien) ???

je comprends pas pourquoi, si tu as une idée merci je veux bien

A plus tard Raymond

Le mieux serait que je puisse voir ton fichier. Si possible enlève tout ce qui te semble inutile pour la résolution du problème.

Une petite question, d'où vient cette variable Retval ?

Bonjour a toutes et tous, forum

Bonjour vba-new

Merci pour ta réponse, je vais voir pour faire autrement car je ne puis joindre mon fichier, trop lourd et puis le bout de code que j'ai mis en début de post est celui qui correspond a ce que je souhaite faire

La variable Retval vient d'un autre bout de code mais n'ai pas essentiel, d'ailleurs je vais supprimer.

Le but est

(1) je récupère le titre d'un film en colonne A

(2) je lance Windows média player pour lire le film

(3) j'affiche l'image correspondant au film

(4) je clic sur WMP qui s'arrète et j'éfface l'image c'est tout

Par contre si l'image n'existe pas je la remplace par une autre par defaut , d'ou mon post

Voila bon app et bonne journée

Merci pour l'aide

Raymond

A tout hasard, si tu fais comme ça ça marche ?

If Retval = -1 Then
Shp.Delete                    'que l'image soit bonne ou pas de toutes facons il veut pas effacer, MAIS je n'ai pas d'erreur

MsgBox "Windows média player est arrêter."   'ca affiche bien mon message OK
End If

Bonjour a toutes et tous, forum bonjour

Bonjour Vba-new

Merci pour ta réponse, j'ai suivi tes conseils mais ca ne marche toujours pas, malgré multiples essais, j'ai épuisser le peu de neurones qui me restait, et comme je n'ai pas été livrer ce matin.

Alors SVP si quelqu'un a une idée sur le sujet je suis preneur de toutes solutions a essayer, merci a tous pour votre aide

Au plaisir de vous relire bonne après midi

Raymond

Bonjour a toutes et tous, forum bonjour

Vba-new salut

Solution au problème le code ci-dessous est bon, je te remercie beaucoup pour l'aide apporter

'*** LANCE UN FILM SUR DOUBLE CLIC DANS LA LISTE COLONNE A
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Chemin As String: Dim Fichier As String: Dim Shp As Shape: Dim Retval As Long: Dim ID As Variant
Application.ScreenUpdating = False

If Not Intersect(Target, Range("A2:A" & [A3000].End(xlUp).Row)) Is Nothing Then
Cancel = True
Chemin = "E:\Videos\"
Fichier = "E:\Affiche\" & Target.Value & ".jpg"
End If

'*** APPEL DU FILM CHOISI DANS LA COLONNE A
ID = Shell("""C:\Program Files\Windows Media Player\wmplayer.exe"" """ & Chemin & Target & ".avi", vbMaximizedFocus)
Retval = ExecCmd("Wmplayer.exe")

'*** APPEL DE L'IMAGE CORRESPONDANT AU FILM                    L    T    W    H
On Error Resume Next
Set Shp = Feuil1.Shapes.AddPicture(Fichier, msoFalse, msoCTrue, 945, 196, 194, 240)
On Error GoTo 0
If Shp Is Nothing Then
Fichier = "E:\Affiche\Liberty.jpg"
Set Shp = Feuil1.Shapes.AddPicture(Fichier, msoFalse, msoCTrue, 945, 196, 194, 240)
End If

Application.ScreenUpdating = True
'*** ARRET DU LECTEUR ET EFFACE L'AFFICHE
If Retval = -1 Then MsgBox "Windows média player est arrêter."
Shp.Delete
End Sub

Bon W-end et bonnes vacances a tous

Raymond