MapWinGIS::VB6SampleCode-ContourToPolishMap
From MapWindow GIS
This code belongs on a VB6 form with a single button called ParseContoursCmd, along with a picturebox called Map1.
Here is the code:
Option Explicit
' The goal of this code is to automate rendering NC DOT contour data into a form that
' can be loaded (along with other data) as background maps onto consumer-grade Garmin GPS handhelds.
' This map format is unusually sensitive to issues of scale vs. feature visibility (screens of approx 40,000
' total pixels).
' The goal of the project is to create background maps for GPS units to be carried
' by environmental monitors. These maps will include virtually all of the data displayed on
' USGS 7.5 (1:24k) topos, except individual buildings and forest cover, plus contours down to 2-5ft
' They will also include information about impaired streams, permitted discharge sites, '
' ongoing large-scale construction (sedimentation that kills aquatic life), golf courses and
' sewage treatment spray fields (nutrient runoff encourages algae blooms), industrial plants, etc.
' At this point, about 10-20% of NC has been finished (tediously by hand) to the point of being
' successfully loaded onto a Garmin GPS60Cx.
' The DOT LIDAR contour data is published by county as (mutually exclusive) 5ft, 10ft, and 20ft countours
' for all counties, and 2ft contours for 84 of 100 counties. Ideally it would be broken down
' by 100s ((ft Mod 100) = 0), 50s ((ft Mod 50) = 0), 20s ((ft Mod 20) = 0), and 10s ((ft Mod 10) = 0),
' such that no contour is duplicated in two groups.
' The output format is Polish Map Format for which a compiler (for Garmin GPS units) and format
' description is distributed at cGPSmapper.com. GPSMapEdit is another tool that can accomplish some
' of the tasks of this code (tediously) via a GUI. The filtering into contour groups could also be
' accomplished (tediously) with MapWindow's Table Editor plugin, TatukGIS Editor, and of course, ArcGIS.
Dim PolishMap As Integer
Private Function f_Export_Shape_Data _
(Export_Shape As MapWinGIS.Shape, _
ByVal Elevation_Feet As Long) _
As Boolean
Dim prt_cnt As Long
Dim prt_idx() As Long
Dim i As Long
Dim pt As New MapWinGIS.Point
Dim p As Long
Dim p_comma As Boolean
With Export_Shape
prt_cnt = .NumParts
If (prt_cnt <= 1) Then
Print #PolishMap, "Data0=";
For p = 0 To (.numPoints - 1)
If (p > 0) Then
Print #PolishMap, ",";
End If
Print #PolishMap, "(";
Set pt = .Point(p)
Print #PolishMap, (Format(pt.y, "0.00000") & "," & Format(pt.x, "0.00000"));
Print #PolishMap, ")";
Next p
Else
ReDim prt_idx(0 To (prt_cnt - 1))
For i = 0 To (prt_cnt - 1)
prt_idx(i) = .Part(i)
Next i
i = 0
p_comma = False
For p = 0 To (.numPoints - 1)
If (i <= (prt_cnt - 1)) Then
If (p >= prt_idx(i)) Then
Print #PolishMap, vbNewLine;
Print #PolishMap, "Data0=";
i = i + 1
p_comma = False
End If
End If
If (p_comma) Then
Print #PolishMap, ",";
End If
Print #PolishMap, "(";
Set pt = .Point(p)
Print #PolishMap, (Format(pt.y, "0.00000") & "," & Format(pt.x, "0.00000"));
Print #PolishMap, ")";
p_comma = True
Next p
End If
End With
Print #PolishMap, vbNewLine;
Set pt = Nothing
End Function
Private Sub ParseContoursCmd_Click()
Dim county_tbl As New MapWinGIS.Table
Dim county_count As Long
Dim c As Long
Dim con10s_include As Boolean
Dim con2s_type As String
Dim con2s_endlevel As Long
Dim con5s_type As String
Dim con5s_endlevel As Long
Dim con10s_type As String
Dim con10s_endlevel As Long
Dim con20s_type As String
Dim con20s_endlevel As Long
Dim con50s_type As String
Dim con50s_endlevel As Long
Dim con100s_type As String
Dim con100s_endlevel As Long
Dim sf10 As New MapWinGIS.Shapefile
Dim sf20 As New MapWinGIS.Shapefile
Dim sf02 As New MapWinGIS.Shapefile
Dim sf05 As New MapWinGIS.Shapefile
Dim sf10_tbl As New MapWinGIS.Table
Dim sf20_tbl As New MapWinGIS.Table
Dim sf02_tbl As New MapWinGIS.Table
Dim sf05_tbl As New MapWinGIS.Table
Dim sh As New MapWinGIS.Shape
Dim s As Long
Dim ft As Long
Dim shp_path As String
Dim map_id As Long
Dim county_name As String
Dim cty_abbr As String
Dim mp_path As String
Dim mp_filnam As String
With county_tbl
.Open ("C:\Cartography\NCgis\NorthCarolina\COUNTY.DBF")
county_count = .NumRows
End With
For c = 0 To (county_count - 1)
With county_tbl
map_id = CLng(Trim(.CellValue(2, c)))
shp_path = "I:\MapNC\" & Trim(.CellValue(4, c)) & "\"
county_name = Trim(.CellValue(0, c))
cty_abbr = Trim(.CellValue(1, c))
con10s_include = (StrComp(Trim(.CellValue(5, c)), "Y", vbTextCompare) = 0)
con2s_type = Trim(.CellValue(6, c))
con2s_endlevel = CLng(Trim(.CellValue(7, c)))
con5s_type = Trim(.CellValue(8, c))
con5s_endlevel = CLng(Trim(.CellValue(9, c)))
con10s_type = Trim(.CellValue(10, c))
con10s_endlevel = CLng(Trim(.CellValue(11, c)))
con20s_type = Trim(.CellValue(12, c))
con20s_endlevel = CLng(Trim(.CellValue(13, c)))
con50s_type = Trim(.CellValue(14, c))
con50s_endlevel = CLng(Trim(.CellValue(15, c)))
con100s_type = Trim(.CellValue(16, c))
con100s_endlevel = CLng(Trim(.CellValue(17, c)))
End With
On Error Resume Next
sf10.Open (shp_path & "con_" & cty_abbr & "_10_WGS84.shp")
sf10_tbl.Open (shp_path & "con_" & cty_abbr & "_10_WGS84.dbf")
If (Err) Then
MsgBox "Input Path Error", vbOKOnly
End If
sf20.Open (shp_path & "con_" & cty_abbr & "_20_WGS84.shp")
sf20_tbl.Open (shp_path & "con_" & cty_abbr & "_20_WGS84.shp")
If (Err) Then
MsgBox "Input Path Error", vbOKOnly
End If
' mp_path = "C:\Cartography\NCgis\" & Trim(county_tbl.CellValue(4, c)) & "\"
mp_path = shp_path
mp_filnam = "Contour_" & county_name & "_WGS84.mp"
PolishMap = FreeFile
Open (mp_path & mp_filnam) For Output As PolishMap
If (Err) Then
MsgBox "Output Path Error", vbOKOnly
End If
Print #PolishMap, "[IMG ID]", vbNewLine;
Print #PolishMap, ("ID=" & Trim(79350000 + map_id)), vbNewLine;
Print #PolishMap, ("Name=C " & county_name & " Contour"), vbNewLine;
Print #PolishMap, "Preprocess=F", vbNewLine;
Print #PolishMap, "LblCoding=9", vbNewLine;
Print #PolishMap, "TreSize=1023", vbNewLine;
Print #PolishMap, "TreMargin=0#", vbNewLine;
Print #PolishMap, "RgnLimit=1023", vbNewLine;
Print #PolishMap, "Transparent=Y", vbNewLine;
Print #PolishMap, "POIIndex=Y", vbNewLine;
Print #PolishMap, "Levels=7", vbNewLine;
Print #PolishMap, "Level0=24", vbNewLine;
Print #PolishMap, "Level1=23", vbNewLine;
Print #PolishMap, "Level2=22", vbNewLine;
Print #PolishMap, "Level3=20", vbNewLine;
Print #PolishMap, "Level4=18", vbNewLine;
Print #PolishMap, "Level5=16", vbNewLine;
Print #PolishMap, "Level6=15", vbNewLine;
Print #PolishMap, "Zoom0=0", vbNewLine;
Print #PolishMap, "Zoom1=1", vbNewLine;
Print #PolishMap, "Zoom2=2", vbNewLine;
Print #PolishMap, "Zoom3=3", vbNewLine;
Print #PolishMap, "Zoom4=4", vbNewLine;
Print #PolishMap, "Zoom5=5", vbNewLine;
Print #PolishMap, "Zoom6=6", vbNewLine;
Print #PolishMap, "[END-IMG ID]", vbNewLine;
Print #PolishMap, vbNewLine;
If (con10s_include) Then
' Parse out tens that are not fifties (10, 30, 70, 90, 110, 130, 170, 190...)
Debug.Print "10s " & (shp_path & "con_" & cty_abbr & "_10_WGS84.shp") & ": " & Trim(sf10.NumShapes)
For s = 0 To (sf10.NumShapes - 1)
Set sh = sf10.Shape(s)
With sh
ft = CLng(Trim(sf10_tbl.CellValue(0, s)))
If ((ft Mod 50) <> 0) Then
Select Case .ShapeType
Case SHP_POLYLINE
Print #PolishMap, "[POLYLINE]", vbNewLine;
Case Else
Print #PolishMap, "[]", vbNewLine;
End Select
Print #PolishMap, ("Type=" & con10s_type), vbNewLine;
Print #PolishMap, ("Label= " & Trim(ft)), vbNewLine;
If (con10s_endlevel > 0) Then
Print #PolishMap, ("EndLevel=" & Trim(con10s_endlevel)), vbNewLine;
End If
f_Export_Shape_Data sh, ft
Print #PolishMap, "[END]", vbNewLine;
Print #PolishMap, vbNewLine;
End If
End With
Next s
End If
' Parse out twenties that are not one hundreds (20, 40, 60, 80, 120, 140, 160, 180...)
Debug.Print "20s " & (shp_path & "con_" & cty_abbr & "_20_WGS84.shp") & " from " & Trim(sf20.NumShapes)
For s = 0 To (sf20.NumShapes - 1)
Set sh = sf20.Shape(s)
With sh
ft = CLng(Trim(sf20_tbl.CellValue(0, s)))
If ((ft Mod 100) <> 0) Then
Select Case .ShapeType
Case SHP_POLYLINE
Print #PolishMap, "[POLYLINE]", vbNewLine;
Case Else
Print #PolishMap, "[]", vbNewLine;
End Select
Print #PolishMap, ("Type=" & con20s_type), vbNewLine;
Print #PolishMap, ("Label= " & Trim(ft)), vbNewLine;
If (con20s_endlevel > 0) Then
Print #PolishMap, ("EndLevel=" & Trim(con20s_endlevel)), vbNewLine;
End If
f_Export_Shape_Data sh, ft
Print #PolishMap, "[END]", vbNewLine;
Print #PolishMap, vbNewLine;
End If
End With
Next s
' Parse out tens that are fifties (50, 150, 250, 350...)
Debug.Print "50s " & (shp_path & "con_" & cty_abbr & "_10_WGS84.shp") & ": " & Trim(sf10.NumShapes)
For s = 0 To (sf10.NumShapes - 1)
Set sh = sf10.Shape(s)
With sh
ft = CLng(Trim(sf10_tbl.CellValue(0, s)))
If ((ft Mod 50) = 0) Then
Select Case .ShapeType
Case SHP_POLYLINE
Print #PolishMap, "[POLYLINE]", vbNewLine;
Case Else
Print #PolishMap, "[]", vbNewLine;
End Select
Print #PolishMap, ("Type=" & con50s_type), vbNewLine;
Print #PolishMap, ("Label=" & Trim(ft)), vbNewLine;
If (con50s_endlevel > 0) Then
Print #PolishMap, ("EndLevel=" & Trim(con50s_endlevel)), vbNewLine;
End If
f_Export_Shape_Data sh, ft
Print #PolishMap, "[END]", vbNewLine;
Print #PolishMap, vbNewLine;
End If
End With
Next s
' Parse out twenties that are one hundreds (100, 200, 300...)
Debug.Print "100s " & (shp_path & "con_" & cty_abbr & "_20_WGS84.shp") & ": " & Trim(sf20.NumShapes)
For s = 0 To (sf20.NumShapes - 1)
Set sh = sf20.Shape(s)
With sh
ft = CLng(Trim(sf20_tbl.CellValue(0, s)))
If ((ft Mod 100) = 0) Then
Select Case .ShapeType
Case SHP_POLYLINE
Print #PolishMap, "[POLYLINE]", vbNewLine;
Case Else
Print #PolishMap, "[]", vbNewLine;
End Select
Print #PolishMap, ("Type=" & con100s_type), vbNewLine;
Print #PolishMap, ("Label=" & Trim(ft)), vbNewLine;
If (con100s_endlevel > 0) Then
Print #PolishMap, ("EndLevel=" & Trim(con100s_endlevel)), vbNewLine;
End If
f_Export_Shape_Data sh, ft
Print #PolishMap, "[END]", vbNewLine;
Print #PolishMap, vbNewLine;
End If
End With
Next s
Close PolishMap
If (Not con10s_include) Then
mp_filnam = "Contour10s_" & county_name & "_WGS84.mp"
PolishMap = FreeFile
Open (mp_path & mp_filnam) For Output As PolishMap
If (Err) Then
MsgBox "Output Path Error", vbOKOnly
End If
Print #PolishMap, "[IMG ID]", vbNewLine;
Print #PolishMap, ("ID=" & Trim(79351000 + map_id)), vbNewLine;
Print #PolishMap, ("Name=C " & county_name & " Contour10s"), vbNewLine;
Print #PolishMap, "Preprocess=F", vbNewLine;
Print #PolishMap, "LblCoding=9", vbNewLine;
Print #PolishMap, "TreSize=1023", vbNewLine;
Print #PolishMap, "TreMargin=0#", vbNewLine;
Print #PolishMap, "RgnLimit=1023", vbNewLine;
Print #PolishMap, "Transparent=Y", vbNewLine;
Print #PolishMap, "POIIndex=Y", vbNewLine;
Print #PolishMap, "Levels=7", vbNewLine;
Print #PolishMap, "Level0=24", vbNewLine;
Print #PolishMap, "Level1=23", vbNewLine;
Print #PolishMap, "Level2=22", vbNewLine;
Print #PolishMap, "Level3=20", vbNewLine;
Print #PolishMap, "Level4=18", vbNewLine;
Print #PolishMap, "Level5=16", vbNewLine;
Print #PolishMap, "Level6=15", vbNewLine;
Print #PolishMap, "Zoom0=0", vbNewLine;
Print #PolishMap, "Zoom1=1", vbNewLine;
Print #PolishMap, "Zoom2=2", vbNewLine;
Print #PolishMap, "Zoom3=3", vbNewLine;
Print #PolishMap, "Zoom4=4", vbNewLine;
Print #PolishMap, "Zoom5=5", vbNewLine;
Print #PolishMap, "Zoom6=6", vbNewLine;
Print #PolishMap, "[END-IMG ID]", vbNewLine;
Print #PolishMap, vbNewLine;
' Parse out tens that are not fifties (10, 30, 70, 90, 110, 130, 170, 190...)
Debug.Print "10s " & (shp_path & "con_" & cty_abbr & "_10_WGS84.shp") & ": " & Trim(sf10.NumShapes)
For s = 0 To (sf10.NumShapes - 1)
Set sh = sf10.Shape(s)
With sh
ft = CLng(Trim(sf10_tbl.CellValue(0, s)))
If ((ft Mod 50) <> 0) Then
Select Case .ShapeType
Case SHP_POLYLINE
Print #PolishMap, "[POLYLINE]", vbNewLine;
Case Else
Print #PolishMap, "[]", vbNewLine;
End Select
Print #PolishMap, ("Type=" & con10s_type), vbNewLine;
Print #PolishMap, ("Label= " & Trim(ft)), vbNewLine;
If (con10s_endlevel > 0) Then
Print #PolishMap, ("EndLevel=" & Trim(con10s_endlevel)), vbNewLine;
End If
f_Export_Shape_Data sh, ft
Print #PolishMap, "[END]", vbNewLine;
Print #PolishMap, vbNewLine;
End If
End With
Next s
Close PolishMap
End If
On Error Resume Next
sf05.Open (shp_path & "con_" & cty_abbr & "_05_WGS84.shp")
sf05_tbl.Open (shp_path & "con_" & cty_abbr & "_05_WGS84.dbf")
If (Err) Then
MsgBox "Input Path Error", vbOKOnly
Else
mp_filnam = "Contour5s_" & county_name & "_WGS84.mp"
PolishMap = FreeFile
Open (mp_path & mp_filnam) For Output As PolishMap
If (Err) Then
MsgBox "Output Path Error", vbOKOnly
End If
Print #PolishMap, "[IMG ID]", vbNewLine;
Print #PolishMap, ("ID=" & Trim(79340000 + map_id)), vbNewLine;
Print #PolishMap, ("Name=C " & county_name & " Contour5s"), vbNewLine;
Print #PolishMap, "Preprocess=F", vbNewLine;
Print #PolishMap, "LblCoding=9", vbNewLine;
Print #PolishMap, "TreSize=1023", vbNewLine;
Print #PolishMap, "TreMargin=0#", vbNewLine;
Print #PolishMap, "RgnLimit=1023", vbNewLine;
Print #PolishMap, "Transparent=Y", vbNewLine;
Print #PolishMap, "POIIndex=Y", vbNewLine;
Print #PolishMap, "Levels=7", vbNewLine;
Print #PolishMap, "Level0=24", vbNewLine;
Print #PolishMap, "Level1=23", vbNewLine;
Print #PolishMap, "Level2=22", vbNewLine;
Print #PolishMap, "Level3=20", vbNewLine;
Print #PolishMap, "Level4=18", vbNewLine;
Print #PolishMap, "Level5=16", vbNewLine;
Print #PolishMap, "Level6=15", vbNewLine;
Print #PolishMap, "Zoom0=0", vbNewLine;
Print #PolishMap, "Zoom1=1", vbNewLine;
Print #PolishMap, "Zoom2=2", vbNewLine;
Print #PolishMap, "Zoom3=3", vbNewLine;
Print #PolishMap, "Zoom4=4", vbNewLine;
Print #PolishMap, "Zoom5=5", vbNewLine;
Print #PolishMap, "Zoom6=6", vbNewLine;
Print #PolishMap, "[END-IMG ID]", vbNewLine;
Print #PolishMap, vbNewLine;
' Parse out fives
Debug.Print "5s " & (shp_path & "con_" & cty_abbr & "_05_WGS84.shp") & ": " & Trim(sf05.NumShapes)
For s = 0 To (sf05.NumShapes - 1)
Set sh = sf05.Shape(s)
With sh
ft = CLng(Trim(sf05_tbl.CellValue(0, s)))
Select Case .ShapeType
Case SHP_POLYLINE
Print #PolishMap, "[POLYLINE]", vbNewLine;
Case Else
Print #PolishMap, "[]", vbNewLine;
End Select
Print #PolishMap, ("Type=" & con5s_type), vbNewLine;
Print #PolishMap, ("Label= " & Trim(ft)), vbNewLine;
If (con5s_endlevel > 0) Then
Print #PolishMap, ("EndLevel=" & Trim(con5s_endlevel)), vbNewLine;
End If
f_Export_Shape_Data sh, ft
Print #PolishMap, "[END]", vbNewLine;
Print #PolishMap, vbNewLine;
End With
Next s
Close PolishMap
End If
On Error Resume Next
sf02.Open (shp_path & "con_" & cty_abbr & "_02_WGS84.shp")
sf02_tbl.Open (shp_path & "con_" & cty_abbr & "_02_WGS84.dbf")
If (Err) Then
MsgBox "Input Path Error", vbOKOnly
ElseIf (sf02.NumShapes > 0) Then
mp_filnam = "Contour2s_" & county_name & "_WGS84.mp"
PolishMap = FreeFile
Open (mp_path & mp_filnam) For Output As PolishMap
If (Err) Then
MsgBox "Output Path Error", vbOKOnly
End If
Print #PolishMap, "[IMG ID]", vbNewLine;
Print #PolishMap, ("ID=" & Trim(79330000 + map_id)), vbNewLine;
Print #PolishMap, ("Name=C " & county_name & " Contour2s"), vbNewLine;
Print #PolishMap, "Preprocess=F", vbNewLine;
Print #PolishMap, "LblCoding=9", vbNewLine;
Print #PolishMap, "TreSize=1023", vbNewLine;
Print #PolishMap, "TreMargin=0#", vbNewLine;
Print #PolishMap, "RgnLimit=1023", vbNewLine;
Print #PolishMap, "Transparent=Y", vbNewLine;
Print #PolishMap, "POIIndex=Y", vbNewLine;
Print #PolishMap, "Levels=7", vbNewLine;
Print #PolishMap, "Level0=24", vbNewLine;
Print #PolishMap, "Level1=23", vbNewLine;
Print #PolishMap, "Level2=22", vbNewLine;
Print #PolishMap, "Level3=20", vbNewLine;
Print #PolishMap, "Level4=18", vbNewLine;
Print #PolishMap, "Level5=16", vbNewLine;
Print #PolishMap, "Level6=15", vbNewLine;
Print #PolishMap, "Zoom0=0", vbNewLine;
Print #PolishMap, "Zoom1=1", vbNewLine;
Print #PolishMap, "Zoom2=2", vbNewLine;
Print #PolishMap, "Zoom3=3", vbNewLine;
Print #PolishMap, "Zoom4=4", vbNewLine;
Print #PolishMap, "Zoom5=5", vbNewLine;
Print #PolishMap, "Zoom6=6", vbNewLine;
Print #PolishMap, "[END-IMG ID]", vbNewLine;
Print #PolishMap, vbNewLine;
' Parse out twos
Debug.Print "2s " & (shp_path & "con_" & cty_abbr & "_02_WGS84.shp") & ": " & Trim(sf02.NumShapes)
For s = 0 To (sf02.NumShapes - 1)
Set sh = sf02.Shape(s)
With sh
ft = CLng(Trim(sf02_tbl.CellValue(0, s)))
Select Case .ShapeType
Case SHP_POLYLINE
Print #PolishMap, "[POLYLINE]", vbNewLine;
Case Else
Print #PolishMap, "[]", vbNewLine;
End Select
Print #PolishMap, ("Type=" & con2s_type), vbNewLine;
Print #PolishMap, ("Label= " & Trim(ft)), vbNewLine;
If (con2s_endlevel > 0) Then
Print #PolishMap, ("EndLevel=" & Trim(con2s_endlevel)), vbNewLine;
End If
f_Export_Shape_Data sh, ft
Print #PolishMap, "[END]", vbNewLine;
Print #PolishMap, vbNewLine;
End With
Next s
Close PolishMap
End If
Next c
Set sh = Nothing
' sf3.Open "C:\Cartography\Test\CountyBound_Johnston_WGS84.shp"
' sf3_tbl.Open "C:\Cartography\Test\CountyBound_Johnston_WGS84.dbf"
'
' For s = 0 To sf3.NumShapes - 1
' Set sh = New MapWinGIS.Shape
' Set sh = sf3.Shape(s)
' For p = 0 To sh.numPoints - 1
' Set pt = New MapWinGIS.Point
' Set pt = sh.Point(p)
' Set pt = Nothing
' Next p
' Set sh = Nothing
' Next s
End Sub
