Range to jpeg

[PIsabel]

Hello.
I have this table with inserted data (first image)
I either have tables with two or three articles or sometimes I have tables with 100 or 200 articles.

In one of the forums I already found a code that creates and converts a certain area into an image and stores it in a folder.
The code works very well.

I need the code to run all the codes in the table and create an image for each of the codes and save the image with the name of that code

Can anyone help me?

 

[PIsabel]

I already have this code

Sub Range_To_Image()
  Dim objChrt As Chart
  Dim rngImage As Range
  Dim strFile As String

 
  On Error GoTo ErrExit

  With Sheets("folha1") 'Tabellenname - Anpassen!

    Set rngImage = .Range("A2:C5")

    rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

    strFile = "C:\Users\Utilizador\Documents\. enviar\haus.jpg" 'Pfad und Dateiname für das Bild

    Set objChrt = .ChartObjects.Add(rngImage.Left, rngImage.Top, rngImage.Width, rngImage.Height).Chart

    With objChrt
        .Parent.Activate 'to avoid exporting an empty file
        .ChartArea.Format.Line.Visible = msoFalse 'remove border from chart
        .Paste
        .Export strFile
        .Parent.Delete
    End With

  End With

ErrExit:
  Set objChrt = Nothing
  Set rngImage = Nothing
 

End Sub

 

[NdNoviceHlp]

Hi Plsabel. It seems like the code posted at the following link will do what you want. HTH. Dave

Save Images to Folder

Hello Everyone ! I have few excel with heavy database in which there is one column of images and one column with its model number. Is there any guide to save all images in bulk with it model # describe in other column. ( Many times there are merge cells also ) Any help will be a great time...

www.mrexcel.com

 

[PIsabel]

Hello.
This is not exactly the code I need.
This code you sent saves the existing images on a sheet.
That's not what I'm looking for!!!
I need a macro that creates images of a certain area.
The code I put here does what I need but only for the first 4 rows of the table.
Basically I just need to run this code and create the image of these 4 lines and 3 columns and save that image with the code of that image and move on to the next 4 lines and all the next 4 on the sheet

VBA Code:
Sub Range_To_Image()
Dim objChrt As Chart
Dim rngImage As Range
Dim strFile As String

 
On Error GoTo ErrExit

With Sheets("folha1") 'Tabellenname - Anpassen!

Set rngImage = .Range("A2:C5")

rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

strFile = "C:\Users\Utilizador\Documents\. enviar\haus.jpg" 'Pfad und Dateiname für das Bild

Set objChrt = .ChartObjects.Add(rngImage.Left, rngImage.Top, rngImage.Width, rngImage.Height).Chart

 With objChrt
.Parent.Activate 'to avoid exporting an empty file
.ChartArea.Format.Line.Visible = msoFalse 'remove border from chart
 .Paste
 .Export strFile
.Parent.Delete
End With

End With

ErrExit:
Set objChrt = Nothing
Set rngImage = Nothing
 

End Sub

 

[NdNoviceHlp]

Hi again Plsabel. My misunderstanding!!! You can trial this code... it's hard to test without your wb. Change the sheet name and folder name to suit. To operate, run the testthis sub. Dave

Sub testthis()
'pics in Sheet1 "A2: A whatever". File names 2 columns to right of pic
Dim MyChart As Chart, FilStr As String, Rng As Range, ws As String
Dim RowStart As Integer, LastRow As Integer, Cnt As Integer, FolderLoc As String
'****adjust folderpath to suit
FolderLoc = "C:\testfolder\"
'******adjust sheet name to suit
ws = "Sheet1"

On Error GoTo Below
Application.ScreenUpdating = False
'add temp chart
Charts.Add.Location Where:=xlLocationAsObject, Name:=ws
Sheets(ws).ChartObjects(Sheets(ws).ChartObjects.Count).Name = "MYChart"
RowStart = 2
With Sheets(ws)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Cnt = RowStart To LastRow Step 4
Set Rng = .Range(.Cells(Cnt, 1), .Cells(Cnt + 3, 1))
FilStr = CStr(.Cells(Cnt, 1).Offset(, 2).Value)
Call CreateJPG(FilStr, FolderLoc, ws, Rng)
Next Cnt
End With

