[COLOR=blue][COLOR=green]' Requires that Microsoft Scripting Runtime library is added as Reference
' And Microsoft XML library
[/color]
Option Explicit
Private RegionDictionary As New Dictionary 'Requires that Microsoft Scripting Runtime library is added as Reference
Private Declare Function FrameRgn Lib "gdi32" (ByVal hdc As Long, ByVal hrgn As Long, ByVal hbrush As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
[COLOR=green]'Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
'Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long[/color]
Private Declare Function PtInRegion Lib "gdi32.dll" (ByVal hrgn As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function InvertRgn Lib "gdi32" (ByVal hdc As Long, ByVal hrgn As Long) As Long
Private Declare Function InvalidateRgn Lib "user32" (ByVal hwnd As Long, ByVal hrgn As Long, ByVal bErase As Long) As Long
Private Declare Function PaintRgn Lib "gdi32" (ByVal hdc As Long, ByVal hrgn As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" (lpPoint As POINTAPI, lpPolyCounts As Long, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hrgn As Long, ByVal hbrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Const WINDING = 2
Private Const ALTERNATE = 1
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Sub Command1_Click()
Dim mydoc As New DOMDocument
Dim lp As Long
Dim fred As IXMLDOMSelection
Dim plotstring As String
[COLOR=green]' This is all very bespoke[/color]
mydoc.Load "f:\italymapsvg2.txt" [COLOR=green]' SVG paths in an xml file[/color]
Set fred = mydoc.getElementsByTagName("a/path") [COLOR=green]' get all the paths[/color]
[COLOR=green]' clean the path[/color]
For lp = 0 To fred.length - 1
plotstring = fred(lp).Attributes(1).Text
plotstring = Left(plotstring, Len(plotstring) - 2)
plotstring = Right(plotstring, Len(plotstring) - 2)
polyplot plotstring [COLOR=green]' turn into a region, add to dictionary, and plot filled and outlined[/color]
Next
End Sub
Private Sub Form_Load()
Form1.ScaleMode = vbPixels
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lp As Long
Dim hbrush As Long
Static prevhighlight As Long
[COLOR=green]' loop through all regions to see if we get a hit[/color]
For lp = 0 To RegionDictionary.Count - 1
If PtInRegion(RegionDictionary.Items(lp), X, Y) Then
paintaregion prevhighlight, RGB(127 + 42 * (lp Mod 3 + 1), 127, 127)
paintaregion RegionDictionary.Items(lp), RGB(192, 64, 64)
Text1.Text = RegionDictionary.Keys(lp)
prevhighlight = RegionDictionary.Items(lp)
End If
Next
End Sub
[COLOR=green]' Cleanup at form unload[/color]
Private Sub Form_Unload(Cancel As Integer)
Dim lp As Long
[COLOR=green]' loop through all regions and delete GDI objects[/color]
For lp = 0 To RegionDictionary.Count - 1
DeleteObject RegionDictionary.Items(lp)
Next
End Sub
Private Sub polyplot(strplotstring As String)
Dim strLine As String
Dim StrLineElements
Dim lp As Long
Dim lastx, lasty
Dim polyPoints() As POINTAPI
Dim numvertices() As Long
Dim polycount As Long
Dim vertices As Long
Dim myrgn As Long
Static regioncount As Long
StrLineElements = Split(strplotstring, " ")
For lp = 0 To UBound(StrLineElements) Step 2
ReDim Preserve polyPoints(lp \ 2) As POINTAPI
If StrLineElements(lp) = "Z" Then [COLOR=green]' new polygon to add to our polypolygon[/color]
ReDim Preserve numvertices(polycount) As Long
numvertices(polycount) = vertices + 1
vertices = 0
polycount = polycount + 1
End If
If StrLineElements(lp) <> "Z" Then
polyPoints(lp \ 2).X = StrLineElements(lp)
polyPoints(lp \ 2).Y = StrLineElements(lp + 1)
vertices = vertices + 1
End If
Next
ReDim Preserve numvertices(polycount) As Long
numvertices(polycount) = vertices
myrgn = CreatePolyPolygonRgn(polyPoints(0), numvertices(0), polycount + 1, 1)
RegionDictionary.Add "Region " & regioncount, myrgn
regioncount = regioncount + 1
paintaregion myrgn, RGB(127 + 42 * (regioncount Mod 3 + 1), 127, 127)
End Sub
Public Sub paintaregion(hrgn As Variant, Optional fillcolour As Long = &H7F7FFF, Optional framecolour As Long = &HC8C8C8)
Dim hbrush As Long
hbrush = CreateSolidBrush(fillcolour)
FillRgn Form1.hdc, hrgn, hbrush
DeleteObject hbrush [COLOR=green]' make sure we clean up GDI objects we are no longer using[/color]
hbrush = CreateSolidBrush(framecolour)
FrameRgn Form1.hdc, hrgn, hbrush, 1, 1
DeleteObject hbrush [COLOR=green]' make sure we clean up GDI objects we are no longer using[/color]
End Sub[/color]
