Error in Export Range as image

[Shinod]

Sub SaveAsJPG()

    Dim ChO As ChartObject, ExportName As String
    Dim CopyRange As Range
    Dim Pic As Picture
    Dim i As Long

    Dim Fold As String
    Dim Name As String
    Dim Path As String

    Fold = ActiveSheet.Range("R1")
    Name = ActiveSheet.Range("H3").Value & " " & ActiveSheet.Range("D3").Value
    Path = Fold & Application.PathSeparator & Name & ".jpg"

    With ActiveSheet
        Set CopyRange = Range("B1:I43")
        If Not CopyRange Is Nothing Then
            Application.ScreenUpdating = False
            ExportName = Path
            If Not ExportName = "False" Then
                CopyRange.Copy
                .Pictures.Paste
                Set Pic = .Pictures(.Pictures.Count)
                Set ChO = .ChartObjects.Add(Left:=10, Top:=10, Width:=Pic.Width, Height:=Pic.Height)
                Application.CutCopyMode = False
                Do
                    DoEvents
                    Pic.Copy
                    DoEvents
                    ChO.Chart.Paste
                    DoEvents
                    i = i + 1
                Loop Until (ChO.Chart.Shapes.Count > 0 Or i > 50)

                ChO.Chart.Export Filename:=ExportName, Filtername:="JPG"
                ChO.Delete
                Pic.Delete
            End If
            Application.ScreenUpdating = True
        End If
    End With
    MsgBox "Payslip created for " & ActiveSheet.Range("D3") & " in " & Fold
End Sub

 

[NdNoviceHlp]

Hi Shinod. Here's some more flexible code. A couple of things. Using "Name" and/or "Path" as variable names is not good as these have specific XL meaning(s). Not certain what is in your cells that name your file but sometimes XL doesn't like the name you have come up with. If you repeat copying and pasting pictures, your clipboard will eventually crash hence the clipboard code below. HTH. Dave
Regular code....

Sub SaveAsJPG()
Dim Fold As String, FlName As String, ExportName As String
Fold = ActiveSheet.Range("R1")
FlName = ActiveSheet.Range("H3").Value & " " & ActiveSheet.Range("D3").Value
ExportName = Fold & Application.PathSeparator & ValidFilePath(FlName) & ".jpg"
Call CreateJpg(ActiveSheet.Name, ActiveSheet.Range("B1:I43"), ExportName)
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
MsgBox "Payslip created for " & ActiveSheet.Range("D3") & " in " & Fold
End Sub

Sub CreateJpg(SheetName As String, xRgAddrss As Range, NameFile As String)
xRgAddrss.CopyPicture
With Sheets(SheetName).ChartObjects.Add(xRgAddrss.Left, xRgAddrss.Top, xRgAddrss.Width, xRgAddrss.Height)
.Activate
.Chart.Paste
.Chart.Export NameFile, "JPG"
End With
Sheets(SheetName).ChartObjects(Sheets(SheetName).ChartObjects.Count).Delete
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

Module code...

#If VBA7 Then
Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
#Else
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
#End If

To operate...

Call SaveAsJPG

 

[Shinod]

Hi Shinod. Here's some more flexible code. A couple of things. Using "Name" and/or "Path" as variable names is not good as these have specific XL meaning(s). Not certain what is in your cells that name your file but sometimes XL doesn't like the name you have come up with. If you repeat copying and pasting pictures, your clipboard will eventually crash hence the clipboard code below. HTH. Dave
Regular code....

Sub SaveAsJPG()
Dim Fold As String, FlName As String, ExportName As String
Fold = ActiveSheet.Range("R1")
FlName = ActiveSheet.Range("H3").Value & " " & ActiveSheet.Range("D3").Value
ExportName = Fold & Application.PathSeparator & ValidFilePath(FlName) & ".jpg"
Call CreateJpg(ActiveSheet.Name, ActiveSheet.Range("B1:I43"), ExportName)
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
MsgBox "Payslip created for " & ActiveSheet.Range("D3") & " in " & Fold
End Sub

Sub CreateJpg(SheetName As String, xRgAddrss As Range, NameFile As String)
xRgAddrss.CopyPicture
With Sheets(SheetName).ChartObjects.Add(xRgAddrss.Left, xRgAddrss.Top, xRgAddrss.Width, xRgAddrss.Height)
.Activate
.Chart.Paste
.Chart.Export NameFile, "JPG"
End With
Sheets(SheetName).ChartObjects(Sheets(SheetName).ChartObjects.Count).Delete
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

Module code...

#If VBA7 Then
Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
#Else
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
#End If

To operate...

Call SaveAsJPG

Dear @NdNoviceHlp Thank you for your reply. I was looking for a solution for this for a long time.

The purpose is to create payslips in "Image".

So will you be kind enough to go through my sheet, please?

As you said when creating image files excel is getting errors sometimes. Someone suggested me to put some delay to overcome this error. but that one also didnt help me much.

Here is the file, could you please fix for me.

The purpose is to create payslip (s) based on the selection. if there is some other way to achieve this goal, then suggest me.

Thanks in advance.

Master Sheet August 2022.xlsm

Microsoft Excel Workbook

1drv.ms

 

[NdNoviceHlp]

Shinod did you trial the code posted? In my limited testing, it created a .jpg file containing the specified range which is what you seemed to be requesting. Not sure that looking at your file will help if I don't know what is actually going wrong? If there is some error, please indicate on what line of code the error occurs. Dave