L
LuLu
Guest
Bonjour,
Voici une macro qui me permet d'afficher une image jpeg chaque que je tape un mot correspondant à toutes les images contenus dans mon repertoire...
Comment dois-je faire pour :
- faire que cette macro ne s'applique que dans les cellules D4:F4; D8:F8
- faire que l'image s'affiche dans la cellule du dessous et que la taille de l'image s'adapte à celle de la cellule (tout en gardant une bonne proportionnalité)
- faire que l'image soit supprimée avant qu'une nouvelle ne s'affiche par dessus (si jamais l'idée me venait de changer de mot)
Merci à vous, cela m'aiderait beaucoup
Bon courage à tous
PS : Voici la macro actuelle
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim Val As String
Dim MyCell As Range
Dim MyPicture As Picture
Dim Pict
Dim a As Long
On Error GoTo errorhandler
Application.ScreenUpdating = False
Val = Target.Value
With Application.FileSearch
.NewSearch
.Filename = '.jpg'
.LookIn = ThisWorkbook.Path
.SearchSubFolders = False
.Execute msoSortByFileName, msoSortOrderAscending
If .Execute > 0 Then
Set MyCell = Target.Offset(1, 0)
MyCell.Select
For Each Pict In ActiveSheet.DrawingObjects ' supprimer ancienne image dans cellule
If Pict.Left = MyCell.Left + (MyCell.Width - 50) / 2 And Pict.Top = MyCell.Top + (MyCell.Height - 50) / 2 Then Pict.Delete
Next
Set MyPicture = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & '\\' & Val & '.jpg')
With MyPicture.ShapeRange
.LockAspectRatio = msoFalse
.Height = 55
.Width = 55
.Top = MyCell.Top + (MyCell.Height - 50) / 2
.Left = MyCell.Left + (MyCell.Width - 50) / 2
End With
MyCell.Select
MsgBox Pict.Left
End If
End With
Application.ScreenUpdating = True
Exit Sub
errorhandler:
Application.ScreenUpdating = True
Exit Sub
End Sub
Voici une macro qui me permet d'afficher une image jpeg chaque que je tape un mot correspondant à toutes les images contenus dans mon repertoire...
Comment dois-je faire pour :
- faire que cette macro ne s'applique que dans les cellules D4:F4; D8:F8
- faire que l'image s'affiche dans la cellule du dessous et que la taille de l'image s'adapte à celle de la cellule (tout en gardant une bonne proportionnalité)
- faire que l'image soit supprimée avant qu'une nouvelle ne s'affiche par dessus (si jamais l'idée me venait de changer de mot)
Merci à vous, cela m'aiderait beaucoup
Bon courage à tous
PS : Voici la macro actuelle
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim Val As String
Dim MyCell As Range
Dim MyPicture As Picture
Dim Pict
Dim a As Long
On Error GoTo errorhandler
Application.ScreenUpdating = False
Val = Target.Value
With Application.FileSearch
.NewSearch
.Filename = '.jpg'
.LookIn = ThisWorkbook.Path
.SearchSubFolders = False
.Execute msoSortByFileName, msoSortOrderAscending
If .Execute > 0 Then
Set MyCell = Target.Offset(1, 0)
MyCell.Select
For Each Pict In ActiveSheet.DrawingObjects ' supprimer ancienne image dans cellule
If Pict.Left = MyCell.Left + (MyCell.Width - 50) / 2 And Pict.Top = MyCell.Top + (MyCell.Height - 50) / 2 Then Pict.Delete
Next
Set MyPicture = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & '\\' & Val & '.jpg')
With MyPicture.ShapeRange
.LockAspectRatio = msoFalse
.Height = 55
.Width = 55
.Top = MyCell.Top + (MyCell.Height - 50) / 2
.Left = MyCell.Left + (MyCell.Width - 50) / 2
End With
MyCell.Select
MsgBox Pict.Left
End If
End With
Application.ScreenUpdating = True
Exit Sub
errorhandler:
Application.ScreenUpdating = True
Exit Sub
End Sub
