Miniaturki produktów - MAKROAPLIKACJE.PL

Facebook LinkedIn X Pinterest

Dość często dostaję zapytania o przygotowanie cennika w Excelu. Zazwyczaj, oprócz specyfikacji i cen, Klienci chcą w nim także umieścić miniaturki produktów. Jak to zrobić, aby wysłać Klientom plik ze zdjęciami, a nie tylko linkami do zdjęć? O tym przeczytasz w tym tekście.

Spis treści ukryj

1. Kilkaset zdjęć w cenniku

2. Kod VBA

2.1. Makro główne

2.2. Ścieżka do katalogu ze zdjęciami

2.3. Kasacja starych miniaturek

2.4. Ostatni niepusty wiersz

3. Analiza kodu

3.1. Rola zmiennych w projekcie

3.2. Sekcja wstępna

3.3. Kasacja kształtów

3.4. Wgranie cennika do tablicy

3.5. Dodanie miniaturek w pętli

4. Wstawiamy zdjęcia czy linki?

5. Film na Vlogu

6. Plik XLSM

Kilkaset zdjęć w cenniku

Pewnego razu zgłosił się do mnie Klient, który potrzebował wgrać zdjęcia produktów do arkusza. Chodziło mu o przygotowanie cennika, który można by było wysyłać w przyszłości do swoich Klientów.

Największym wyzwaniem było dla mnie opracowanie makra, które wgrywa kilkaset zdjęć produktów do komórek arkusza i odpowiednio je pozycjonuje.

Oczywiście zasada Kopiuj/Wklej nie sprawdziłaby się w tym przypadku. Byłaby to bardzo żmudna praca, obarczona dużym ryzykiem błędu.

Wiedziałem, że trzeba napisać makro, które przejdzie w pętli po wszystkich komórkach, pobierze kod produktu (nazwę pliku) i wstawi jego miniaturkę wewnątrz komórki.

Kod VBA

Zadanie wykonałem za pomocą makra głównego i trzech procedur pomocniczych.

Makro główne


Option Explicit
Private Const ms_MODUL As String = "MModulGlowny"
Public gl_BLAD_APLIKACJI As Long ' Zmienna globalna - błąd w aplikacji

Public Sub WgrajZdjeciaDoCennika()

    'Makro wgrywa miniaturki produktów do kolumny B

    Dim sKatalogZdjecia As String    ' Katalog ze zdjęciami - użytkownik wskazuje

    Dim lCennikOst As Long           ' Ostatni niepusty wiersz w wksCennik (kol.A)
    Dim avCennik As Variant          ' Cennik zrzucony do tablicy Variant
    Dim x As Long                    ' Licznik pętli

    Dim sNumerSku As String          ' Numer SKU np. "06477" - plik "006477_A.png"
    Dim shpFoto As Shape             ' Obiekt kształtu, bedziemy dodawać do komórki
    Dim rngCelka As Range            ' Komórka, do której wstawimy miniaturkę
    Dim sSciezkaDoZdjecia As String  ' Lokalizacja obrazka na dysku / pełna ścieżka
    Dim bCzyJestZdjecie As Boolean   ' Informacja czy istnieje obrazek dla produktu?

    Const s_BLAD_OPIS_BRAK_KATALOGU As String = _ 
		"Nie wskazałeś folderu ze zdjęciami. Makro kończy bieg!"
    Const i_BLAD_NUMER_BRAK_KATALOGU As Integer = 9991

    Const sPROC As String = "WgrajZdjeciaDoCennika"

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

    'Poproś usera o wskazanie katalogu ze zdjęciami produktów
2   sKatalogZdjecia = sSciezkaDoKatalogu("Wskaż katalog ze zdjęciami", "Importuj")

    'Przerwij makro, jeśli użytkownik nie wskazał pliku
3   If Len(sKatalogZdjecia) = 0 Then
4       Err.Raise Number:=i_BLAD_NUMER_BRAK_KATALOGU, _
                  Description:=s_BLAD_OPIS_BRAK_KATALOGU
5   End If            '  If Len(sKatalogZdjecia) = 0 Then

    'Wyłącz migotanie ekranu
6   Application.ScreenUpdating = False

    'Skasuj wszystkie kształty z wksCennik
