Insérer automatiquement des images

[Renaud22]

Bonjour à tous,

J'ai un fichier (Exemple.xlsm) qui contient 6 espaces réservés à des images. En cliquant une seule fois sur un des rectangles, le répertoire contenant les images s'ouvre. Je peux alors sélectionner l'image désirée et celle-ci est collée à l'endroit désigné, dimensionnée selon les critères définis dans le code VBA, sélectionnée automatiquement (' Macro & instructions pour coller une photo et le nom de celle-ci (B11)....) et le nom du fichier est indiqué en haut à gauche de l'image. Les images sont de format JPG et leur préfixe commence par 001, 002, 003,....999, 1000.

Mon problème est le suivant : j'aimerais pouvoir également copier les images automatiquement en conservant les dimensions prédéfinies en tapant le nom de l'image. Par exemple : cadre B11 @ E17, je tape en "B10", le numéro : 032 suivi de "Entrée" et automatiquement la photo 032.jpg sera collée dans le cadre B11 @ E17 et la sélection de cette image sera faite automatiquement sans que je la sélectionne manuellement. Idem pour les 5 autres espaces réservés aux images.

Afin d'éviter l'ouverture du répertoire contenant les images après l'appui sur la touche "Entrée", il faudra modifier le code VBA (' Macro & instructions pour coller une photo et le nom de celle-ci (B11)....) pour activer un rectangle avec un double-clic au lieu d'un simple clic (cas actuel). Il faudra trouver un moyen de définir le répertoire par défaut afin que le programme les photos dans le bon répertoire.

En résumé, je désire utiliser les deux méthodes, soit directement en cliquant sur le cadre et sélectionner la photo dans le répertoire par défaut suivis de l'insertion du nom de cette photo, soit en tapant le numéro de la photo pour que celle-ci s'insère automatiquement dans le cadre.

Plusieurs personne m'ont suggéré de regarder les exemples de Jacques Boisgontier pour résoudre mon problème. Celui-ci est trop spécifique et particulier pour que les exemples de M. Boisgontier puissent m'aider.

Si vous avez des questions, n'hésitez à me contacter.

En vous remerciant par avance pour votre précieuse aide.

Salutations,

Renaud22

 

[Lone-wolf]

Re : Insérer automatiquement des images

Bonsoir Renaud.

Une petite remarque pour commencer; il y a trop de Application.EnableEvents.

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
'Le code
'
'
'
'
'
'Fin code
Application.EnableEvents = True
End Sub

Une fois suffit comme tu peux le voir.

Pour le répertoire bein, soit tu met les photos dans le même dossier du fichier pour ensuite noter ThisWorkbook.Path & "\". Soit dans le même dossier tu recrées un dossier en y mettant les images et tu reprends ThisWorkbook.Path & "\Photos\", ou le chemin complet du dossier des photos "C:\Users\Renaud\Mes documents\Photos\". Et ensuite comme l'explique Jacques, tu mets soit des shapes (ActiveSheet.Pictures.Insert(MaPhoto), soit des contrôles images(Image1.Picture = LoadPicture(MaPhoto). Et à moins d'avoir mal compris, voici un exemple du même auteur.

je tape en "B10", le numéro : 032 suivi de "Entrée" et automatiquement la photo 032.jpg sera collée dans le cadre B11 @ E17 et la

Private Sub Worksheet_Change(ByVal Target As Range)
  '-- suppression de l'image actuelle
  If Target.Column = 1 And Target.Count = 1 Then
     For Each s In ActiveSheet.Shapes
       If s.Type = 13 Then
          If s.TopLeftCell.Address = Target.Offset(0, 1).Address Then s.Delete
       End If
     Next s
     RépertoirePhotos = ThisWorkbook.Path & "\" ' adapter
     On Error Resume Next
     Set img = ActiveSheet.Pictures.Insert(répertoirePhoto & Target & ".jpg")
     If Err > 0 Then
       MsgBox "inconnu"
     Else
       img.Left = Target.Offset(, 1).Left + 15
       img.Top = Target.Offset(, 1).Top
     End If
   End If
End Sub

Est-ce que ici l'image ne se positionne pas dans la cellule choisie??? et c'est l'évenement Change() qui vas exécuter l'action. Avec ceci à toi d'adapter la macro à tes besoins.



A+

 

[Renaud22]

Re : Insérer automatiquement des images

Bonjour Lone-wolf,

Merci d'avoir répondu à ma demande.

Comme je suis nul en programmation, j'aurais besoin que vous ajoutiez, si possible vous-même, les lignes de code dans le fichier joint pour que le programme fonctionne. Seul l'exemple de la cellule "B10" suffira. Je pourrais l'appliquer aux cellules G10, B18, G18, B26 et E26.

Le nom du répertoire par défaut contenant les photos est variable. Je ne peux pas mettre toutes les photos dans un seul répertoire et y faire référence dans le code. J'utilise plusieurs répertoires de photos. Comme vous le remarquez, lorsqu'on clique sur le cadre B11 @ E17, vous pouvez choisir votre répertoire et par la suite le dernier répertoire choisis deviendra ainsi le répertoire par défaut. J'aimerais qu'on définisse manuellement au début le répertoire par défaut et lorsqu'on tape le nom de la photo, la photo liée à ce nom soit sélectionnée dans le dernier répertoire choisis (par défaut).

Au plaisir de vous relire,

Sincères salutations,

Renaud22

 

[Lone-wolf]

Re : Insérer automatiquement des images

Bonjour Renaud,

