Excel içeriği resim olarak kaydet

[bthn35]

Merhaba,
Aşağıdaki excel'deki içeriği resim olarak kaydetmek mümkün mü? Ben makro ile denedim ancak resim bomboş geliyor. Office Pro Plus 2016 TR kullanıyorum.

http://s7.dosya.tc/server12/z6w9il/imza_test.zip.html

 

[turist]

Doysa Linki

 

[bthn35]

Maalesef gene bombos geliyor resim, acaba yetkiyle ilgili birsey mi?

 

[turist]

Eklenen dosyada denediniğinizde Resim olup, içerisi mi boş.
Masa üstünde izma.jpg adında bir dosya oluşuyor mu?

 

[bthn35]

Alttaki gibi çıkıyor.

 

[turist]

Masa üstündeki resmi "Paint" gibi bir Windows uygulaması ile açıp deneyin.

 

[bthn35]

Sonuç alttaki gibi, Windows 10 olmasıyla bir ilgisi olabilir mi?

 

[halit3]

Alternatif olarak aşağıdaki linkleri irdeleyiniz.
https://www.excel.web.tr/threads/sitedeki-resimleri-huecreye-getirme.175665/#post-961236
https://www.excel.web.tr/threads/secili-huecrelerin-ekran-goeruentuesuenue-almak.173497/#post-945847

 

[igultekin2000]

Sonuç alttaki gibi, Windows 10 olmasıyla bir ilgisi olabilir mi?

Sub jpg_kaydet()
On Error Resume Next
Call dosyayısil
  Dim objTemp As Object
  Dim chtMyChart As Chart
  Dim rngImg As Range
  Dim No As Long
  Dim TempName As String
  Set rngImg = Range("A1:AE44") 'resim alanını burda belirleyin
  rngImg.Copy
  Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
  objTemp.Select
  ActiveSheet.Paste
  objTemp.Delete
  TempName = Range("AH1")
  With Selection
      .CopyPicture 1, 2
      Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
  With chtMyChart
      .Paste
      .Export TempName
      .Parent.Delete
  End With
  .Delete
  End With
  MsgBox "Resim Alanı , " & TempName & " olarak kaydedildi.", , "Excel'i sevmeyen NEZLE olsun."
  Set rngImg = Nothing
  Set objTemp = Nothing
End Sub

kendi kullandığım örnekten, formdan almıştım

 

[turist]

Sonuç alttaki gibi, Windows 10 olmasıyla bir ilgisi olabilir mi?

Deneyin:
Yazı ve Logo alanı (A1:L5) aralığını seçin.
Yukarıdaki resimde anlatıldığı gibi kopyalayın.
Sonra "Paint" programınızı açın ve "Yapıştırın".
Çıkan sonuç ne oluyor, bakın.
Eğer yine BOŞ görüntü çıkıyorsa; clipborad.dll sorunu var demektir.

 

[halit3]

Birde bu kodu dene
Bu kod resimi dosyanın yanına çıkartıyor.

Sub resim_kaydet()

Dim objTemp As Object
Dim chtMyChart As Chart

Range("A1:L5").Copy

Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
objTemp.Select
ActiveSheet.Paste
objTemp.Delete

klasor = ThisWorkbook.Path
say = CreateObject("Scripting.FileSystemObject").GetFolder(klasor).Files.Count + 1
dosya = klasor & "\Resim " & say & ".jpg"


With Selection
.CopyPicture 1, 2
Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
With chtMyChart
.Paste
.Export dosya
.Parent.Delete
End With
.Delete
End With
MsgBox dosya & Chr(10) & " olarak kaydedildi.", , "UAYRI"

Set objTemp = Nothing
End Sub

 

[igultekin2000]

Birde bu kodu dene
Bu kod resimi dosyanın yanına çıkartıyor.

Teşekkürler , gayet pratik ve kullanışlı olmuş.

 

[halit3]

Teşekkürler iyi çalışmalar

 

[tamer42]

Birde bu kodu dene
Bu kod resimi dosyanın yanına çıkartıyor.

Sub resim_kaydet()

Dim objTemp As Object
Dim chtMyChart As Chart

Range("A1:L5").Copy

Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
objTemp.Select
ActiveSheet.Paste
objTemp.Delete

klasor = ThisWorkbook.Path
say = CreateObject("Scripting.FileSystemObject").GetFolder(klasor).Files.Count + 1
dosya = klasor & "\Resim " & say & ".jpg"


With Selection
.CopyPicture 1, 2
Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
With chtMyChart
.Paste
.Export dosya
.Parent.Delete
End With
.Delete
End With
MsgBox dosya & Chr(10) & " olarak kaydedildi.", , "UAYRI"

Set objTemp = Nothing
End Sub

Merhabalar,

Kodları çalışırmayı denerken ekli hatayı verdi ama;

sebebi ne olabilir?

iyi Çalışmalar.