121. Jak wyeksportować fragment arkusza do obrazka w wysokiej rozdzielczości?

Dosyć niedawno stanąłem przed bardzo łatwym z pozoru zadaniem, wyeksportowania zakresu komórek (zawierającego m.in. wykres) do pliku graficznego. Warunki dotyczące tego obrazka były dwa: po pierwsze – koniecznie musiał to być format PNG, po drugie – zdjęcie musiało być świetnej jakości (służyło ono w celach wizualizacji i miało być wyświetlane na kilku wielkich monitorach).

Jak to czasami bywa w życiu (programisty VBA) prace nad częścią projektu mogą się nieoczekiwanie wydłużyć. Wiedziałem, że Excel nie oferuje żadnego prostego sposobu na wyeksportowanie zakresu komórek do formatu graficznego (przydałaby się jakaś metoda typu ExportToPicture dla obiektu Range). Wiedziałem też jednak, że istnieje sposób na eksport wykresu do pliku graficznego. Nie wszystko więc stracone!

Najpierw przeszukałem jednak internet w poszukiwaniu jakiegoś makra opartego o funkcje API i trafiłem na bardzo dobry kod. Niestety funkcja nie spełniała pierwszego warunku (format docelowy to EMF) i pomimo świetnej jakości screena, musiałem wrócić do punktu wyjścia. Później znalazłem w internecie inny kod, wraz z bardzo cenną informacją na temat tego, w jaki sposób poprawić jakość obrazka.

Oczywiście wszystko trzeba było zrobić okrężną drogą:

• (opcjonalnie) dodać nowy, tymczasowy arkusz
• utworzyć w nim nowy wykres o wymiarach identycznych z zakresem komórek
• zrobić screen zakresu komórek i wkleić go właśnie w miejsce wykresu
• wyeksportować wykres do pliku graficznego
• (opcjonalnie) skasować tymczasowy arkusz

I właśnie w tym ostatnim linku przeczytałem, że aby zwiększyć rozdzielczość/jakość tego końcowego pliku graficznego, należy zwiększyć jego skalę (powiększyć dwu lub trzykrotnie) zaraz po wklejeniu w obszar wykresu, ale tuż przed eksportem. Taka operacja co prawda mocno zwiększy rozmiar pliku, ale plik zyska na jakości. Mogę potwierdzić, że tak faktycznie jest, ale często w momencie eksportu Excel się zawieszał (sprawdzone na dwóch komputerach), więc ostatecznie zdecydowałem się, że nie będę wpływał na rozmiar obrazka (Klient zaakceptował tą oryginalną jakość).

Kod, który realizuje to zadanie zamieszczam poniżej. Makro główne wywołuje jedynie funkcję główną, która posiada dwa argumenty: zakres komórek do wyeksportowania, docelowa lokalizacja pliku graficznego. Zakres nazywa się Layout, natomiast lokalizacją jest zaszyta w stałej.

'// Autor    : Mariusz Jankowski

Private Const msMODUL As String = "MEksportDoObrazka"
Option Explicit

Public Sub MakroGlowne()

    Const sPROC As String = "MakroGlowne"
    Const sLOKALIZACJA_PNG As String = "C:\Users\Mariusz\Desktop\Layout.PNG"

    'Wywołaj makro eksportujące
1   EksportujDoPng wksLayout.Range("Layout"), sLOKALIZACJA_PNG

End Sub

Public Sub EksportujDoPng(ByRef rngEksport As Range, ByVal sSciezkaDoPng As String)

    '// Makro eksportuje zakres komórek do pliku graficznego PNG.
    '// Procedura posiada dwa argumenty: pierwszy to obszar do wyeksportowania,
    '// drugi natomiast to pełna lokalizacja pliku na dysku

    Dim wksTemp As Worksheet
    Dim objWykres As ChartObject
    Dim objCzart As Chart
    Const iSKALA As Integer = 1

    Const sPROC As String = "EksportujDoPng"

    'Aktywuj obsługę błędów na starcie
1   On Error GoTo ObslugaBledu

    'Dodaj arkusz tymczasowy
2   Set wksTemp = ThisWorkbook.Sheets.Add

    'Dodaj wykres rozmiarem identyczny z zakresem komórek
3   With rngEksport
4       Set objWykres = wksTemp.ChartObjects.Add(.Left, .Top, .Width, .Height)
5   End With
6   Set objCzart = objWykres.Chart

    'Kopiuj zakres jako obrazek
7   rngEksport.CopyPicture xlScreen, xlPicture
8   objCzart.Paste

    'Uwaga! W razie potrzeby podaj większą wartość dla stałej iSKALA
9   With wksTemp
10      .Shapes(1).ScaleWidth iSKALA, msoFalse, msoScaleFromTopLeft
11      .Shapes(1).ScaleHeight iSKALA, msoFalse, msoScaleFromTopLeft
12  End With

    'Eksportuj wykres do pliku graficznego
13  objCzart.Export Filename:=sSciezkaDoPng, FilterName:="PNG"

    'Skasuj arkusz tymczasowy
14  Application.DisplayAlerts = False
15  wksTemp.Delete
16  Application.DisplayAlerts = True

Wyjscie:
17  Set wksTemp = Nothing
18  Set objWykres = Nothing
19  Set objCzart = Nothing
20  On Error GoTo 0
21  Exit Sub

ObslugaBledu:
22  Application.ScreenUpdating = True
23  MsgBox "Wystąpił błąd nr " & Err.Number & " (" & Err.Description & ")." & _
           vbCr & vbCr & "Linia kodu nr " & Erl & " w procedurze " & _
           "'" & sPROC & "' modułu '" & msMODUL & "'.", vbInformation, "BŁĄD!"
24  Resume Wyjscie

End Sub

Taki oto zakres komórek (zawierający wykres) został zapisany do pliku graficznego. Część projektu wykonana, można przejść do następnej :).