Tworzenie Shape'ów o kształcie powiatu na podstawie mapy Polski. A więc
prezentowanie danych na mapie - podejście 2 :-)
  strona główna:
A po co ten Excel ;-)
 
 
  Inny sposób prezentowania danych na mapie
     Choć sposób prezentowania danych na mapie z poprzedniego wątku na ten temat bardzo mi się spodobał to jednak trzeba przyznać że   
sporym minusem metody jest dość długi czas jej wykonania. Metoda opisana tutaj jest dużo szybsza jednak działa na zupełnie innej zasadzie.  
 
     Sposobem tym jest utworzenie obiektów shape o kształcie powiatów i nadawanie im koloru w zależności od wartości przypożądkowanej  
danemu powiatowi w skali kolorów. Jak jednak stworzyć takie kształty? Na stronce opisującej tę metodą można wyczytać ze można znaleźć   Build your own Choropleth Maps with Excel
taką mapę na podanej w linku stronie, i po odpowiednich manewrach możemy taką mapę podzielić na odrębne obiekty Shape. Jakoś bardzo  
usilnie nie szukałem. Ważne jednak że nie znalazłem a że jakoś zawsze wolę usiąść nad własnym pomysłem niż tracić czas na poszukiwania  
gotowych rozwiązań to też wymyśliłem jak (z całkiem niezłą skutecznością) stworzyć takie kształty w oparciu o "moją" mapę.  
 
"Moja" mapa to mapa "wyjściowa" którą wykorzystuję również w poprzednim pomyśle. A więc tu tylko kilka najistotniejszych informacji:  
 - każdy powiat jest pokolorowany unikalną i znaną kombinacją kolorów składowych  
 - powiaty i województwa są oddzielone kolorami: czerwonym (RGB:255,0,0) i niebieskim (RGB:0,0,255)   
 
     OK. :-) Teoria jest taka: Na UserForm'ie jest mapa na podstawie której będziemy tworzyć nasze Shape's - powiaty. Po kliknięciu na  
dowolny element mapy procedura powinna sprawdzić jaki powiat został wybrany. Określę to czytając składowe klikniętego koloru i porównująć  
wyniki z tabelą (Arkusz3) gdzie są zapisane informację o składowych koloru dla każdego powiatu oraz nazwą jaka ma być nadana utworzonemu  
obiektowi Shape. Jeżeli nie zostanie znaleznione powiat o danych pochodzacych z badanego koloru oznacza to że kliknięto na granicę między  
powiatami lub poza mapę -> koniec procedury. Jeżeli jednak uda się okreslić jaki to powiat procedura w pętli będzie sprawdzac kolejne pixele  
w lewo aż trafi na granicę między powiatami. Po natrafieniu ma granicę rekurencyjnie pobiegnie granicą tego powiatu zapisując współżędne  
każdego punktu na granicy do tablicy. Na podstawie danych zapisanych do tej tablicy "narysuje" obiekt Shape w arkuszu, który kształtem  
będzie odpowiadał klikniętemu powiatowi. Po kliknięciu na sasiadujący powiat procedura dorysuje kolejny obiekt Shape w odpowiednim miejscu  
względem poprzedniego tworzac mapę np.: województwa lub nawet całej Polski. Tworzonym obiektom Shape zostanie nadana nazwa zgodna  
z nazwą z ark.Arkusz3. Po tej nazwie będziemy nadawać kolor dla danego obiektu Shape. Kolor nada formuła która przyjmie jako argumenty:  
nazwę danego obiektu Shape (powiatu) oraz składowe koloru jaki ma być nadany. Jeżeli utworzona mapa byłaby za mała/ za duża lub miałaby   
być np.: w jakiś sposób pochylona jednak tak żeby cały układ się nie zniekształcił należy napisać procedurę grupującą obiekty Shape w zazna-  
czonym zakresie co umożliwi edycię całej mapy. A następnie poprzez PPM/ Grupuj / Grupuj lub Rozgrupuj umożliwi dowolne manewry na mapie  
zachowująć jej funkcjonalność, a więc po zmianie wartości dla danego powiatu zmieni się jego kolor.  
 
    Na realizację całości zadania zeszło mi dwa dni (w wolnym czasie, którego w zimie to ja mam "jak na lekarstwo"). Nie oddam Wam jednak  
