Funkcja InsertPictureFromHTTP - funkcja zwracająca do komórki obraz pochodzący z Internetu.   strona główna:
A po co ten Excel ;-)
 
 
 
    O tym po co mi taka funkcja - za chwilę. Teraz: Jak napisać funkcję która do komórki w której jest wpisana zwróci obraz. Źródłem tego   
obrazu ma być adres/link do tego obrazu w sieci.  
 
Potrzebna nam będzie wiedza nt. linku do obrazu którego chcielibyśmy mieć w arkuszu. Np.:  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
i w Arkuszu Excela, np.: dla scalonych komórek w dopasowanym wielkością zakresie:  
 
i jest :-)  
 
Jaka funkcja zrealizuje takie zadanie??  
 
Function InsertPictureFromHTTP(strHTTP As String, Optional xlRng As Excel.Range)  
    Dim xlShp As Excel.Shape  
    Dim rng As Excel.Range  
      
    If Not xlRng Is Nothing Then  
        Set rng = xlRng  
    Else  
        Set rng = Application.Caller.MergeArea  
    End If  
    With rng  
        On Error Resume Next  
        Set xlShp = .Parent.Shapes("kom" & .Address(external:=True))  
        If Not xlShp Is Nothing Then  
            Set xlShp = Nothing  
            Exit Function  
        End If  
        On Error GoTo 0  
          
        Set xlShp = .Parent.Shapes.AddPicture(strHTTP, _  
                                              msoTrue, msoTrue, _  
                                              .Left, .Top, .Width, .Height)  
        xlShp.Name = "kom" & .Address(external:=True)  
        Set xlShp = Nothing  
    End With  
    InsertPictureFromHTTP = vbNullString  
End Function  
 
Fragmentami:  
 
Function InsertPictureFromHTTP(strHTTP As String, Optional xlRng As Excel.Range)  
 
Funkcja przyjmuje 1 lub 2 argumenty:  
 1 - strHTTP to adres zdjęcia które chcemy wstawić do arkusza  
 2 - (opcjonalny) - to komórka/komórki do których ma trafić obraz.  
 
    If Not xlRng Is Nothing Then  
        Set rng = xlRng  
    Else  
        Set rng = Application.Caller.MergeArea  
    End If  
 
Jeżeli arg.2 nie zostanie podany to funkcja zwróci obraz do komórek w których jest wpisana. Jednak jeżeli chcielibyśmy tę funkcję wykorzystać  
w VBA to należy podać arg.2.  
 
        On Error Resume Next  
        Set xlShp = .Parent.Shapes("kom" & .Address(external:=True))  
        If Not xlShp Is Nothing Then  
            Set xlShp = Nothing  
            Exit Function  
        End If  
        On Error GoTo 0  
 
Tworzonym obrazom nadawana będzie nazwa będąca połączeniem "kom" i adresu komórek do których będzie ona wpisana. Jeżeli obraz o   
takiej nazwie już istnieje to funkcja kończy działanie. Czemu?? Po pierwsze - Internet to raczej coś zmiennego, nie ma gwarancji że obraz  
pod danym linkiem będzie tam na zawsze. Jak mam już obraz który chciałem to nie chcę uzależniać działania funkcji od faktu czy ten obraz  
ciągle jest pod wskazanym linkiem. Poza tym nie ma co wstawiać obrazów na nowo po każdym przeliczeniu arkusza. W tym pomyśle nie   
potrzebuję odświeżania formuł. Można było by po prostu usunąć formułę z komórek arkusza. Jednak odświeżanie obrazu jest możliwe poprzez  
ręczne usunięcie samego obrazu i ponowne przeliczenie funkcji - dlatego taka konstrukcja.  
 
        Set xlShp = .Parent.Shapes.AddPicture(strHTTP, _  
                                              msoTrue, msoTrue, _  
                                              .Left, .Top, .Width, .Height)  
        xlShp.Name = "kom" & .Address(external:=True)  
 
Wstawienie obrazu do komórek arkusza i nadanie mu odpowiedniej nazwy.  
 
