Excel nie posiada narzędzia, które pozwalałoby na zapisanie zakresu komórek do pliku graficznego w wysokiej rozdzielczości. Obiekt Range – o dziwo – nie posiada metody w stylu ExportToPicture. Musimy więc wyeksportować zakres do obrazka w bardziej okrężny sposób.
Wymogi zadania
Niedawno stanąłem przed zadaniem wyeksportowania zakresu komórek do pliku graficznego.
Warunki dotyczące tego obrazka były dwa.
- Format PNG. Screen koniecznie musiał być zapisany w takiej formie graficznej.
- Wysoka rozdzielczość. Zdjęcie służyło do 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. Niewątpliwie 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 internet w poszukiwaniu gotowca opartego o funkcje API i trafiłem na bardzo dobry kod. Niestety funkcja nie spełniała pierwszego warunku (EMF to nie PNG) 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ą:
- Dodać tymczasowy arkusz (opcjonalnie).
- 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
- Skasować tymczasowy arkusz (opcjonalnie).
Skalowanie obrazka
W tym ostatnim linku przeczytałem, że aby polepszyć jakość 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. A to jest dla nas priorytetem!
I faktycznie tak to działa, ale dość często w momencie eksportu Excel się zawieszał. Sprawdziłem to na kilku komputerach i efekt był zawsze taki sam.
Ostatecznie zdecydowałem, że nie będę wpływał na rozmiar obrazka – Klient zaakceptował oryginalną jakość.
Zapis do obrazka makrem
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.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
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 EksportujDoPng wksLayout.Range("Layout"), sLOKALIZACJA_PNG End Sub |
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
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 A1:J25 został zapisany do pliku graficznego wysokiej rozdzielczości.
Plik XLSM