gotowej całej mapy Polski. Przykład będzie zawierał utworzone mapy woj.: Małopolskiego - pod E2003 i Zach.Pomorskiego - pod E2010.  
Dla E2010 trzeba mieć trochu więcej cierpliwości :-| ale pod E2003 działa całkiem poprawnie.  
 
    Dodatkowym plusem metody jest fakt że raz utworzona mapa nie musi być tworzona na nowo po zmianie danych. Nie nadajemy to koloru  
dla poszczególnych pixeli a dla całego wypełnienia danego kształtu. Tu własnie tkwi tajemica szybkości działania całej procedury. Prezentowana  
procedura jest zatem narzedziem do tworzenia narzędzi. :-)  
 
   Aaa… choc całość działa całkiem poprawnie to jednak zdarzają się że granice klikniętego powiatu nie będą, powiedźmy, zgodne z naszymi   
oczekiwaniami ;-) Zwaliłbym to na niedoskonałość mapy ale prawdą jest że czasem rekurencja idzie czort wie gdzie i czort wie czemu, a czasem  
połączy dwa powiaty twierdząć że to jeden. W takiem sytuacji - bez paniki! ;-P Klikamy ponownie na interesujący nas powiat (najlepiej w nieco  
innym miejscu). Poprzedni zostanie usunięty a procedura utworzy obiekt ponownie - może tym razem prawidłowo :-)  
 
    Przejdźmy teraz do samego kodu realizującego zadanie.  
 
Kliknięcie na przycisk na Arkuszu u pokaże sięnam UserForm z mapą wyjściową…  
 
Private Sub UserForm_Initialize()  
    tblInfo = ThisWorkbook.Worksheets("Arkusz3").Range("A2:E380")  
    frmHdc = FormHDC  
End Sub  
 
tblInfo - to tablica poziomu modułu przechowująca dane dotyczące powiatów: składowe koloru, nazwa powiatu, województwa oraz nazwa  
            która zostanie nadana obiektowi Shape danego powiatu.  
 
frmHdc - to zmienna poziomu modułu w której przechowany zostanie uchwyt do obrazu userforma. Wartość ta będzie nam potrzebna do  
             odczytu składowych koloru powiatu którego kliknęliśmy oraz nadawaniu barwy pixelom na granicy powiatu.  
 
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)  
 
    On Error GoTo UserForm_MouseDown_Error  
 
    Dim lngPixelColor As Long  
    Dim R As Integer, G As Integer, B As Integer  
    Dim bFlagErr As Boolean  
      
    Dim strShName As String  
 
    lngPixelColor = GetPixel(frmHdc, x / pixel2point, y / pixel2point)  
    UnRGB lngPixelColor, R, G, B  
    strShName = ShName(G, R)  
      
    Dim xlWks As Excel.Worksheet  
    Set xlWks = ThisWorkbook.Worksheets("Arkusz1")  
    If Len(strShName) > 0 Then  
        On Error Resume Next  
        xlWks.Shapes(strShName).Delete  
        On Error GoTo 0  
    Else  
        Exit Sub  
    End If  
    Set xlWks = Nothing  
          
    Do  
        lngPixelColor = GetPixel(frmHdc, x / pixel2point, y / pixel2point)  
        UnRGB lngPixelColor, R, G, B  
          
        If (R = 0 And G = 0 And B = 255) Or _  
           (R = 255 And G = 0 And B = 0) Or _  
           (R = 255 And G = 255 And B = 255) Then  
           Exit Do  
        End If  
        x = x - pixel2point: If x < 0 Then bFlagErr = True: Exit Do  
    Loop  
      
    WytnijPowiat x / pixel2point, y / pixel2point, 2  
    ReadTblDane  
    CreateShape strShName  
      
