Opslaan als afbeelding

[Schelledraad]

Ik heb in Excel een aantal plaatjes staan die ik wil opslaan in een nieuwe map. Dit kan je handmatig doen door het plaatje te selecteren en dan met je rechter muisknop kiezen voor "opslaan als afbeelding" in de gewenste map en dan is het weer .jpg.
Maar je voelt het al. Dat wil ik doen met een VBA code.

 

[snb]

Een dat is hier al tig keer beantwoord.

 

[Schelledraad]

Nou, ik heb naar vergelijbare vragen gezocht, maar niet gevonden

 

[Senso]

Ik weet niet hoe dat moet. How to save images from an Excel file into a folder using VBA? Mogelijk dat het daar bij staat.

 

[snb]

Sub M_snb()
  c00 = Application.DefaultFilePath & "foto.gif"

  With Sheet1.Shapes(1)
    .CopyPicture
    With Sheet1.ChartObjects.Add(1, 1, .Width, .Height).Chart
      .Paste
      .Export c00, "GIF"
      .Parent.Delete
    End With
  End With
End Sub

 

[Schelledraad]

OK, dat helpt al heel erg voor mijn begrip.

Zelf heb ik onderstaande code gevonden, die doet precies wat ik wil. Ik kan eerst een map selecteren waarin ik de bestandjes wil hebben.
Alleen.... Het vreemde doet zich voor dat als ik de code uitvoer er wel bestanden worden aangemaakt, maar zonder plaatje. Echter als ik de code handmatig doorloop neemt ie de plaatjes wel op?!?!

Sub ExportImages_ExtendOffice()
'Updated by Extendoffice 20220308
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 = 2 Then
xStrImgName = xImg.TopLeftCell.Offset(0, -1).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

 

[Senso]

Gebruik je dan Ku-tools for Excel?

Heb je die van snb geprobeerd?

 

[Schelledraad]

Ja, die doet het prima, alleen kan ik de export vervolgens nergens vinden ?!? . Ik ben dus nu aan het prutsen met de code daaronder om de code van snb daarmee te combineren, zodat er eerst een scherm verschijnt waar je kan aangeven waar je de export naar toe wil verplaatsen en daarna wil ik de code van snb runnen, maar dat lukt me vooralsnog niet

 

[Schelledraad]

Het vreemde is dus dat als ik de code stapje voor stapje uitvoer het wel goed gaat, maar als ik hem in 1 keer laat runnen neemt ie de plaatjes niet mee. de naam wel ?!

 

[snb]

Kijk eens:

Sub M_snb()
  msgbox Application.DefaultFilePath & "foto.gif"
End Sub

Gebruik code tags als je VBA-code plaatst.

 

[Schelledraad]

Ja zo heb ik hem idd gevonden. Maar nu wil ik dus met dat stukje uit die andere code eerst de locatie kunnen opgeven om vervolgens jouw code erop los te laten.

 

[snb]

Je hebt nog steeds geen code tags gebruikt in je post met VBA-code. Pas dat eerst eens aan svp.

 

[snb]

Vergeet alle andere code, maar gebruik slechts:

Sub M_snb()
  With Application.FileDialog(4)
     If .Show Then
        c00 = .SelectedItems(1)

        With Sheet1.Shapes(1)
          .CopyPicture

          With Sheet1.ChartObjects.Add(1, 1, .Width, .Height).Chart
            .Paste
            .Export c00 & "\foto.gif", "GIF"
            .Parent.Delete
          End With

        End With
      End If
    End With
End Sub

 

[Schelledraad]

En ook voor de code van snb geldt dat ie alleen werkt als ik hem regel voor regel uitvoer. Laat ik de code in 1 keer runnen dan neemt ie het plaatje niet mee.

 

[Schelledraad]

Ik word er bijna wanhopig van. Het enige wat ik in jouw laatste kolom heb aangepast is Sheet1 naar Blad1. Dat kan het toch niet zijn ? jouw code werkt prima, alleen neemt ie het plaatje niet mee.

 

[Schelledraad]

Ik ben alweer een stukje verder. Als ik de code in 1 keer afspeel dan neemt ie .paste niet over !

 

[edmoor]

Plaats een voorbeeld van je document.

 

[Schelledraad]

Sub Plakken()
With Blad1.Shapes("hand")
    .CopyPicture
          With Blad1.ChartObjects.Add(1, 1, .Width, .Height).Chart
            .Paste
          End With
End With
End Sub

Dit stukje van de code pakt ie dus niet. Zou With te diep genest kunnen zijn ?

 

[snb]

Als je Sheet1 in Blad 1 wijzigt, dan zul je dat 2 keer moeten doen.
- Waarom plaats je geen voorbeeldbestand en
- waarom doe je niet er van jou gevraagd wordt ? code tags in https://www.helpmij.nl/forum/showth...s-afbeelding?p=6338100&viewfull=1#post6338100 toevoegen ?

 

[Schelledraad]

Hier een voorbeeldbestand. Dat met die tags moet ik ff uitzoeken hoe dat moet