comme les photos se touvent dans différents endroits, tu n'as pas le choix que d'afficher la BDD "Ouvrir un fichier". Ici, comme tu pourras le voir après test, pas besoin de sélectionner celle-ci dans la BDD. Dans ton classeur mais un contrôle image ActiveX; dans ses propriétés mets en mode Zoom. Attention! Il faudra faire autant de sub que tu as de répertoires, la première ici c'est " Sub OpenAFile() ". Tu peux mettre OpenAFile1 - OpenAFile2 - etc. Mais ceci dans un module standard.

'ouvrir un fichier de n'importe quel type dans Excel
'après l'avoir sélectionné dans la boite de dialogue Ouvrir de Windows

Declare Function ShellExecute Lib "shell32.dll" Alias _
       "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation _
       As String, ByVal lpFile As String, ByVal lpParameters _
       As String, ByVal lpDirectory As String, ByVal nShowCmd _
       As Long) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
         "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type


Sub OpenAFile()
Dim sFilter$, sDefNom$, sInitRep$, sNomDial$, sFichToOpen$
  
  'paramètres de la boite de dialogue
  sFilter = "Tous les fichiers (*.*)" & Chr(0) & "*.*" & Chr(0)
  sDefNom = Feuil2.Range("d5")
  sInitRep = "D:\Dossiers Excel\Divers\Insertion Images\"
  sNomDial = "Ouvrir un fichier"
  'appel puis ouverture du fichier si sélection
  sFichToOpen = GetFileName(sFilter, sDefNom, sInitRep, sNomDial)
  If sFichToOpen <> "" Then
    ShellExecute 0, "open", sFichToOpen, "", "", 5
    Sheets(2).Image1.Picture = LoadPicture(sDefNom & ".gif")
End If
End Sub


Function GetFileName(sFilter As String, sDefaultFile As String, sInitialDir As String, sTitle As String) As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long

  With OpenFile
    .lStructSize = Len(OpenFile)
    .lpstrFilter = sFilter
    .nFilterIndex = 1
    .lpstrFile = sDefaultFile & String(256 - Len(sDefaultFile), 0)
    .nMaxFile = Len(OpenFile.lpstrFile) - 1
    .lpstrFileTitle = OpenFile.lpstrFile
    .nMaxFileTitle = OpenFile.nMaxFile
    .lpstrInitialDir = sInitialDir
    .lpstrTitle = sTitle
    .flags = 0
  End With
  lReturn = GetOpenFileName(OpenFile)

  If lReturn = 0 Then
    GetFileName = ""
  Else
     GetFileName = Trim(OpenFile.lpstrFile)
  End If
End Function

A+

 

[Renaud22]

Re : Insérer automatiquement des images

Bonjour Lone-Wolf,

Comme je l'ai mentionné dans mon dernier message, je ne suis pas bon en programmation. Je ne sais pas où exactement il faut insérer vos lignes de code dans le fichier "Exemple.xlsm" afin de faire des tests. Est-il possible de sélectionner une fois le répertoire photos (ex. : boite de dialogue) et que celui-ci devienne le répertoire par défaut ? Pourriez-vous, SVP, me retourner le fichier "Exemple.xlsm" avec vos lignes de code déjà insérées.

Au plaisir de vous relire.

Sincères salutations,

Renaud22

 

[Lone-wolf]

Re : Insérer automatiquement des images

Re Renaud,

Ok. Mais il faut que tu modifie le chemin des photos ici: sInitRep = Ton chemin et aussi l'extension des photos ".gif" par ".bmp" par exemple.



A+

 

[Renaud22]

Re : Insérer automatiquement des images

Bonjour Lone-wolf,

Merci de m'avoir transmis votre fichier mais celui-ci n'est malheureusement pas adapté à mes contraintes (fichier Exemple.xlsm joint au début).

Tous le fichiers sont en "jpg" et la numérotation commence par 001, 002,....100....1000,... Les deux méthodes d'insertion de photos doivent être possibles (image ou n° de l'image) comme mentionné précédemment. Le fichier joint "Exemple.xlsm" doit servir de modèle. Il ne faut pas que le répertoire par défaut soit modifié à partir du code mais de manière plus transparente (bouton, etc...).

Je sais que vous avez beaucoup pour m'aider et je l'apprécie.

Salutations,

Renaud22

 

[Lone-wolf]

Re : Insérer automatiquement des images

Re,

Re Renaud,
Ok. Mais il faut que tu modifie le chemin des photos ici: sInitRep = Ton chemin et aussi l'extension des photos ".gif" par ".bmp" par exemple.

Est-ce que tu a lu ceci??? Est-ce que c'est compliqué de changer .gif par .jpg? Et si tu as changer les chemins des fichiers, tu peux écrire 001 - 002 - 003 etc.


A+

 

[Renaud22]

Re : Insérer automatiquement des images

J'ai bien lu vos derniers messages et je comprends comment il faut adapter le programme en fonction de mes besoins spécifiques.

Merci beaucoup pour votre aide.

Salutations

Renaud22

 

[Lone-wolf]

Re : Insérer automatiquement des images

Bonjour Renaud,

à tester.

Dim sh, img, repertoire, nf

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 suppression
  repertoire = "D:\Dossiers Excel\Importation Images\"
    nf = repertoire & Range("B3") & ".jpg"
    
    On Error Resume Next
      With Range("B3")
    If Dir(nf) <> "" Then
      Set img = ActiveSheet.Pictures.Insert(nf)
      img.Name = .Value
      img.Top = .Top
      img.Left = .Left
    End If
Range("B2").Value = .Value
End With
End Sub


Sub suppression()
  For Each sh In ActiveSheet.Shapes
    If sh.Type <> 8 Then sh.Delete
  Next sh
End Sub

A+

 

[Renaud22]

Re : Insérer automatiquement des images

J'ai testé et c'est bon.

Merci beaucoup Lone-Wolf.

Salutations,

Renaud22