7   Call SkasujKsztalty
8   If gl_BLAD_APLIKACJI <> 0 Then GoTo Wyjscie

    'Sprawdź ostatni niepusty wiersz w kolumnie A
9   lCennikOst = lOstatni(wksCennik.Range("A:A"))

    'Wgraj dane z arkusza do tablicy - pomiń nagłówek
10  avCennik = wksCennik.Range("A3:Y" & lCennikOst)

    'Przejdź w pętli po wszystkich produktach
11  For x = LBound(avCennik, 1) To UBound(avCennik, 1)

        'Zaczytaj numer SKU
12      sNumerSku = avCennik(x, 25)

        'Zdefiniuj ścieżkę do miniaturki zdjęcia
13      sSciezkaDoZdjecia = sKatalogZdjecia & "\0" & sNumerSku & "_A.png"

        'Sprawdź czy istnieje zdjęcie produktu
14      bCzyJestZdjecie = Len(Dir$(sSciezkaDoZdjecia, vbNormal)) <> 0

        'Wstaw foto, jeśli jest ścieżka
15      If bCzyJestZdjecie Then

            'Określ komórkę, do której wstawić fotkę
16          Set rngCelka = wksCennik.Cells(x + 2, "B")

            'Dodaj fotkę
17          Set shpFoto = wksCennik.Shapes.AddPicture( _
                          Filename:=sSciezkaDoZdjecia, _
                          LinkToFile:=msoFalse, _
                          SaveWithDocument:=msoTrue, _
                          Left:=rngCelka.Left + 12, _
                          Top:=rngCelka.Top + 6, _
                          Height:=65.1968503937, _
                          Width:=65.1968503937)

            'Dodaj nazwę dla fotki.
            'Przenieś i zmień rozmiar wraz z komórkami
18          With shpFoto
19              .Name = sNumerSku
20              .Placement = xlMoveAndSize
21          End With

22      End If          ' If bCzyJestZdjecie Then

23  Next x            ' For x = LBound(avCennik, 1) To UBound(avCennik, 1)

Wyjscie:
24  Set shpFoto = Nothing
25  Set rngCelka = Nothing
26  gl_BLAD_APLIKACJI = 0
27  On Error GoTo 0
28  Exit Sub

ObslugaBledu:
29  Application.ScreenUpdating = True
30  MsgBox Title:="Błąd programu!", Buttons:=vbInformation, _
           Prompt:="Informacje dotyczące błędu: " & vbCr & vbCr & _
                   "Numer: " & vbTab & Err.Number & vbCr & _
                   "Opis: " & vbTab & Err.Description & vbCr & vbCr & _
                   "Moduł: " & vbTab & ms_MODUL & vbCr & _
                   "Makro: " & vbTab & sPROC & vbCr & _
                   "Linia: " & vbTab & Erl()
31  gl_BLAD_APLIKACJI = Err.Number
32  GoTo Wyjscie

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

Option Explicit

Private Const ms_MODUL As String = "MModulGlowny"

Public gl_BLAD_APLIKACJI As Long ' Zmienna globalna - błąd w aplikacji

Public Sub WgrajZdjeciaDoCennika()

'Makro wgrywa miniaturki produktów do kolumny B

Dim sKatalogZdjecia As String ' Katalog ze zdjęciami - użytkownik wskazuje

Dim lCennikOst As Long ' Ostatni niepusty wiersz w wksCennik (kol.A)

Dim avCennik As Variant ' Cennik zrzucony do tablicy Variant

Dim x As Long ' Licznik pętli

Dim sNumerSku As String ' Numer SKU np. "06477" - plik "006477_A.png"

Dim shpFoto As Shape ' Obiekt kształtu, bedziemy dodawać do komórki

Dim rngCelka As Range ' Komórka, do której wstawimy miniaturkę

Dim sSciezkaDoZdjecia As String ' Lokalizacja obrazka na dysku / pełna ścieżka

Dim bCzyJestZdjecie As Boolean ' Informacja czy istnieje obrazek dla produktu?

Const s_BLAD_OPIS_BRAK_KATALOGU As String = _

"Nie wskazałeś folderu ze zdjęciami. Makro kończy bieg!"

Const i_BLAD_NUMER_BRAK_KATALOGU As Integer = 9991

Const sPROC As String = "WgrajZdjeciaDoCennika"

'Aktywuj obsługę błędów na starcie

