Exporter une image Excel dans un dossier

Bonjour le forum,

J'ai mon fichier Excel qui comprend dans la feuille 1 des images dans la colonne K et je souhaite les exporter dans un dossier au format .jpg. Le nom du fichier doit être généré à partir du texte de la colonne A et aussi que le lien de l'image l'image s'affiche dans la cellule ou était l'image. J'ai essayé la macro VBA suivante :

Private Sub CommandButton1_Click()
Dim oTxt As Object
 For Each cell In Ark1.Range("A2:A" & Ark1.UsedRange.Rows.Count)

 saveText = cell.Text
 Open "C:\Users\mazouzy\Desktop\ImagesESO" & saveText & ".jpg" For Output As #1
 Print #1, cell.Offset(0, 1).text
 Close #1
 Next cell
End Sub

J'ai malheureusement aucun bon résultat, j'ai essaye plusieurs méthodes trouvé sur des forums, mais aucuns ne correspond a ce que je cherche particulièrement.

Quelqu'un peut-il m'aider? Merci!

Cordialement

Salut :)

En fait l'astuce est d'ajouter une trame d'un graphique (vide) et copier/coller l'image dans le graphique et d'exporter le graphique en image.

Voici un exemple pour une image, pour la suite tu pourras facilement intégrer ce code dans une boucle pour gérer plusieurs images en même temps. Le code viens du site http://boisgontierj.free.fr/ dans le menu "Images" et dans la section "Expor image interne"

Sub ExportImage()
Dim répertoire As String
Dim f As Worksheet
Dim nomshape As String
Dim img As Shape

  répertoire = ThisWorkbook.Path
  Set f = ActiveSheet
  nomshape = "Image 2"
  Set img = f.Shapes(nomshape)
  img.CopyPicture xlScreen, xlBitmap
  With img.Parent.ChartObjects.Add(0, 0, img.Width, img.Height).Chart
     While .Shapes.Count = 0
       DoEvents
       .Paste
     Wend
     .Export répertoire & "\" & nomshape & ".jpg", "jpg"
     .Parent.Delete
  End With
End Sub

Salut Gautier !

Merci pour ta réponse, finalement j'ai réussi a transférer toute les images du tableau et renommez chacune d'elles en leurs donnant le nom de la cellule adjacentes grâce a ce code:

Sub ExportImages_ExtendOffice()

    Dim xStrPath As String
    Dim xStrImgName As String
    Dim xImg As Shape
    Dim xObjChar As ChartObject
    Dim xFD As FileDialog
    Set xFD = Application.FileDialog(msoFileDialogFolderPicker)
    xFD.Title = "Please select a folder to save the pictures" & " - ExtendOffice"
    If xFD.Show = -1 Then
       xStrPath = xFD.SelectedItems.Item(1) & "\"
    Else
        Exit Sub
    End If

    On Error Resume Next
    For Each xImg In ActiveSheet.Shapes
        If xImg.TopLeftCell.Column = 11 Then
        xStrImgName = xImg.TopLeftCell.Offset(0, -10).Value
        If xStrImgName <> "" Then
            xImg.Select

            Selection.Copy
            Set xObjChar = ActiveSheet.ChartObjects.Add(0, 0, xImg.Width, xImg.Height)
            With xObjChar
                .Border.LineStyle = xlLineStyleNone
                .Activate
                ActiveChart.Paste
                .Chart.Export xStrPath & xStrImgName & ".jpg"
                .Delete
            End With
        End If
        End If
    Next
End Sub

Je bloque maintenant sur un code, j'aimerais faire ceci:

Si ma cellule A2 est vide, alors aller à la cellule N+1
Si ma cellule n'est pas vide, alors écrire dans la colonne k "\ImagesESO\" + le ce qu'il y a dans la cellule A2 +".jpg"

Voila a quoi ressemble mon code pour l'instant:

Sub AjouterLienImage()

 Dim I As Long

   With Sheets("scan")
     .Activate
     For I = 2 To 500
      If .Cells(I, 1) <> "" Then
         .Cells(I, 11).FormulaR1C1 = "\ImagesESO\" & ".jpg"
      End If
     Next I
   End With
 End Sub

Le code fonctionne bien, mais je ne sais pas comment copier/coller ce qu'il y a dans la colonne A dans la colonne K... . Fin j'ai essaye avec le copy.range mais j'y arrive pas.Il faut utiliser le bouton "Ajouter Lien Image", en fichier joint le fichier modifier, merci pour ton aide.

Cldt.

Re, j'ai essayé ce code mais toujours rien...

Quelqu'un aurait-il une solution a ce problème svp? merci d'avance.

Cldt.

Hello,

Essaye ceci :

.cells(I,11) = "\ImagesESO\" & .range(Ta cellule).value & ".jpg"

A+,

Kilian

Bonsoir Kilian,

Ton code fonctionne mais là le problème c'est que les cellule (I, 11) aurons tous la valeur de A2, chaque cellule dois copier la valeur de la cellule adjacente. Tu m’as guidé sur la bonne voie, j'ai finalement utiliser ce code qui fonctionne à la perfection merci Kilian:

Sub AjouterLienImage()

 Dim I As Long

   With Sheets("scan")
     .Activate
     For I = 2 To 500
      If .Cells(I, 1) <> "" Then
         .Cells(I, 11) = "\ImagesESO\" & .Cells(I, 1).Value & ".jpg"
      End If
     Next I
   End With
 End Sub

Passe une bonne soirée.