No i na dobrą sprawę tyle :-) Drugą częścią artykułu będzie przykład oparty o tę funkcję lub coś jej podobnemu. Mianowicie:  
Zbliżają się wakacje. Wielu z nas, w tym i ja, planuję spędzić je za granicą i przed każdym wyjazdem gdzieś do strefy euro przygotowuję sobie  
zestawienie monet euro których mi brakuje. :-) Bo, nie wiem czy wiecie, każdy kraj strefy euro boje swoje własne monety. Awersy co prawda  
są takie same jednak Rewersy są już inne dla każdego kraju. Można więc stworzyć fajną kolekcję. Tyle że trzeba mieś jakąś ściągę pod ręką  
żeby sprawdzać czy trafił się nam jakiś nowy element kolekcji czy nie…
 
    Co więc trzeba wiedzieć żeby taką ściągę stworzyć??  
1) - jak wyglądają Rewersy wszystkich monet Euro krajów strefy Euro.  
2) - zapisać ,w jakiś sposób, te które już mamy.  
 
Etap 1. Wszystkie Euro:  
 
część wygląda tak: --------------->  
 
Do pobrania tych obrazów wykorzystamy stronkę  
http://www.ecb.europa.eu/euro/coins/  
 
Przeglądając źródło strony trafimy na linki do obrazów monet  
przykładowo link do austriackiej 2Euro to:  
http://www.ecb.europa.eu/euro/coins/common/shared/img/at/2e.gif  
 
Cześć http://www.ecb.europa.eu/euro/coins/common/shared/img/ jest  
stała następnie: symbol kraju at i symbol monety 2e oraz rozszerzenie pliku.  
Wyjątkiem jest Estonia jednak również można łatwo zrozumieć prawidłowość.  
 
Procedura zwracająca obrazy do wcześniej przygotowanego  (wielkość komórek) zakresu może wyglądać tak:  
 
 
Option Explicit  
 
Sub MonetyEuro_Wszystkie()  
    Dim xlWks As Excel.Worksheet  
      
    Const strPAth As String = "http://www.ecb.europa.eu/euro/coins/common/shared/img/"  
    Dim arrKraj: arrKraj = Kraje()  
    Dim arrNomi: arrNomi = VBA.Array("2e", "1e", "50c", "20c", "10c", "5c", "2c", "1c")  
    Dim arrEst: arrEst = VBA.Array(200, 100, 50, 20, 10, 5, 2, 1) 'EE-200-2011.jpg  
    Dim href As String  
    Dim i As Byte, j As Byte  
      
    Set xlWks = ThisWorkbook.Worksheets("EURO wszystkie")  
    With xlWks  
        .Shapes.SelectAll: Selection.Delete  
        On Error Resume Next  
        For i = 0 To UBound(arrKraj, 2)  
            .Cells(3, i + 3) = arrKraj(0, i)  
            For j = 0 To UBound(arrNomi)  
                With .[C4].Offset(j, i)  
                    Select Case arrKraj(1, i)  
                        Case "et": href = strPAth & arrKraj(1, i) & "/EE-" & Format(arrEst(j), "000") & "-2011.jpg"  
                        Case Else: href = strPAth & arrKraj(1, i) & "/" & arrNomi(j) & ".gif"  
                    End Select  
                    xlWks.Shapes.AddPicture href, _  
                                            msoFalse, msoCTrue, _  
                                            .Left + 1, .Top + 1, .Width - 2, .Height - 2  
                End With  
            Next  
        Next  
        On Error GoTo 0  
    End With  
    Set xlWks = Nothing  
End Sub  
 