1 On Error GoTo ObslugaBledu

'Poproś usera o wskazanie katalogu ze zdjęciami produktów

2 sKatalogZdjecia = sSciezkaDoKatalogu("Wskaż katalog ze zdjęciami", "Importuj")

'Przerwij makro, jeśli użytkownik nie wskazał pliku

3 If Len(sKatalogZdjecia) = 0 Then

4 Err.Raise Number:=i_BLAD_NUMER_BRAK_KATALOGU, _

Description:=s_BLAD_OPIS_BRAK_KATALOGU

5 End If ' If Len(sKatalogZdjecia) = 0 Then

'Wyłącz migotanie ekranu

6 Application.ScreenUpdating = False

'Skasuj wszystkie kształty z wksCennik

7 Call SkasujKsztalty

8 If gl_BLAD_APLIKACJI <> 0 Then GoTo Wyjscie

'Sprawdź ostatni niepusty wiersz w kolumnie A

9 lCennikOst = lOstatni(wksCennik.Range("A:A"))

'Wgraj dane z arkusza do tablicy - pomiń nagłówek

10 avCennik = wksCennik.Range("A3:Y" & lCennikOst)

'Przejdź w pętli po wszystkich produktach

11 For x = LBound(avCennik, 1) To UBound(avCennik, 1)

'Zaczytaj numer SKU

12 sNumerSku = avCennik(x, 25)

'Zdefiniuj ścieżkę do miniaturki zdjęcia

13 sSciezkaDoZdjecia = sKatalogZdjecia & "\0" & sNumerSku & "_A.png"

'Sprawdź czy istnieje zdjęcie produktu

14 bCzyJestZdjecie = Len(Dir$(sSciezkaDoZdjecia, vbNormal)) <> 0

'Wstaw foto, jeśli jest ścieżka

15 If bCzyJestZdjecie Then

'Określ komórkę, do której wstawić fotkę

16 Set rngCelka = wksCennik.Cells(x + 2, "B")

'Dodaj fotkę

17 Set shpFoto = wksCennik.Shapes.AddPicture( _

Filename:=sSciezkaDoZdjecia, _

LinkToFile:=msoFalse, _

SaveWithDocument:=msoTrue, _

Left:=rngCelka.Left + 12, _

Top:=rngCelka.Top + 6, _

Height:=65.1968503937, _

Width:=65.1968503937)

'Dodaj nazwę dla fotki.

'Przenieś i zmień rozmiar wraz z komórkami

18 With shpFoto

19 .Name = sNumerSku

20 .Placement = xlMoveAndSize

21 End With

22 End If ' If bCzyJestZdjecie Then

23 Next x ' For x = LBound(avCennik, 1) To UBound(avCennik, 1)

Wyjscie:

24 Set shpFoto = Nothing

25 Set rngCelka = Nothing

26 gl_BLAD_APLIKACJI = 0

27 On Error GoTo 0

28 Exit Sub

ObslugaBledu:

29 Application.ScreenUpdating = True

30 MsgBox Title:="Błąd programu!", Buttons:=vbInformation, _

Prompt:="Informacje dotyczące błędu: " & vbCr & vbCr & _

"Numer: " & vbTab & Err.Number & vbCr & _

"Opis: " & vbTab & Err.Description & vbCr & vbCr & _

"Moduł: " & vbTab & ms_MODUL & vbCr & _

"Makro: " & vbTab & sPROC & vbCr & _

"Linia: " & vbTab & Erl()

31 gl_BLAD_APLIKACJI = Err.Number

32 GoTo Wyjscie

End Sub

Ścieżka do katalogu ze zdjęciami


Public Function sSciezkaDoKatalogu(ByVal sTytul As String, _
                                   ByVal sPrzycisk As String) As String

    ' Funkcja wyświetla okienko dialogowe i zwraca pełną ścieżkę do pliku

    Dim sOkienko As String          ' Pełna ścieżka do pliku lub pusty ciąg

1   With Application.FileDialog(msoFileDialogFolderPicker)

