Creating Image From Selected Cells And Saving
An image is created
from the selected cell or cells. The generated images are saved to the in the same
location with workbook.
Image names are checked and each recorded image is saved with a different name.
For
example : myimage1.jpg, myimage2.jpg
Codes that provide us to build the image:
The following function is used to check the image name and save the image with a different name:
Codes that provide us to build the image:
Sub CopyRangeToJpg()
Dim rng As Excel.Range
Dim cht As Excel.ChartObject
Dim alan As String
Dim i As Long
Dim strPath As String
strPath = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
alan = Selection.Address
For i = 1 To 1
Set rng = Sheets(i).Range(alan)
rng.CopyPicture xlScreen, xlPicture
Set cht = Sheets(i).ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
cht.Chart.Paste
cht.Chart.Export DosyaKontrolu(strPath, "myimage", ".jpg", i)
cht.Delete
ExitProc:
Application.ScreenUpdating = True
Set cht = Nothing
Set rng = Nothing
Next
End Sub
Dim rng As Excel.Range
Dim cht As Excel.ChartObject
Dim alan As String
Dim i As Long
Dim strPath As String
strPath = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
alan = Selection.Address
For i = 1 To 1
Set rng = Sheets(i).Range(alan)
rng.CopyPicture xlScreen, xlPicture
Set cht = Sheets(i).ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
cht.Chart.Paste
cht.Chart.Export DosyaKontrolu(strPath, "myimage", ".jpg", i)
cht.Delete
ExitProc:
Application.ScreenUpdating = True
Set cht = Nothing
Set rng = Nothing
Next
End Sub
The following function is used to check the image name and save the image with a different name:
Private Function DosyaKontrolu(DosyaYolu As String, DosyaOnEk As String, DosyaUzanti As String, Sayi As Long) As String
Dim fso As Object
Dim Kontrol As Boolean
Dim TamDosyaYolu As String
Set fso = CreateObject("Scripting.FileSystemObject")
With fso
Do
TamDosyaYolu = DosyaYolu & DosyaOnEk & Sayi & DosyaUzanti
Kontrol = fso.FileExists(TamDosyaYolu)
Sayi = Sayi + 1
Loop Until Not Kontrol
DosyaKontrolu = TamDosyaYolu
End With
Set fso = Nothing
End Function
Dim fso As Object
Dim Kontrol As Boolean
Dim TamDosyaYolu As String
Set fso = CreateObject("Scripting.FileSystemObject")
With fso
Do
TamDosyaYolu = DosyaYolu & DosyaOnEk & Sayi & DosyaUzanti
Kontrol = fso.FileExists(TamDosyaYolu)
Sayi = Sayi + 1
Loop Until Not Kontrol
DosyaKontrolu = TamDosyaYolu
End With
Set fso = Nothing
End Function
please show the vba code how to do this
ReplyDeleteDear sir,
ReplyDeletewill you give me the vba code for this "create a image from cell".......Please I need it much.....please send me to bhaiswarpravin@gmail.com
Your the besst
ReplyDeleteGrreat post thanks
ReplyDelete