'remove temp chart
Sheets(ws).ChartObjects("MYChart").Delete
Below:
Application.ScreenUpdating = True
If Err.Number <> 0 Then
MsgBox "Error"
End If
End Sub

Sub CreateJPG(FileNm As String, FolderLoc As String, SheetName As String, xRgAddrss As Range)
'make image files
ThisWorkbook.Worksheets(SheetName).Activate
xRgAddrss.CopyPicture
'size chart to Rng cell
With Sheets(SheetName).ChartObjects("MYChart").Chart
.Parent.Height = xRgAddrss.Height
.Parent.Width = xRgAddrss.Width
.Parent.Top = xRgAddrss.Top
.Parent.Left = xRgAddrss.Left
End With
'make file in wb path
With Sheets(SheetName).ChartObjects("MYChart")
.Activate
.Chart.Paste
.Chart.Export FolderLoc & ValidFilePath(FileNm) & ".jpg", "JPG"
End With
End Sub

Public Function ValidFilePath(Arg As String) As String
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
    .Pattern = "[\\/:\*\?""<>\|]"
    .Global = True
    ValidFilePath = .Replace(Arg, "_")
End With
Set RegEx = Nothing
End Function

 

[PIsabel]

Hello.
Thanks for the code but it's more than I can follow, adapt or change.
The code made an error and I can't even figure out where.
The code I have does exactly what I need but only for an area pre-defined by me.
I just need to run this code for all sets of 4 lines.
In other words: every 4 lines I need the code to create the image and save it with the code name of those 4 lines.

 

[NdNoviceHlp]

I understand your needs and the code you posted. The code provided does what you want however you need to adjust the sheet name and folder location. I'm not sure about your sheet setup and it would be a whole lot easier if you posted a wb. "The code made an error" doesn't really tell me much... what kind of error and where? You can comment out (place an apostrophe at the start of the code line) these 2 lines of code and find out where the error is..

'On Error GoTo Below
'Application.ScreenUpdating = False

Anyways, I suspect that it may be your file name. So you can trial adding a msgbox to find out what's going on...

FilStr = CStr(.Cells(Cnt, 1).Offset(, 2).Value)
msgbox FilStr

Dave

 

[PIsabel]

the code opens a graph sheet and triggers this "error"

'remove temp chart
Sheets(ws).ChartObjects("MYChart").Delete
Below:
Application.ScreenUpdating = True
If Err.Number <> 0 Then
MsgBox "Error"
End If
End Sub

 

[NdNoviceHlp]

It may have to do with your sheet set up. Are your rows in "A" merged cells? I just re-tested the code. If you want to trial it, create a folder on your "C" drive and name it "TestFolder". Open a new wb, paste the code in the sheet1 code, type whatever in A2 to A somewhere (more than 4 rows), type whatever in C2 to C the same somewhere, and run the testthis sub. Your testfolder will have images of 4 rows of "A" starting at A2 to whatever. The images are named by the "C" 1st row value of each "A" pic. This part of the code was missing the delete pic part which is needed to prevent having overlapping pics on the chart... so replace this part....

Sub CreateJPG(FileNm As String, FolderLoc As String, SheetName As String, xRgAddrss As Range)
'make image files
ThisWorkbook.Worksheets(SheetName).Activate
xRgAddrss.CopyPicture
'size chart to Rng cell
With Sheets(SheetName).ChartObjects("MYChart").Chart
.Parent.Height = xRgAddrss.Height
.Parent.Width = xRgAddrss.Width
.Parent.Top = xRgAddrss.Top
.Parent.Left = xRgAddrss.Left
End With
'make file in wb path
With Sheets(SheetName).ChartObjects("MYChart")
.Activate
.Chart.Paste
.Chart.Export FolderLoc & ValidFilePath(FileNm) & ".jpg", "JPG"
End With
With Sheets(SheetName).ChartObjects("MYChart").Chart
.Pictures(.Pictures.Count).Delete
End With
Set xRgAddrss = Nothing
End Sub