DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub Resim_Kaydet()
Dim rsm As Shape, yol As String, sat As Long, grf As Object
yol = "C:\Users\sami\"
Application.ScreenUpdating = False
For Each rsm In ActiveSheet.Shapes
sat = rsm.TopLeftCell.Row
rsm.Copy
Set grf = ActiveSheet.ChartObjects.Add(0, 0, rsm.Width, rsm.Height)
grf.Chart.Paste
grf.Chart.Export yol & Cells(sat, "S") & ".jpg"
grf.Delete
Next rsm
Application.ScreenUpdating = True
End Sub
Sub Resim_Kaydet()
Dim rsm As Shape, yol As String, sat As Long, grf As Object
yol = "C:\Users\sami\"
Application.ScreenUpdating = False
For Each rsm In ActiveSheet.Shapes
sat = rsm.TopLeftCell.Row
rsm.Copy
Set grf = ActiveSheet.ChartObjects.Add(0, 0, rsm.Width, rsm.Height)
grf.Chart.Paste
grf.Chart.Export yol & Cells(sat, "S") & ".jpg"
grf.Delete
Next rsm
Application.ScreenUpdating = True
End Sub
Sub foto()
Dim masaustu As String
Dim ad As String
Dim yol As String
Dim caart As Chart
Dim jipeg As Range
Dim x As Long
masaustu = "C:\Users\sami\"
ad = "test"
For x = 1 To 2000
If Dir(masaustu & ad & x & ".PNG") = "" Then
yol = masaustu & ad & x & ".PNG"
Exit For
End If
Next x
Application.ScreenUpdating = False
Set jipeg = ActiveSheet.Range("A1:M21")
jipeg.CopyPicture
Set caart = ActiveSheet.ChartObjects.Add(1, 1, jipeg.Width, jipeg.Height).Chart
caart.Paste
caart.Export yol, "PNG"
caart.Parent.Delete
Application.ScreenUpdating = True
Set jipeg = Nothing
Set caart = Nothing
End Sub
Korhan bey altta var buyrun ,Küçük bir örnek dosya paylaşırsanız deneme fırsatımız olacaktır.
Sub foto()
Dim masaustu As String
Dim ad As String
Dim yol As String
Dim caart As Chart
Dim jipeg As Range
Dim x As Long
masaustu = "C:\Users\sami\"
ad = "test"
For x = 1 To 2000
If Dir(masaustu & ad & x & ".PNG") = "" Then
yol = masaustu & ad & x & ".PNG"
Exit For
End If
Next x
Application.ScreenUpdating = False
Set jipeg = ActiveSheet.Range("A1:M21")
jipeg.CopyPicture
Set caart = ActiveSheet.ChartObjects.Add(1, 1, jipeg.Width, jipeg.Height).Chart
Application.Wait (Now + TimeValue("0:00:02"))
caart.Paste
Application.Wait (Now + TimeValue("0:00:02"))
caart.Export yol, "PNG"
caart.Parent.Delete
Application.ScreenUpdating = True
Set jipeg = Nothing
Set caart = Nothing
End Sub
Linkte paylaştığım kodlardan faydalandım.
Eki deneyiniz..
"Makro Dosyası" isimli dosyayı açıp butona tıklayınız..
Not : Kodun çalışması için sisteminizde 64 Bit Winrar programının yüklü olması gerekir. Eğer sizde 32 bit yüklüyse makroda değişiklik yapmak gerekecektir.
Harici Link (Silinebilir) ; https://s2.dosya.tc/server25/9dktxa/Deneme.rar.html
F8 olmadan direkt bu kodu dener misiniz.
C#:Sub foto() Dim masaustu As String Dim ad As String Dim yol As String Dim caart As Chart Dim jipeg As Range Dim x As Long masaustu = "C:\Users\sami\" ad = "test" For x = 1 To 2000 If Dir(masaustu & ad & x & ".PNG") = "" Then yol = masaustu & ad & x & ".PNG" Exit For End If Next x Application.ScreenUpdating = False Set jipeg = ActiveSheet.Range("A1:M21") jipeg.CopyPicture Set caart = ActiveSheet.ChartObjects.Add(1, 1, jipeg.Width, jipeg.Height).Chart Application.Wait (Now + TimeValue("0:00:02")) caart.Paste Application.Wait (Now + TimeValue("0:00:02")) caart.Export yol, "PNG" caart.Parent.Delete Application.ScreenUpdating = True Set jipeg = Nothing Set caart = Nothing End Sub