UserForm_MouseDown_Exit:  
    Erase tblDane: iTbl = 0  
    Exit Sub  
      
UserForm_MouseDown_Error:  
    MsgBox "Unexpected error - " & Err.Number & vbCrLf & vbCrLf & _  
            Error$, vbExclamation, "VBAProject - UseForMouDow"  
    Resume UserForm_MouseDown_Exit  
 
End Sub  
 
    Po kliknięciu na mapę…  
 
    lngPixelColor = GetPixel(frmHdc, x / pixel2point, y / pixel2point)  
    UnRGB lngPixelColor, R, G, B  
    strShName = ShName(G, R)  
 
Do lngPixelColor zostaje zapisana wartość koloru klikniętego pixela. Procedura UnRGB…  
 
Private Sub UnRGB(ByVal color As OLE_COLOR, _  
                  ByRef R As Integer, ByRef G As Integer, ByRef B As Integer)  
    R = color Mod 256  
    G = (color \ 256) Mod 256  
    B = color \ 65536  
End Sub  
 
Do zmiennych R, G, B zostają zapisane wartości składowe klikniętego koloru. Do zmiennej strShName zostanie zapisana nazwa która powinna  
być nadana obiektowi Shape danego powiatu. Nazwę tą określę funkcją ShName na podstawie składowych koloru.  
 
Function ShName(G As Integer, R As Integer)  
    Dim i As Long  
    For i = 1 To 379  
        If tblInfo(i, 1) = G And tblInfo(i, 2) = R Then  
            ShName = tblInfo(i, 5)  
            Exit For  
        End If  
    Next  
End Function  
 
Interesująca nas nazwa jest zapisana w kol.5 tablicy tblInfo utworzonej podczas tworzenia się UserForm'a. Do określenia tej nazwy należy  
sprawdzić wartość G - składowa G klikniętego koloru, R - analogicznie. Te dane są zapisane w kol.1 i 2 tblInfo.  
 
    Dim xlWks As Excel.Worksheet  
    Set xlWks = ThisWorkbook.Worksheets("Arkusz1")  
    If Len(strShName) > 0 Then  
        On Error Resume Next  
        xlWks.Shapes(strShName).Delete  
        On Error GoTo 0  
    Else  
        Exit Sub  
    End If  
    Set xlWks = Nothing  
 
Jeżeli do strShName nie została zapisana żadna nazwa -> koniec zabawy. Sytuacja ta (jak już pisałem) może zaistniej jeżeli klikniemy na   
granicę między powiatami albo poza mapą. Kolor który zostanie analizowany nie znajdzię swych składowych w tblInfo - nie jest to żaden  
powiat. Jeżeli jednak coś się zapisało.. Trzeba sprawdzić czy shape o danej nazwie nie został już utworzony. Jeżeli tak to zostanie usunięty.  
 
    Do  
        lngPixelColor = GetPixel(frmHdc, x / pixel2point, y / pixel2point)  
        UnRGB lngPixelColor, R, G, B  
          
        If (R = 0 And G = 0 And B = 255) Or _  
           (R = 255 And G = 0 And B = 0) Or _  
           (R = 255 And G = 255 And B = 255) Then  
           Exit Do  
        End If  
        x = x - pixel2point: If x < 0 Then bFlagErr = True: Exit Do  
    Loop  
 
Jeżeli powiat jest już znany. W pętli Do..Loop czytamy kolejne pixele w lewo aż dojdziemy do granicy powiatu. Granice na mapie wstępnej są  
oznaczone kolorami: Czerwony (RGB: 255,0,0) - granica województwa, Niebieski (RGB: 0,0,255). Ja dodatkowo nadaję opracowanym już  
powiatom kolor biały (RGB: 255,255,255). Kod raczej prosty…  
 
    WytnijPowiat x / pixel2point, y / pixel2point, 2  
 
To wywołanie procedury która zostanie wywołana rekurencyjnie określając granicę powiatu. Tu jest jej pierwsze wywołanie. A sama procedura:  
 
