Opgelost Opslaan van Excel-range als mooi grafisch bestand

[keb]

ik wil een ruim Excel-bereik (91 regels, 16 kolommen) opslaan als jpg.

In bijgaande sketch werkt methode 1 goed (maar omslachtig).
Methode 2, waarbij ik naar een grafiek kopieer - levert een onjuist plaatje.

Wie kent een mooie methode om het clipboard AUTOMATISCH naar een grafisch programma te kopiëren. (bijvoorbeel IrfanView, maar mag ook een ander grafisch programma zijn.

Sub Export_Excelselectie_jpg()
'Macro om reeds geslecteerd bereik in Excel als jpg op te slaan
'Selecteer vooraf een bereik
'Activeer daarna deze macro om het geslecteerde bereik als jpg op te slan

Dim ws As Worksheet
Dim Rng As Range
Dim Chrt As Chart
Dim ExportPath As String
Dim filename As String

Set ws = ActiveSheet
'Set Rng = Sheets("Kwartierstaat").Range("A1:P91")  'Eerste blad van kwartierstaat, werkt goed
Set Rng = Selection '

'Geef bestandsnaam op (niet foolproof)
filename = InputBox("Bestandsnaam", "Geef bestandsnaam op zonder extensie")
ExportPath = "D:\_Temp\Screenshots" & "\" & filename & ".jpg"
'MsgBox ExportPath

'Methode 1
Rng.Copy  'Copy to clipboard, importeren in grafisch programma, levert een mooi plaatje op

'Methode 2
'Levert een verwrongen plaatje op
Set Chrt = ThisWorkbook.Charts.Add
Rng.CopyPicture xlScreen, xlBitmap
With Chrt
    .Paste
    .Export filename:=ExportPath, Filtername:="JPG"
End With

Application.DisplayAlerts = False
ActiveSheet.Delete      'remove chart
Application.DisplayAlerts = True

MsgBox "Screenshot is opgeslagen in map SCREENSHOTS)"

End Sub

 

[HSV]

Wat levert dit op?

Sub hsv()
dim filename as string
filename = InputBox("Bestandsnaam", "Geef bestandsnaam op zonder extensie")
Range("A1:P91").CopyPicture , xlPicture
   With ActiveSheet.ChartObjects.Add(0, 0, 450, 400).Chart
      .Paste
      .Export "D:\_Temp\Screenshots" & filename & ".jpg","jpg"
      .Parent.Delete
   End With
End Sub

 

[AHulpje]

Zo misschien:

 

[keb]

Wat levert dit op?

Sub hsv()
dim filename as string
filename = InputBox("Bestandsnaam", "Geef bestandsnaam op zonder extensie")
Range("A1:P91").CopyPicture , xlPicture
   With ActiveSheet.ChartObjects.Add(0, 0, 450, 400).Chart
      .Paste
      .Export "D:\_Temp\Screenshots" & filename & ".jpg","jpg"
      .Parent.Delete
   End With
End Sub

Met de grenzen van 450 en 400 wordt de resolutie van de jpg zeer klein.
Mogelijk moet ik spelen met de grenzen van de Chart.

 

[keb]

AHulpje, met uw oplossing en enkele aanpassingen werkt alles.
BEDANKT

 

[keb]

Hierbij de uiteindelijke code

Sub Range2JPG()
'macro om van een vastgedefineerd of flexibel celbereik een grafisch bestand te maken.

Dim ws As Worksheet
Dim rng As Range
Dim Chrt As Chart
Dim pic As Picture
Dim i As Long
Dim strExportPath As String
Dim strFilename As String

Set ws = ActiveSheet
'Kies een flexibel of vast celbereik om een grafisch bestand van te maken
'Set rng = Sheets("Kwartierstaat").Range("A1:P91") 
Set rng = Selection

strExportPath = "D:\_Temp\Screenshots\" 'Default outputmap
'Geef bestandsnaam op (niet foolproof)
strFilename = InputBox("Bestandsnaam", "Geef bestandsnaam op zonder extensie")

'Methode 1
rng.Copy  'Copy to clipboard, later importeren in grafisch programma

'Methode 2  'Levert een jpg-bestand op in de defaultmap
With ActiveSheet
   .Pictures.Paste
   Set pic = .Pictures(.Pictures.Count)
   With .ChartObjects.Add(Left:=10, Top:=10, Width:=pic.Width, Height:=pic.Height)
         Application.CutCopyMode = False
         Do
            'Kan even duren, daarom een loopje
             DoEvents
             pic.Copy
             DoEvents
             .Chart.Paste
             DoEvents
             i = i + 1
             Loop Until (.Chart.Shapes.Count > 0 Or i > 50)
               .Chart.Export Filename:=strExportPath & strFilename & ".jpg", Filtername:="JPG"
               .Delete
               pic.Delete
            End With
        End With
End Sub

 

[HSV]

Ik krijg hier een plaatje van pak hem beet een halve centimeter breed met maar twee kolommen met die code.
Geen idee waar jij het plaatje in opent.

 

[keb]

De grootte van het het plaatje wordt bepaald door het vooraf geselecteerde bereik (set rng = selection).
Deze macro heb ik gekoppeld aan een groot gegevensbestand.

 

[HSV]

Ha, oké.
Ik zag alleen maar de aangegeven range staan.

 

[HSV]

Deze verkorte code ziet er in mijn beleving prima uit.
Juiste grootte en niet wazig bij vergroting.

Sub hsv()
Dim c As Range, strFilename As String
Set c = Range("a1:P91")
strFilename = InputBox("Bestandsnaam", "Geef bestandsnaam op zonder extensie")
If strFilename <> "" Then
 c.CopyPicture
   With ActiveSheet.ChartObjects.Add(10, 10, c.Width, c.Height).Chart
    .Parent.Activate
    .Paste
    .Export "D:\_Temp\Screenshots\" & strFilename & ".jpg", "jpg"
    .Parent.Delete
   End With
 End If
End Sub