Foto's opslaan met benaming tevinden in zelfde excel

[BricksetforYou]

Goedeavond allen,

Ik ben al een tijdje aan het zoeken naar ene macro die het volgende kan doen voor mij. Ik zelf geraak er absoluut niet meer uit.

In kolom A vinden jullie een aantal foto's.

In de kolom C vinden jullie de benaming die ik zou gebruiken om de foto's te benoemen.

Kan er een macro gemaakt worden om de foto's in de kolom A op te slaan met de naam van kolom C?

 

[HSV]

Met:

Sub hsv()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
 sh.Name = sh.TopLeftCell.Offset(, 2)
Next sh
End Sub

 

[BricksetforYou]

HSV bedankt voor uw hulp,

Ik heb net deze macro geprobeerd maar helaas gebeurd er niets.

 

[HSV]

De plaatjes worden hier netjes herbenoemd.

 

[BricksetforYou]

En worden de plaatjes ook opgeslaan in een map naar keuze?

 

[HSV]

Was dat de vraag dan?

 

[BricksetforYou]

Harry,

De plaatsjes die in kolom A staan moeten opgeslagen worden in een map met als naam de naam in de kolom C. Naam is bijvoorbeeld " 6284585 "

 

[edmoor]

Doe dit eens:

Sub CommandButton1_Click()
    Dim objPic As Shape
    Dim objChart As Chart
    
    Application.ScreenUpdating = False
    Sheets.Add
    ActiveSheet.Name = "TMP"
    
    For Each sh In Sheets("Blad1").Shapes
        sh.CopyPicture xlScreen, xlPicture
        With Sheets("TMP")
            .Shapes.AddChart
            .Shapes.Item(1).Width = sh.Width
            .Shapes.Item(1).Height = sh.Height
            .Shapes.Item(1).Select
        End With
        
        Set objChart = ActiveChart
        objChart.Paste
        objChart.Export ThisWorkbook.Path & "\" & sh.TopLeftCell.Offset(, 2) & ".jpg"
    Next sh
    
    Application.DisplayAlerts = False
    Sheets("TMP").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[alphamax]

Public Sub ExportAndRename()
    With Worksheets("Blad1")
        For Each oShape In .Shapes
            Set oChart = .ChartObjects.Add(oShape.Left, oShape.Top, oShape.Width, oShape.Height)
            oShape.Copy
            oChart.Select
            ActiveChart.Paste
            ActiveChart.Export ThisWorkbook.Path & "\" & oShape.TopLeftCell.Offset(0, 2).Value & ".png", "PNG"
            Application.Wait DateAdd("s", 1, Now)
            oChart.Delete
            DoEvents
        Next
    End With
End Sub

 

[BricksetforYou]

Heykes ed,

ik krijg een foutmelding bij de volgende zin

objChart.Export ThisWorkbook.Path & "" & sh.TopLeftCell.Offset(, 2) & ".jpg"

 

[edmoor]

Als je een foutmelding krijgt, vertel er dan ook bij welke dat is.
Probeer ook die van Alphamax.
Bij mij werkt die van mij prima.

 

[alphamax]

Je moet het bestand eerst eens opslaan op je harde schijf, anders geeft ThisWorkbook.Path een fout.
De foto's staan daarna in dezelfde map, als de map waar je het bestand hebt opgeslagen.

 

[alphamax]

Ben je de backslash niet vergeten?

objChart.Export ThisWorkbook.Path & "[COLOR=#ff0000]\[/COLOR]" & sh.TopLeftCell.Offset(, 2) & ".jpg"

 

[edmoor]

Het forum verwijderd die als je geen codetags gebruikt.

 

[snb]

Waarom zoveel charts creëren als het aantal afbeeldingen? Dat kan toch gewoon met 1 chart ?
En gebruik vooral geen 'select'.

Sub M_snb()
  With Worksheets("Blad1")
    .ChartObjects.Add(1, 1, 100, 100)
    For it In .Shapes
      it.Copypicture
      .charts(1).Paste
      .charts(1).Export G:\OF\" & it.TopLeftCell.Offset(, 2) & ".png", "PNG"
    Next
   .charts(1).delete
  End With
End Sub