Sub WytnijPowiat(ByVal x As Integer, ByVal y As Integer, iPoz As Integer)  
    Dim arrX As Variant: arrX = VBA.Array(1, 1, 0, -1, -1, -1, 0, 1)  
    Dim arrY As Variant: arrY = VBA.Array(0, 1, 1, 1, 0, -1, -1, -1)  
    Dim i As Byte  
    Dim lngPixelColor As Long  
    Dim R As Integer, G As Integer, B As Integer  
    Dim xPoz As Single, yPoz As Single, s As Integer  
      
    Select Case iPoz  
        Case 0: s = 6  
        Case 1: s = 5  
        Case 2 To 7: s = iPoz - 2  
    End Select  
      
    For i = 0 To 7  
        xPoz = x + arrX(s) * pixel2point  
        yPoz = y + arrY(s) * pixel2point  
      
        lngPixelColor = GetPixel(frmHdc, xPoz, yPoz)  
        UnRGB lngPixelColor, R, G, B  
        If (R = 0 And G = 0 And B = 255) Or _  
           (R = 255 And G = 0 And B = 0) Or _  
           (R = 255 And G = 255 And B = 255) Then  
              
            ReDim Preserve tblDane(iTbl)  
            tblDane(iTbl).x = xPoz  
            tblDane(iTbl).y = yPoz  
            iTbl = iTbl + 1  
              
            SetPixel frmHdc, xPoz, yPoz, RGB(0, 0, 0)  
            WytnijPowiat CSng(xPoz), CSng(yPoz), s  
              
            Exit For  
        End If  
          
        s = s + 1  
        If s = 8 Then s = 0  
          
    Next  
 
End Sub  
 
Fragmentami:  
 
    Dim arrX As Variant: arrX = VBA.Array(1, 1, 0, -1, -1, -1, 0, 1)  
    Dim arrY As Variant: arrY = VBA.Array(0, 1, 1, 1, 0, -1, -1, -1)  
 
zależało mi żeby pętla leciała po sasiadach elementu granicy na lewo od klikniętego pixela leciała w strikre określony sposób.  
Sposób ten można zobrazować tak:                     X oznacza analizowany elemet granicy. Kolejność analizowania sasiadów, czy sasiad to 
 
też element granicy, powinna                             przebiegać w kolejności od 0 do 7 (lub np.: od 6 to 5 - w prawo). arrX i arrY to tablice  
które określają jaki offset powinien                      być analizowany w każdym z kroków.  
 
 
    Select Case iPoz  
        Case 0: s = 6  
        Case 1: s = 5  
        Case 2 To 7: s = iPoz - 2  
    End Select  
 
Przyjąłem że będę zaczynał analizować sąsiadów w kolejności opisanej licząc od elementu o 2 numery mniejszego niż ten na którym poprzednio  
znalazłem sasiada będącego granicą.  
 
    For i = 0 To 7  
        xPoz = x + arrX(s) * pixel2point  
        yPoz = y + arrY(s) * pixel2point  
 
(..)  
 
        s = s + 1  
        If s = 8 Then s = 0  
    Next  
 
Analizowani są wszyscy sasiedzi jednak zaczynając od tego przesuniętego od poprzednio analizowanego o xPoz, yPoz.  
 
        lngPixelColor = GetPixel(frmHdc, xPoz, yPoz)  
        UnRGB lngPixelColor, R, G, B  
        If (R = 0 And G = 0 And B = 255) Or _  
           (R = 255 And G = 0 And B = 0) Or _  
           (R = 255 And G = 255 And B = 255) Then  
 
Jeżeli analizowany pixel jest granicą…  
 
            ReDim Preserve tblDane(iTbl)  
            tblDane(iTbl).x = xPoz  
            tblDane(iTbl).y = yPoz  
            iTbl = iTbl + 1  
 
Współżędne tego punktu są zapisane do tablicy poziomu modułu tblDane.  
 
            SetPixel frmHdc, xPoz, yPoz, RGB(0, 0, 0)  
 
