Obrazek Wysokiej Jakości z Zakresu

Niedawno stanąłem przed, łatwym z pozoru, zadaniem wyeksportowania zakresu komórek do pliku graficznego.

Wymogi Zadania

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 (dla każdej linii produkcyjnej).

Szukanie Rozwiązania

Jak to czasem 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.

Kolejność Działań

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

Skalowanie Obrazka

I właśnie w tym ostatnim linku przeczytałem, że aby polepszyć jakość tego końcowego pliku graficznego, należy zwiększyć jego skalę. Powiększyć go 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ł oryginalną jakość).

Kod Makra

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.

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

Screen z Rozwiązaniem

Tak oto, zakres komórek został zapisany do pliku graficznego. Część projektu wykonana, można przejść do następnej.