jpg olarak kaydet (office 2019)

[sevensuleyman]

merhaba ; excellde resim olarak kaydettiğim excell dosyanı office 2019 da kullanamıyorum. resimler beyaz boş olarak akydetmektedir. kod nasıl düzeltebilriz.

Private Sub CommandButton2_Click()
Dim objTemp As Object
Dim chtMyChart As Chart

Range("B8").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 & "\Kampanya " & Range("B3") & Format(Now, "( dd.mm.yyyy_hh.mm )") & ".png"


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.", , "UYARI"

Set objTemp = Nothing
End Sub

 

[halit3]

Bunu bir denermisiniz.

Private Sub CommandButton2_Click()
Dim objTemp As Object
Dim chtMyChart As Chart

Range("B8").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 & "\Kampanya " & Range("B3") & Format(Now, "( dd.mm.yyyy_hh.mm )") & ".png"


With Selection
If Val(Application.Version) > 11 Then
.Copy
Else
.CopyPicture 1, 2
End If


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.", , "UYARI"

Set objTemp = Nothing
End Sub

 

[Korhan Ayhan]

Alternatif olarak inceleyiniz..

Makro Jpg Kaydetme Boş Resim Sorunu

Merhaba arkadaşlar. Excelde bir sayfayı jpg olarak masaüstüne kaydetmek istiyorum. Makro kodum bundan 2 sene önce sorunsuz çalışıyordu tekrar kullanmam gerekti ancak şuan masaüstüne kaydediyor fakat boş bir resim olarak kaydediyor nerede hata olduğunu bulamadım. Excel 2016 kullanıyorum Windows...

www.excel.web.tr

 

[sevensuleyman]

Bunu bir denermisiniz.

Private Sub CommandButton2_Click()
Dim objTemp As Object
Dim chtMyChart As Chart

Range("B8").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 & "\Kampanya " & Range("B3") & Format(Now, "( dd.mm.yyyy_hh.mm )") & ".png"


With Selection
If Val(Application.Version) > 11 Then
.Copy
Else
.CopyPicture 1, 2
End If


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.", , "UYARI"

Set objTemp = Nothing
End Sub

maalesef aynı sorun devam ediyor.

 

[halit3]

.Copy

yukarıdaki bölümü bul aşağıdaki ile değiştir.

.CopyPicture

 

[sevensuleyman]

değiştirdim maalesef olmadı resmi boş beyaz olarak kaydediyor.

.Copy

yukarıdaki bölümü bul aşağıdaki ile değiştir.

.CopyPicture

 

[Korhan Ayhan]

Vermiş olduğum linki incelediniz mi?

 

[sevensuleyman]

Vermiş olduğum linki incelediniz mi?

denedim ama olmadı . yapamadım galiba size zahmet uyarlayabilirmisiniz

 

[halit3]

kod

Private Sub CommandButton2_Click()
Dim Alan As Range
Dim Dosya As String

klasor = ThisWorkbook.Path
say = CreateObject("Scripting.FileSystemObject").GetFolder(klasor).Files.Count + 1
Dosya = klasor & "\Kampanya " & Range("B3") & Format(Now, "( dd_mm_yyyy_hh_nn_ss )") & ".jpg"

Set Alan = ActiveSheet.Range("B8")

Alan.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With ActiveSheet.ChartObjects.Add(Left:=Alan.Left, Top:=Alan.Top, Width:=Alan.Width, Height:=Alan.Height)
.Name = "TempChart"
.Activate
End With

ActiveChart.Paste
With ActiveSheet.ChartObjects("TempChart")
.Chart.Export (Dosya)
.Delete
End With

Set Alan = Nothing
End Sub

 

[sevensuleyman]

kod

Private Sub CommandButton2_Click()
Dim Alan As Range
Dim Dosya As String

klasor = ThisWorkbook.Path
say = CreateObject("Scripting.FileSystemObject").GetFolder(klasor).Files.Count + 1
Dosya = klasor & "\Kampanya " & Range("B3") & Format(Now, "( dd_mm_yyyy_hh_nn_ss )") & ".jpg"

Set Alan = ActiveSheet.Range("B8")

Alan.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With ActiveSheet.ChartObjects.Add(Left:=Alan.Left, Top:=Alan.Top, Width:=Alan.Width, Height:=Alan.Height)
.Name = "TempChart"
.Activate
End With

ActiveChart.Paste
With ActiveSheet.ChartObjects("TempChart")
.Chart.Export (Dosya)
.Delete
End With

Set Alan = Nothing
End Sub

teşekkürler sorunsuz çalıştı. kolay gelsin