Excel 2010 uložení jako obrázek pomocí vba

při otevření obrázku v malování, Windows prohlížeč fotografií nebo Photo Gallery při přiblížení dochází nejspíš ke kompresi a je to docela špatně čitelné. Řešení jsem našel otevřít to např. v IE

Chceš říct, že jeden a tentýž obrázek otevřený v těch třech programech vypadá jinak než v IE? Jakože ty tři ten obrázek zmrší? Nebo naopak IE z nekvalitního obrázku vytáhne víc než ty tři ostatní? Tak to bych rád viděl... Zkus to nějak odchytit a ukázat... Taky přilož ten uložený obrázek PNG.

Každopádně když jsem testoval jak excel převádí na obrázek, tak se zdá, že při zvolení varianty Format:=xlBitmap jsou výsledky lepší než pro Format:=xlPicture - má to o něco větší rozlišení a zřejmě používá antialiasing nebo něco podobného pro vylepšení obrazu.

Format:=xlPicture

Format:=xlBitmap

Máš pravdu, asi jsem po těch hodinách čumění do PC viděl to co není :D

Jak to teda mám udělat ?

edit. Zkoušel jsem to uložit jako PDF, ale PDF oseká tabulku (má velikost A1:O44), ve výsledku tam jsou asi 4 sloupce, což je nežádoucí.

Tady máš ten můj testovací kód, který funguje - jen si pohlídej rozsah co se má exportovat, jestli ti to bere jen pět sloupců a ty tam máš ještě další popsané sloupce, zkontroluj, jestli jsou obsazené i v prvním řádku! Případně si najdi kód, který prohledá celou tabulku a najde ten rozsah lépe...

Sub ObrazekDoSouboru()

    strLocation = "D:\"
    strFileName = "TestExcel.png"    'Here you put the name of your png file
    Dim rng As Excel.Range

'Set rng = Range("A1:O44")  buď použij rozsah napevno
'Find the last used row in a Column: column A in this example
'Nebo si ho nech vyhledat podle poslední obsazené buňky v řádku 1 a poslední buňky ve sloupci A

Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'MsgBox LastRow
'Find the last used column in a Row: row 1 in this example
Dim LastCol As Integer
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'MsgBox LastCol

Set rng = Range("A1", Cells(LastRow, LastCol))

    rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
With ActiveSheet.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
        .Name = "ChartForExport"
        .Activate
    End With
    ActiveChart.Paste
    ActiveSheet.ChartObjects("ChartForExport").Chart.Export Filename:=strLocation & "\" & strFileName, Filtername:="png"
    ActiveSheet.ChartObjects("ChartForExport").Delete

End Sub

Tu velikost jsem ošetřil tak, že jsem v Excelu nastavit: Tisk -> měřítko -> přizpůsobit všechny sloupce na jednu stránku (všiml jsem si že PDF vychází z toho jak ej to rozložené na tisk)

Btw. PDF se dokáže zjistit velikost (rozsah) kam až sahá ten sešit, ale vychází z toho co bylo změněno/upraveno, čili šéf, tam má předpřipravenou tabulku (ohraničení) až někam do nekonečna, a pdf to bere jako že tam něco je, takže tam do toho vezme i to ohraničení tabulky kde nejsou data.

Podívám se na ten tvůj kód, uvidíme jak to bude fungovat.

Zatím moc díky.

Makro jsem zkusil, funguje dobře, ale kvalita obrázku je velice mizerná. Asi bude opravdu nejlepší přes to PDF.

Uvidím co mi na to řekne šéf, moc děkuju všem a přejí hezký den.

U mě ta kvalita odpovídá nastavená lupy v Excelu (ono to defakto odchytává v kvalitě zobrazení na monitoru). Když to chceš kvalitnější, dej větší lupu:
Lupa 25%

Lupa 100%

Lupa 200%