2       .Title = sTytul                       ' Tytuł okienka
3       .ButtonName = sPrzycisk               ' Etykieta na przycisku
4       .InitialFileName = ThisWorkbook.Path  ' Wyświetl domyślnie katalog z plikiem
5       .AllowMultiSelect = False             ' Pozwól na wybranie tylko jednego pliku
6       .Show                                 ' Wyświetl
7       If .SelectedItems.Count = 0 Then
8           sOkienko = ""
9       Else
10          sOkienko = .SelectedItems(1)
11      End If

        'Przypisz do wyniku wartość zmiennej
12      sSciezkaDoKatalogu = sOkienko

13  End With

End Function

Public Function sSciezkaDoKatalogu(ByVal sTytul As String, _

ByVal sPrzycisk As String) As String

' Funkcja wyświetla okienko dialogowe i zwraca pełną ścieżkę do pliku

Dim sOkienko As String ' Pełna ścieżka do pliku lub pusty ciąg

1 With Application.FileDialog(msoFileDialogFolderPicker)

2 .Title = sTytul ' Tytuł okienka

3 .ButtonName = sPrzycisk ' Etykieta na przycisku

4 .InitialFileName = ThisWorkbook.Path ' Wyświetl domyślnie katalog z plikiem

5 .AllowMultiSelect = False ' Pozwól na wybranie tylko jednego pliku

6 .Show ' Wyświetl

7 If .SelectedItems.Count = 0 Then

8 sOkienko = ""

9 Else

10 sOkienko = .SelectedItems(1)

11 End If

'Przypisz do wyniku wartość zmiennej

12 sSciezkaDoKatalogu = sOkienko

13 End With

End Function

Kasacja starych miniaturek

Wystąpił błąd. Spróbuj ponownie.

Ostatni niepusty wiersz


Public Function lOstatni(ByRef rngKolumna As Range) As Long
    Dim lTekst As Long
    Dim lLiczba As Long

1   On Error Resume Next
2   lTekst = WorksheetFunction.Match("żżż", rngKolumna, 1)
3   lLiczba = WorksheetFunction.Match(9.99999999999999E+307, rngKolumna, 1)
4   On Error GoTo 0
5   lOstatni = WorksheetFunction.Max(lTekst, lLiczba)

End Function

Public Function lOstatni(ByRef rngKolumna As Range) As Long

Dim lTekst As Long

Dim lLiczba As Long

1 On Error Resume Next

2 lTekst = WorksheetFunction.Match("żżż", rngKolumna, 1)

3 lLiczba = WorksheetFunction.Match(9.99999999999999E+307, rngKolumna, 1)

4 On Error GoTo 0

5 lOstatni = WorksheetFunction.Max(lTekst, lLiczba)

End Function

Analiza kodu

Wynotujmy najważniejsze sekwencje kodu.

Rola zmiennych w projekcie

Pierwszą informacją jaką chcemy pobrać do zmiennej (sKatalogZdjecia) jest ścieżka do katalogu z miniaturkami produktów. Ta ścieżka nie jest przypisana na stałe. Chcemy być elastyczni i pozwalamy użytkownikowi wybrać folder w okienku dialogowym.

Nazwy plików graficznych (miniaturek) zawierają w sobie kod produktu (tzw. Numer SKU). Jeśli kod produktu to np. 06477, to nazwą pliku będzie 006477_A.png. Będziemy używać pętli For Next przebiegając nie po tabeli w arkuszu, tylko właśnie po tablicy wirtualnej.

Przetwarzanie komórek pętlą For Each byłoby zbyt czasochłonne, zatem zrzucamy cały cennik do tablicy wirtualnej avCennik. Będziemy używać pętli For Next przebiegając nie po tabeli w arkuszu, tylko właśnie po tablicy wirtualnej. Makro wykona się znacznie szybciej. Zmienna x będzie naszym licznikiem pętli.

Oczywiście będzie nam potrzebna zmienna (sNumerSku) przechowująca kod produktu. Znając go, łatwo będziemy mogli przypisać mu ścieżkę do zdjęcia na dysku twardym (sNumerSku). Co więcej, musimy się upewnić, że dany produkt posiada zdjęcie na dysku. W tym celu wprowadzamy zmienną typu PRAWDA/FAŁSZ bCzyJestZdjecie.

Musimy jeszcze wiedzieć, do której komórki makro ma wstawić miniaturkę. Deklarujemy więc zmienną obiektową typu Range (rngCelka).

Przyda się również zmienna shpFoto, która będzie obiektem miniaturki (kształtem).

Sekcja wstępna