Function Kraje() As Variant  
    Dim htmlDocument As Object 'MSHTML.htmlDocument  
    Dim el As Object 'MSHTML.HTMLElementCollection  
    Dim request As Object 'WinHttp.WinHttpRequest  
              
    Dim tbl() As Variant, i As Byte  
    Set htmlDocument = CreateObject("HtmlFile")  
    Set request = CreateObject("WinHttp.WinHttpRequest.5.1")  
      
    With request  
        .Open "GET", "http://www.ecb.europa.eu/euro/coins/html/index.pl.html", True  
        .send  
        .waitForResponse  
        htmlDocument.body.innerHTML = .responseText  
    End With  
 
    For Each el In htmlDocument.getElementById("crossnav"). _
 
                                getElementsByTagName("li")  
        ReDim Preserve tbl(0 To 1, 0 To i)  
        tbl(0, i) = el.innerText  
        tbl(1, i) = Mid(el.ChildNodes(0).href, 24, 2)  
        i = i + 1  
    Next  
    Kraje = tbl  
      
    Set el = Nothing  
    Set htmlDocument = Nothing  
    Set request = Nothing  
End Function  
 
 
    Samo wstawianie obrazów, znając mechanizmy funkcji   
InsertPictureFromHTTP nie jest problemem. Znamy prawie cały ciąg   
adresu/linku obrazu który nam jest potrzebny. Prawie cały, bo nie znamy  
symbolu kraju. (np. dla Austrii at). W sumie nie jest ich tak wiele. Nie   
byłoby wiele roboty z prostym podglądnięciem tego w źródle strony  
i stworzenie tablicy stałych. Jednak można też zwrócić tablice z tymi symbolami wprost ze źródła strony kodem. To właśnie realizuje  
funkcja Kraje(). Cały mechanizm wyjaśniają obrazy i strzałki obok kodu.  
 
W załączniku, w Ark.EURO wszystkie, pod przyciskiem Wstaw macię tą procedurę.  
Zestaw wszystkich monet już jest.. Z małym wyjątkeim :-P Chodzi o 2Euro dla Watykanu. Końcówka tego linku jest odrobinę inna: 2e_2.gif  
Procedura jej nie zwróci. Pewnie że można to było dopisac warunkiem ale… można też wstawić ten obraz naszą funkcją :-)  
w kom.V4 wpiszecie =InsertPictureFromHTTP("http://www.ecb.europa.eu/euro/coins/common/shared/img/va/2e_2.gif") i będzie komplet.  
 
Etap 2. Które euro już mamy??  
Wymarzyło mi się to tak:  
 
Ma to działać następująco:  
 - przy każdym polu na monetę będzie  
CheckBox.  
 - po zaznaczeniu CheckBoxa obok, w  
polu monety, pojawi się odpowiednia sztuka  
 
Jasnym jest że będziemy potrzebować  
całego adresu obrazu:  
 - część stała jest w C1  
 - Symbol kraju w wierszu 2  
 - Symbole monet - pod CheckBox'ami  
 
Całość ma działąć po kliknięciu na ChcekBox  
więc to ich zdarzenie trzeba oprogramować.  
Wykorzystałem CheckBox'y z Formularzy i wstawiam je kodem do zaznaczenia (Selection) procedurą:  
 
Sub WstawChBox()  
    Dim xlRng As Excel.Range  
    Dim xlChBox As Excel.CheckBox  
      
    For Each xlRng In Selection  
        With xlRng  
            Set xlChBox = .Parent.CheckBoxes.Add(.Left, .Top, .Width, .Height)  
            With xlChBox  
                .Caption = vbNullString  
                .OnAction = "WstawZdjeciePoChBoxie"  
                .Width = xlRng.Width  
            End With  
            Set xlChBox = Nothing  
        End With  
    Next  
End Sub  
 
Private Sub WstawZdjeciePoChBoxie()  
    With ActiveSheet.CheckBoxes(Application.Caller)  
        If .Value = -4146 Then  
            On Error Resume Next  
            ActiveSheet.Pictures("kom" & .TopLeftCell.Offset(, 1).Address(external:=True)).Delete  
            On Error GoTo 0  
        Else  
            InsertPictureFromHTTP .Parent.[C1] & .TopLeftCell, .TopLeftCell.Offset(, 1)  
        End If  
    End With   Przykład do ściągnięcia:
End Sub   euro.zip
 
W załączniku macię pustą tabelę z wstawionymi CheckBox'ami w Ark.EURO. Tylko znaczyć odłożone do kolekcji monety. :-)