Új hozzászólás Aktív témák

• #38493 Alex123 senior tag Alex123 #38492

  Új Válasz 2018-07-08 15:12:54 #38493

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Alex123

  senior tag

  válasz Alex123 #38492 üzenetére

  Ezzel a kóddal ki tudom menteni a képeket:

  Sub SaveImages()

'the location to save all the images
Const destFolder$ = "C:\users\...\desktop\"

Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("sheet1")

Dim ppt As Object, ps As Variant, slide As Variant

Set ppt = CreateObject("PowerPoint.application")
Set ps = ppt.presentations.Add
Set slide = ps.slides.Add(1, 1)

Dim shp As Shape, shpName$
For Each shp In ws.Shapes
shpName = destFolder & shp.TopLeftCell.Offset(1, 1) & ".png"
shp.Copy
With slide
.Shapes.Paste
.Shapes(.Shapes.Count).Export shpName, 2
.Shapes(.Shapes.Count).Delete
End With
Next shp

With ps
.Saved = True
.Close
End With
ppt.Quit
Set ppt = Nothing

End Sub

  A kép nevét át is nevezi a következőképpen (A oszlop 1 sor kép, B oszlop második sor a kép neve).
  Ez így tökéletesen működik is...

  DE:
  - azt hogyan tudom elérni, hogy a képek (az excel táblázatban kicsinyítve vannak) a valós, 100%-os méretükkel kerüljenek kimentésre?

  Várom az ötleteket, köszönöm!

Új hozzászólás Aktív témák