Najpierw aktywujemy obsługę błędów – makro przerwie kod i wyświetli stosowny monit, jeśli natrafi na błąd.

Następnie wyskakuje okienko dialogowe z prośbą o wskazanie katalogu ze zdjęciami. Jeżeli użytkownik nie wybierze katalogu, kończymy działanie programu.

Wyłączamy migotanie ekranu aby przyspieszyć działanie makra.

Kasacja kształtów

Musimy się upewnić, że w arkuszu nie ma żadnych starych miniaturek. W tym celu wywołujemy makro pomocnicze SkasujKsztalty, które kasuje nam wszystkie kształty w arkuszu.

Jeśli w arkuszu znajduje się logo Klienta i chcemy je zachować, to musimy dodać warunek sprawdzający nazwę kształtu.

Wgranie cennika do tablicy

Ten punkt już opisywałem wyżej. Wgranie tabeli z cennikiem do tablicy wirtualnej jest konieczne, aby makro działało szybko. Nie wiemy dokładnie ile jest produktów, w tym celu deklarujemy zmienną, która sprawdza ostatni niepusty wiersz.

Dodanie miniaturek w pętli

Najważniejsza część projektu – przechodzimy w pętli po wszystkich produktach.

Najpierw zaczytujemy Numer SKU, a znając go możemy łatwo określić ścieżkę do zdjęcia produktu na dysku twardym. Możemy też ustalić czy zdjęcie fizycznie znajduje się na dysku.

Jeśli wiemy, że produkt posiada miniaturkę, to wyliczamy, do której komórki ma zostać ona wstawiona.

Wstawiamy miniaturkę do komórki, tak aby nie wystawała poza jej obręb.

Każde zdjęcie jest takiej samej wielkości. Jego rozmiar będzie się dopasowywać dynamicznie do wysokości wiersza i szerokości kolumny.

GOTOWE ! 🙂

Wstawiamy zdjęcia czy linki?

W Excelu możemy standardowo wstawić do arkusza rysunek, przechodząc do karty Wstawianie i klikając na przycisk Obraz. Pojawia się wówczas okienko, w którym powinniśmy zlokalizować zdjęcie i je wybrać.

Swoje rozwiązanie postanowiłem pierwotnie oprzeć na tym patencie. Odpowiednikiem tej operacji w VBA jest pojedyncza linia kodu.

Oczywiście w dalszych liniach definiowałem nazwę tego obrazka, jego położenie względem górnej lewej krawędzi komórki, szerokość, wysokość itd.

Makro sprawnie wstawiło mi kilkaset zdjęć, więc zadowolony uznałem, że temat jest zamknięty.

Nie podobał mi się jednak rozmiar pliku….. Zaledwie 1,5MB biorąc pod uwagę, że jest tam ok. 500 zdjęć?… Coś mi nie grało, tym bardziej, że przy ponownym uruchomieniu Excel się zawieszał, a plików nie było widać….

Byłem zaskoczony i zbadałem temat ponownie.

Okazało się, że metoda Insert kolekcji Pictures nie wstawia zdjęć, a jedynie linki do nich! Excel wieszał się, ponieważ nie mógł zlokalizować tych zdjęć – były one poza arkuszem.

Wiedziałem, że muszę znaleźć inny sposób na trwałe dodanie zdjęć do pliku, tak by można go było dalej dystrybuować.

Po krótkim researchu, skorzystałem z metody AddPicture kolekcji Shapes, która pozwala mi zdecydować czy obrazek ma zostać zapisany razem z plikiem.

Widząc, że rozmiar pliku wzrósł o 1000% wiedziałem, że zdjęcia zostały prawidłowo załadowane.

Poniżej dokładny opis metody AddPicture obiektu Shapes.
https://docs.microsoft.com/en-us/office/vba/api/excel.shapes.addpicture

Additional menu

Kilkaset zdjęć w cenniku

Kod VBA

Makro główne

Ścieżka do katalogu ze zdjęciami

Kasacja starych miniaturek

Ostatni niepusty wiersz

Analiza kodu

Rola zmiennych w projekcie

Sekcja wstępna

Kasacja kształtów

Wgranie cennika do tablicy

Dodanie miniaturek w pętli

Wstawiamy zdjęcia czy linki?

Film na Vlogu

Plik XLSM

Footer