znaleziony element tablicy zostaje pokolorowany na czarno!!. To dlatego żeby rekurencja jak spowrotem dojdzie do pierwszego czarnego  
pixela zakończyła się.  
 
            WytnijPowiat CSng(xPoz), CSng(yPoz), s  
 
Kolejne wywołanie procedury rekurencyjnej - poszukiwanie kolejnego elementu granicy powiatu.  
    W efekcie mamy tablicę tblDane przechowującą dane nt. współżędnych elementów granicy powiatu na mapie. :-)  
 
Ta procedura w końcu się zakończy ;-) a wtedy wracamy do procedury następującej po kliknięciu na mapę…  
 
    ReadTblDane  
 
a więc:  
 
Sub ReadTblDane()  
    Dim i As Long  
    For i = 0 To UBound(tblDane)  
        SetPixel frmHdc, tblDane(i).x, tblDane(i).y, RGB(255, 255, 255)  
    Next  
End Sub  
 
    Procedura ta przemaluje elementy mapy zapisane do tblDane - znalezione elementy granicy (pomalowane poprzednio na czarno) na biało.  
Biały kolor jest mi potrzeby bo jest to kolor traktowany przez procedury jako element granicy, a poprzednio nadawany kolor czarny był mi  
potrzebny żeby zakończyła się rekurencja. Jednak znając już współżędne granicy kolor czarny nie jest już potrzebny.  
 
    CreateShape strShName  
 
To już utworzenie samego objektu Shape w Arkuszu.  
 
Sub CreateShape(strName As String)  
    'Stop  
    Dim xlWks As Excel.Worksheet  
    Dim xlFreeF As Excel.FreeformBuilder  
    Dim xlShape As Excel.Shape  
      
    Set xlWks = ThisWorkbook.Worksheets("Arkusz1")  
    'Set xlFreeF = xlWks.Shapes.BuildFreeform(EditingType:=msoEditingAuto, _  
                                             X1:=tblDane(0).x, _  
                                             Y1:=tblDane(0).y)  
    Dim i As Long  
    'With xlFreeF  
        'For i = 1 To UBound(tblDane)  
            '.AddNodes msoSegmentLine, msoEditingAuto, tblDane(i).x, tblDane(i).y  
        'Next  
        '.ConvertToShape  
    'End With  
      
    'http://www.mrexcel.com/forum/showthread.php?t=75527  
    'BuildFreeform co-ordinates  
 
    Dim Poly As Object  
      
    Set Poly = xlWks.Drawings.Add(tblDane(0).x, tblDane(0).y, tblDane(0).x, tblDane(0).y, False)  
    With Poly  
        For i = 1 To UBound(tblDane)  
            .AddVertex tblDane(i).x, tblDane(i).y  
        Next  
        .Name = strName  
        .ShapeRange.Line.Weight = 1  
        .ShapeRange.Fill.ForeColor.RGB = RGB(220, 220, 220)  
    End With  
    Set Poly = Nothing  
 
    Set xlWks = Nothing  
    Set xlFreeF = Nothing  
End Sub  
 
    No właśnie :-)  
Najpierw stwierdziłem że będę to robił poprzez Shapes.BuildFreeform. Przestrzegam Was jednak przed tą metodą. Złośliwaaaa! :-P  
Metoda .ConvertToShape działa raz na 20. Pojęcia nie mam czemu. Byle że ujażmić jej nie mogłem. Z pomocą przyszła cytowana w kodzie   
strona zmieniająca nieco podejście do zadania. Nazwy obiektu nie zmieniałem z szacunku !! Dla twórcy. Ukłony! :-)  
Drawings.Add - pierwsze słyszę :-) jednak działa całkiem fajnie!.  
 
        .Name = strName  
        .ShapeRange.Line.Weight = 1  
        .ShapeRange.Fill.ForeColor.RGB = RGB(220, 220, 220)  
 
