MapWindow Script Directory
Script: ColorAndRenameLayers
Imports MapWindow.Interfaces
Imports MapWinGIS
Imports System
Imports System.Windows.Forms
Imports System.Collections
Imports Microsoft.VisualBasic
'Each script should (but doesn't have to) have a unique name.
'Change MyExample here to something meaningful. ScriptMain should remain as "Main" however.
'***********************************************
'* Author: Paul Meems 7 feb 2006
'* This script renames the layernames
'* in the projectfile and gives all
'* shapes an unique color
'* Thanks to Chris Michaelis for helping me out
'* Paul Meems 13 november 2006
'* Added new function ColorByContiniousRamp,
'* which colors the shapefile using a color ramp
'***********************************************
Public Module ColorRenameLayers
'***********************
'* Main
'***********************
Public Sub ScriptMain(ByRef m_MapWin As IMapWin)
Dim i As Long, handle As Long
Dim fldIndex as Integer = 0 'Set this to the desired field
Dim sStripString as string = "Martin-Test field total" 'this string is removed from the layername
Dim bStep1 as Boolean = True ' I use this script twice, first step is to create
'unique colors, then I manually check all layers, next step is to create a continious ramp
'and the *.mwsr file.
'[PM 16 nov 2006]Due to remarks of Chris I've placed
'm_MapWin.Layers.GetHandle(i) in place of just i in
'calls to m_MapWin.Layers()
For i = 0 To m_MapWin.Layers.NumLayers - 1
'get layer handle:
handle = m_MapWin.Layers.GetHandle(i)
'Rename layername in projectfile
'm_MapWin.Layers(handle).Name = RenameLayername(m_MapWin.Layers(handle).Name)
m_MapWin.Layers(handle).Name = RemoveStringInLayername(m_MapWin.Layers(handle).Name, sStripString)
If bStep1 Then
'Color layer with unique colors:
ColorByUniqueBreaks(m_MapWin, fldIndex, handle)
Else
'Color with continious ramp:
StartColorByContiniousRamp(m_MapWin, fldIndex, handle)
'Create *.mwsr file:
If Not m_MapWin.Layers(handle).SaveShapeLayerProps() Then
MsgBox ("Could not create *.mwsr for " & m_MapWin.Layers(handle).Name)
End If
End If
Next i
MsgBox ("Ready")
End Sub
'***********************
'* RenameLayername
'***********************
Private Function RenameLayername(ByVal sLayername As String) As String
Dim arrTemp() As String
arrTemp = sLayername.Split(" ")
If (arrTemp.GetUpperBound(0) > 0) Then
sLayername = arrTemp(arrTemp.GetUpperBound(0))
End If
Return sLayername
End Function
'***********************
'* RenameLayername
'***********************
Private Function RemoveStringInLayername(ByVal sLayername As String, ByVal sStripString as String) As String
sLayername = sLayername.Replace(sStripString, "")
Return sLayername.Trim()
End Function
'***********************
'* StartColorByContiniousRamp
'***********************
Sub StartColorByContiniousRamp(ByRef m_MapWin As IMapWin, ByVal fld As Integer, ByVal lyrNum As Integer)
'Give each layer its own color ramp
Dim usedColors As New Hashtable()
Dim startColor, endColor As UInt32
'Get the unique colors for this project:
startColor = getRandomColor(usedColors)
endColor = getRandomColor(usedColors)
'Do the coloring
ColorByContiniousRamp(m_MapWin, fld, lyrNum, startColor, endColor)
'Clean up
usedColors = Nothing
End Sub
'***********************
'* ColorByContiniousRamp
'***********************
Private Function ColorByContiniousRamp(ByRef m_MapWin As IMapWin, ByVal fldIndex As Integer, ByVal lyrNum As Integer, ByRef ColorStart As UInt32, ByRef ColorEnd As UInt32) As Boolean
Dim colorscheme As New MapWinGIS.ShapefileColorScheme()
Dim colorbreak As New MapWinGIS.ShapefileColorBreak()
Dim sf As MapWinGIS.Shapefile
Dim fieldMin, fieldMax As Double
'Get shapefile
sf = CType(m_MapWin.Layers(lyrNum).GetObject, MapWinGIS.Shapefile)
If sf Is Nothing Then Return False
'Check input:
If fldIndex > sf.NumFields - 1 OrElse fldIndex < 0 Then Return False
If lyrNum > m_MapWin.Layers.NumLayers - 1 OrElse lyrNum < 0 Then Return False
colorscheme.FieldIndex = fldIndex
colorscheme.LayerHandle = lyrNum
colorbreak.Caption = sf.Field(fldIndex).Name
getMinMaxField(sf, fldIndex, fieldMin, fieldMax)
'msgbox("fieldMin " & fieldMin & " fieldMax: " & fieldMax)
colorbreak.StartValue = fieldMin
colorbreak.startColor = ColorStart
colorbreak.EndValue = fieldMax
colorbreak.endColor = ColorEnd
colorscheme.Add (colorbreak)
'Set outlinecolor to black
m_MapWin.Layers(lyrNum).OutlineColor = System.Drawing.Color.Black
'Set fill color of layer to white, this is also the default fill color,
'this should be done before attaching the color scheme:
m_MapWin.Layers(lyrNum).Color = System.Drawing.Color.White
'Attach colorscheme to layer:
m_MapWin.Layers(lyrNum).ColoringScheme = colorscheme
'Clean up:
sf = Nothing
colorscheme = Nothing
colorbreak = Nothing
End Function
'***********************
'* getMinMaxField
'***********************
Sub getMinMaxField(ByRef sf As MapWinGIS.Shapefile, ByRef fldIndex As Integer, ByRef fieldMin As Double, ByRef fieldMax As Double)
'Loop trough all values of the field and determin the min and max
Dim i As Integer
Dim val As Double
'init:
fieldMin = 10000000
fieldMax = -1000000
Try
For i = 0 To sf.NumShapes - 1
val = sf.CellValue(fldIndex, i)
If val < fieldMin Then fieldMin = val
If val > fieldMax Then fieldMax = val
Next i
Catch lEx As Exception
MsgBox ("Exception " & lEx.ToString)
End Try
End Sub
'***********************
'* ColorByUniqueBreaks
'***********************
Private Function ColorByUniqueBreaks(ByRef m_MapWin As IMapWin, ByVal fld As Integer, ByVal lyrNum As Integer) As Boolean
Dim m_ColoringScheme As New MapWinGIS.ShapefileColorScheme
Dim i As Integer
Dim ht As New Hashtable()
Dim sf As MapWinGIS.Shapefile
Dim val As Object
Dim arr() As Object
'Dim tPrecision As Integer is never used.
'Get shapefile
sf = CType(m_MapWin.Layers(lyrNum).GetObject, MapWinGIS.Shapefile)
If sf Is Nothing Then
Return False
End If
'Check input:
If fld > sf.NumFields - 1 OrElse fld < 0 Then
Return False
End If
If lyrNum > m_MapWin.Layers.NumLayers - 1 OrElse lyrNum < 0 Then
Return False
End If
'Remove current colors:
While m_ColoringScheme.NumBreaks > 0
m_ColoringScheme.Remove (0)
End While
'Get unique values
For i = 0 To sf.NumShapes - 1
val = sf.CellValue(fld, i)
If Not ht.ContainsKey(val) Then
ht.Add(val, val)
End If
Next i
'Create sorted array:
ReDim arr(ht.Count - 1)
ht.Values().CopyTo(arr, 0)
Array.Sort(arr)
'Create color for each unique value
For i = 0 To arr.length - 1
Dim brk As New MapWinGIS.ShapefileColorBreak
Dim randomColor As UInt32
Dim usedColors As New Hashtable
'because the coloring is randomly chosen, it's possible (and happens often) that
'the same color is chosen twice.
'Beacuse of this I save the colors per scheme to avoid this.
randomColor = getRandomColor(usedColors)
brk.startColor = randomColor
brk.endColor = randomColor
brk.StartValue = arr(i)
brk.EndValue = arr(i)
If IsNumeric(arr(i)) Then
brk.Caption = CDbl(arr(i)).ToString("G3") 'G3 == format string
Else
brk.Caption = CStr(arr(i))
End If
'the field value to color by
m_ColoringScheme.FieldIndex = fld
m_ColoringScheme.Add (brk)
brk = Nothing
usedColors = Nothing
Next i
'Clean up:
ht = Nothing
sf = Nothing
'Set outlinecolor to black
m_MapWin.Layers(lyrNum).OutlineColor = System.Drawing.Color.Black
'Set fill color of layer to white, this is also the default fill color,
'this should be done before attaching the color scheme:
m_MapWin.Layers(lyrNum).Color = System.Drawing.Color.White
'Attach colorscheme to layer:
m_MapWin.Layers(lyrNum).ColoringScheme = m_ColoringScheme
Return True
End Function
'***********************
'* getRandomColor
'***********************
Function getRandomColor(ByRef usedColors As Hashtable) As UInt32
Dim randomColor As UInt32
Dim webSafeColor As String
Dim r, g, b As Integer
'because the coloring is randomly chosen, it's possible (and happens often) that
'the same color is chosen twice.
'Beacuse of this I save the colors per scheme to avoid this.
'I want nice contrasting colors so I save the websafe colorvalues so I don't get
'for example several shades of lightgreen.
r = CInt(Rnd() * 255)
g = CInt(Rnd() * 255)
b = CInt(Rnd() * 255)
webSafeColor = Hex(r).Substring(0, 1) & Hex(g).Substring(0, 1) & Hex(b).Substring(0, 1)
randomColor = System.Convert.ToUInt32(RGB(r, g, b))
Do While usedColors.ContainsKey(webSafeColor)
r = CInt(Rnd() * 255)
g = CInt(Rnd() * 255)
b = CInt(Rnd() * 255)
webSafeColor = Hex(r).Substring(0, 1) & Hex(g).Substring(0, 1) & Hex(b).Substring(0, 1)
randomColor = System.Convert.ToUInt32(RGB(r, g, b))
Loop
usedColors.Add(webSafeColor, webSafeColor)
Return randomColor
End Function
End ModuleBack
