none
How to export excel sheet to JPG/PNG with High resolution in VBA? RRS feed

  • Question

  • Is there any way to save a Excel sheet (report) to jpg/png ?

    The excel report contains figures and a few pictures. It would be desirable to be in high resolution.

    Monday, January 30, 2012 2:07 AM

Answers

  • Are you using Excel 2007 or later?

    In that case, you can export the worksheet as a pdf. This gives a fairly good quality output.

    Sub ExportSheet()
    Dim wks As Worksheet
    Dim strName As String
    
    Set wks = ActiveSheet
    strName = InputBox("Enter name for pdf file:")
    
    wks.ExportAsFixedFormat Type:=xlTypePDF, _
                            Filename:="D:\Users\Ed\Documents\" & strName, _
                            Quality:=xlQualityStandard, _
                            OpenAfterPublish:=True
    
    End Sub
    


    Ed Ferrero
    www.edferrero.com
    • Proposed as answer by Shasur Monday, January 30, 2012 12:26 PM
    • Marked as answer by danishaniModerator Tuesday, February 14, 2012 12:12 AM
    Monday, January 30, 2012 12:18 PM
  • Hi, I can give to you 2 codes. One good, 2nd great.

    First is universal, but sometimes is hart to scale range of picture area:

    Option Explicit
    Declare Function SystemParametersInfo Lib "user32" _
          Alias "SystemParametersInfoA" (ByVal iAction As Long, _
          ByVal iParam As Long, pvParam As Any, _
          ByVal fWinIni As Long) As Long
    
    Function FEnableFontSmoothing(SwON As Boolean) As Boolean
        FEnableFontSmoothing = SystemParametersInfo(75, SwON, 0, &H1)
    End Function
    
    Function GetFontSmoothing() As Boolean
    Dim iResults As Boolean, pv As Integer
    'Get font smoothing value and return true if font smoothing is turned on.
    iResults = SystemParametersInfo(74, 0, pv, 0)
    If pv > 0 Then
        GetFontSmoothing = True
    Else
        GetFontSmoothing = False
    End If
    End Function
    
    Sub Exportuj_jako_Obrazek()
    Dim RngObraz As Range, oSheet As Worksheet
    Dim oChart As Chart, oObraz As Picture, nazwa$
    Dim Rodzaj$: Rodzaj = "png" '"bmp","jpg","gif","png")
    Dim TrueType As Boolean
    
    Application.ScreenUpdating = False
    TrueType = FEnableFontSmoothing(False)
    nazwa = "Test" ' lub z komórki Range("b1").Text & " " & Range("b2").Text
    Set RngObraz = Selection ' lub określony Range("A1:N20")
    Set oSheet = Worksheets.Add
    Charts.Add
    
    ActiveChart.Location Where:=xlLocationAsObject, name:=oSheet.name
    Set oChart = ActiveChart
    RngObraz.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    oChart.Paste
    Set oObraz = Selection
    If RngObraz.Cells.Count > 40 Then
        With oChart.Parent
            .Width = 1.2 * oObraz.Width
            .Height = 1.8 * oObraz.Height
        End With
    End If
    oChart.Export FileName:="C:\Temp\" & nazwa & "." & Rodzaj, FilterName:=Rodzaj
    
    With Application
        .DisplayAlerts = False
    oSheet.Delete
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    TrueType = FEnableFontSmoothing(True)
    End Sub

    Secound with very good quality, but ext =EMF

    'to workbook
    Sub EksportujDoObrazuEMF()
      Call EksportujObiektDoEMF(ActiveWindow.VisibleRange)
      MsgBox "Its done ;-)"
    End Sub
    
    'to seperate module
    Option Explicit
    
    Private Declare Function OpenClipboard Lib "User32" _
                                           (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "User32" () As Long
    Private Declare Function GetClipboardData Lib "User32" _
                                              (ByVal uFormat As Long) As Long
    Private Declare Function CopyEnhMetaFileA Lib "Gdi32" _
                                              (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
    Private Declare Function DeleteEnhMetaFile Lib "Gdi32" _
                                               (ByVal hdc As Long) As Long
    
    Sub EksportujObiektDoEMF(Obj As Object)
    
      Dim PlikEMF, Rep  As Long
    
      PlikEMF = ThisWorkbook.Path & "\tmp_img.emf"
      
      If Dir$(PlikEMF) <> "" Then
        Kill PlikEMF
      End If
    
      If Export2emf(Obj, PlikEMF) = "" Then
        MsgBox "Błąd przy eksporcie pliku !", vbCritical
      End If
    End Sub
    
    Private Function Export2emf(Objet As Object, _
                                NazwaPliku, Optional Apparence, _
                                Optional Format, Optional Size) As String
    
      Export2emf = NazwaPliku
    
      If TypeName(Objet.Parent) = "Chart" Then
        Objet.Parent.CopyPicture Apparence, Format, Size
      ElseIf TypeName(Objet) <> "Chart" Then
        Objet.CopyPicture Apparence, Format
      Else
        Objet.CopyPicture Apparence, Format, Size
      End If
      OpenClipboard 0
      If DeleteEnhMetaFile(CopyEnhMetaFileA(GetClipboardData(14), _
                                            Export2emf)) = 0 Then Export2emf = ""
      CloseClipboard
    End Function


    Oskar Shon, Office System MVP

    Press if Helpful; Answer when a problem solved

    Saturday, February 11, 2012 6:07 PM
    Answerer

All replies

  • You might get some ideas from this thread, and see if that helps in accomplish your goal:

    http://www.jpsoftwaretech.com/export-excel-range-to-a-picture-file-redux/

     

    Hope this helps,

     


    Daniel van den Berg | Washington, USA | "Anticipate the difficult by managing the easy"
    Monday, January 30, 2012 5:38 AM
    Moderator
  • What version of OS are you using. If using Vista or Win 7 then try Snipping Tool. You can be selective about what to select and then save to a file.

    If you can't find Snipping Tool.exe then in Vista (32 bit) I am fairly sure it is in Windows\System32 but in any case you should be able to do a search for it in Windows Explorer. You really need to create a short cut in the Quick Launch at bottom left of the screen. To do this, after finding it in windows Explorer Right click it and Send to Desktop. You can then drag the short cut into the quick launch.

    Just follow the prompts to use Snipping Tool

     

     


    Regards, OssieMac
    Monday, January 30, 2012 7:09 AM
  •  

     

     

     

     

    You might get some ideas from this thread, and see if that helps in accomplish your goal:

    http://www.jpsoftwaretech.com/export-excel-range-to-a-picture-file-redux/

     

    Hope this helps,

     


    Daniel van den Berg | Washington, USA | "Anticipate the difficult by managing the easy"

     

     

    It runs but only export the upper few rows of the sheet.

    Monday, January 30, 2012 8:14 AM
  • I am looking for ways to automate the process in VBA
    Monday, January 30, 2012 8:15 AM
  • There is graph inside the sheet which can be saved correctly.
    Monday, January 30, 2012 9:28 AM
  • I doubt if Graph will be taken as part of the range as it will be floating . There are methods to save the graph separately though.

    Let us wait for others to respond; meanwhile will check if there can be a way to do this.

    Cheers

    Shasur


    http://www.vbadud.blogspot.com http://www.dotnetdud.blogspot.com
    Monday, January 30, 2012 11:41 AM
  • Are you using Excel 2007 or later?

    In that case, you can export the worksheet as a pdf. This gives a fairly good quality output.

    Sub ExportSheet()
    Dim wks As Worksheet
    Dim strName As String
    
    Set wks = ActiveSheet
    strName = InputBox("Enter name for pdf file:")
    
    wks.ExportAsFixedFormat Type:=xlTypePDF, _
                            Filename:="D:\Users\Ed\Documents\" & strName, _
                            Quality:=xlQualityStandard, _
                            OpenAfterPublish:=True
    
    End Sub
    


    Ed Ferrero
    www.edferrero.com
    • Proposed as answer by Shasur Monday, January 30, 2012 12:26 PM
    • Marked as answer by danishaniModerator Tuesday, February 14, 2012 12:12 AM
    Monday, January 30, 2012 12:18 PM
  • It runs but only export the upper few rows of the sheet.

    I believe you can adjust the range accordingly by changing the range:

     

    Sub test()
    Dim rng As Excel.Range
    
    ' //// Change Range below accordingly! ///////
    Set rng = Range("A1:B10")
     
    If ExportRangeToPicture(rng, "C:\range.gif") Then
      MsgBox "ok!"
    Else
      MsgBox "Didn't work"
    End If
     
    End Sub
    

     

    I like Ed's solution using a PDF though.

     

    Hope this helps,

     

     


    Daniel van den Berg | Washington, USA | "Anticipate the difficult by managing the easy"
    Monday, January 30, 2012 7:38 PM
    Moderator
  • Hi, I can give to you 2 codes. One good, 2nd great.

    First is universal, but sometimes is hart to scale range of picture area:

    Option Explicit
    Declare Function SystemParametersInfo Lib "user32" _
          Alias "SystemParametersInfoA" (ByVal iAction As Long, _
          ByVal iParam As Long, pvParam As Any, _
          ByVal fWinIni As Long) As Long
    
    Function FEnableFontSmoothing(SwON As Boolean) As Boolean
        FEnableFontSmoothing = SystemParametersInfo(75, SwON, 0, &H1)
    End Function
    
    Function GetFontSmoothing() As Boolean
    Dim iResults As Boolean, pv As Integer
    'Get font smoothing value and return true if font smoothing is turned on.
    iResults = SystemParametersInfo(74, 0, pv, 0)
    If pv > 0 Then
        GetFontSmoothing = True
    Else
        GetFontSmoothing = False
    End If
    End Function
    
    Sub Exportuj_jako_Obrazek()
    Dim RngObraz As Range, oSheet As Worksheet
    Dim oChart As Chart, oObraz As Picture, nazwa$
    Dim Rodzaj$: Rodzaj = "png" '"bmp","jpg","gif","png")
    Dim TrueType As Boolean
    
    Application.ScreenUpdating = False
    TrueType = FEnableFontSmoothing(False)
    nazwa = "Test" ' lub z komórki Range("b1").Text & " " & Range("b2").Text
    Set RngObraz = Selection ' lub określony Range("A1:N20")
    Set oSheet = Worksheets.Add
    Charts.Add
    
    ActiveChart.Location Where:=xlLocationAsObject, name:=oSheet.name
    Set oChart = ActiveChart
    RngObraz.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    oChart.Paste
    Set oObraz = Selection
    If RngObraz.Cells.Count > 40 Then
        With oChart.Parent
            .Width = 1.2 * oObraz.Width
            .Height = 1.8 * oObraz.Height
        End With
    End If
    oChart.Export FileName:="C:\Temp\" & nazwa & "." & Rodzaj, FilterName:=Rodzaj
    
    With Application
        .DisplayAlerts = False
    oSheet.Delete
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    TrueType = FEnableFontSmoothing(True)
    End Sub

    Secound with very good quality, but ext =EMF

    'to workbook
    Sub EksportujDoObrazuEMF()
      Call EksportujObiektDoEMF(ActiveWindow.VisibleRange)
      MsgBox "Its done ;-)"
    End Sub
    
    'to seperate module
    Option Explicit
    
    Private Declare Function OpenClipboard Lib "User32" _
                                           (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "User32" () As Long
    Private Declare Function GetClipboardData Lib "User32" _
                                              (ByVal uFormat As Long) As Long
    Private Declare Function CopyEnhMetaFileA Lib "Gdi32" _
                                              (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
    Private Declare Function DeleteEnhMetaFile Lib "Gdi32" _
                                               (ByVal hdc As Long) As Long
    
    Sub EksportujObiektDoEMF(Obj As Object)
    
      Dim PlikEMF, Rep  As Long
    
      PlikEMF = ThisWorkbook.Path & "\tmp_img.emf"
      
      If Dir$(PlikEMF) <> "" Then
        Kill PlikEMF
      End If
    
      If Export2emf(Obj, PlikEMF) = "" Then
        MsgBox "Błąd przy eksporcie pliku !", vbCritical
      End If
    End Sub
    
    Private Function Export2emf(Objet As Object, _
                                NazwaPliku, Optional Apparence, _
                                Optional Format, Optional Size) As String
    
      Export2emf = NazwaPliku
    
      If TypeName(Objet.Parent) = "Chart" Then
        Objet.Parent.CopyPicture Apparence, Format, Size
      ElseIf TypeName(Objet) <> "Chart" Then
        Objet.CopyPicture Apparence, Format
      Else
        Objet.CopyPicture Apparence, Format, Size
      End If
      OpenClipboard 0
      If DeleteEnhMetaFile(CopyEnhMetaFileA(GetClipboardData(14), _
                                            Export2emf)) = 0 Then Export2emf = ""
      CloseClipboard
    End Function


    Oskar Shon, Office System MVP

    Press if Helpful; Answer when a problem solved

    Saturday, February 11, 2012 6:07 PM
    Answerer