Name powstałego obiektu zgodna z określoną funkcją ShName. Szerokość linii na 1 i kolor wypełnienia na szary to elementy które gwarantują  
że bez względu na wersję Excela tworzone shape będą dość podobne. Polegając na wartościach domyślnych otrzymujemy zupełnie inne   
obiekty.  
    No i mamy powiat. :-) W Excelu 2010 UserForm może się zawiecić ale kształt i tak powstanie. A cierpliwy twórca mapę swoją stworzy.  
W E2003 całośc działa dużo stabilniej.   
 
PS: coraz poważniej myślę o nie przechodzeniu do nowej wersji Excela albo przynajmniej zachowaniu obu. Bo coraz częściej się przekonuję  
że to co tracę przechodząc na nową wersję nie zostanie zrekompenowane Ribbon'em ;-) Ale pewnie zasadniczym powodem jest fakt że   
używam tej alpikacji w trochu niestandardowy sposób. Tymniemniej MA DZIAŁAĆ a działa ~ledwo! :-|  
 
Pozostaje nam jeszcze sprawa np.: zmiany pozycji, lub powiększenie/pomniejszenie/inna edycja całego układu.  
do tego jest nam potrzebna mozliwośc tymczasowego zgrupowania naszych kształtów. Pomóc może procedura grupująca obiekty Shape w   
zakresie Selection…  
 
Sub MergeShapesInSelection()  
    Dim xlRng As Excel.Range  
    Dim xlShp As Excel.Shape  
    Dim tblNames() As Variant, i As Integer  
      
    If TypeName(Selection) <> "Range" Then Exit Sub  
    Set xlRng = Selection  
      
    With xlRng.Parent  
        For Each xlShp In .Shapes  
            If Not Intersect(xlShp.TopLeftCell, xlRng) Is Nothing Then  
                ReDim Preserve tblNames(i)  
                tblNames(i) = xlShp.Name: i = i + 1  
            End If  
        Next  
        If i > 0 Then .Shapes.Range(tblNames).Group  
    End With  
    Set xlRng = Nothing  
End Sub  
 
Po zakończeniu tworzenia powiatów woj.. Zachodnio Pomorskiego mamy w arkuszu…  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Zanzaczamy ten zakres i odpalamy procedurę MergeShapesInSelection  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Tak wygląda zgrupowany obiekt podczas powiększania. Jak widać powiększa się wszystko zachowując proporcję :-)  
Po dokonaniu odpowiedniej edycji: PPM / Grupa / Rozgrupuj…  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
i mamy poddzielne elementy mapy.  
 
Teraz kolorowanie elementów:  
 - filtrujemy dane w Ark.Arkusz3 po województwie (kol.4)   
 - do Ark.Arkusz1 do kol. (nazwijmy ją) 1 kopiujemy nazwy wyfiltrowanych powiatów, a do kol.2 nazwy nadane utworzonym kształtom.  
 - Wart. (kol3) to =ZAOKR(LOS()*500;0)  
 - Wart.% (kol4) to =L39/MAX($L$39:$L$59) wartość analizowana / wartość max.  
 - formuły dla R,G,B wyjaśnione w poprzednim artykule! Tak jak i kolory graniczne funkcja zwracająca te kolory ze skłądowych.  
 - ostatnia kolumna (wartości 0 - bez nagłówka) to formuła =ShapeFillRGB(K39;O39;P39;Q39)  
   gdzie K39 to odwołanie do nazwy obiektu Shape np.: "drow_9", a O39,P39,Q39 to składowe koloru dla tego kształtu.   Inny sposób prezentowania danych na mapie
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Realizuje to funkcja  
 
Function ShapeFillRGB(xlLabelName As String, R As Integer, G As Integer, B As Integer)  
    With Application.Caller.Parent.Shapes(xlLabelName)    
        .Fill.ForeColor.RGB = VBA.RGB(R, G, B)    
    End With   Przykład można pobrać z..
End Function    
  xl0000100.zip
Już w poprzednim art. Pisałem że funkcją można modyfikować/tworzyć obiekty Shape. To również przykład takiej funkcji.    
Reakcję widac na obiektach shape :-)    
 
No i to chyba wszystko. Mam nadzieję że Wam się spodoba. :-)