VERSION 5.00
Begin VB.Form RANGS_Form 
   Caption         =   "RANGS Example Program Sept.6, 1999"
   ClientHeight    =   7344
   ClientLeft      =   60
   ClientTop       =   348
   ClientWidth     =   7776
   LinkTopic       =   "Form1"
   ScaleHeight     =   7344
   ScaleWidth      =   7776
   StartUpPosition =   3  'Windows Default
End
Attribute VB_Name = "RANGS_Form"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
DefInt I-N: DefSng A-H, O-Z

'==========================================================
'Example program in Visual Basic for using RANGS shorelines
'Version 1.1, September 6, 1999

'Regionally Accessible Nested Global Shorelines RANGS

'Rainer Feistel
'Institut für Ostseeforschung, Warnemünde

'http://www.io-warnemuende.de/public/phy/rfeistel/index.htm
'==========================================================

Private hCEL As Integer
Private hCAT As Integer
Private hRIM As Integer

Private Type PixelPoint
  X  As Long
  Y  As Long
End Type


Private Sub Form_Load()
Me.AutoRedraw = True
Me.Show

'Mecklenburg
lon1 = 11
lat1 = 54
lon2 = 14
lat2 = 53

'UK+Ireland
'lon1 = -15
'lat1 = 59
'lon2 = 5
'lat2 = 49

Resolution% = 0        'highest resolution
flags& = 1 + 2 + 4 + 8 'draw cell box, shore, lakes, islands
DrawRANGS lon1, lat1, lon2, lat2, Resolution%, flags&
End Sub


Sub DrawRANGS(lon1, lat1, lon2, lat2, Resolution%, flags&)
Dim PolygonByte As Byte

Me.ScaleLeft = lon1
Me.ScaleWidth = lon2 + 1 - lon1
Me.ScaleTop = lat1 + 1
Me.ScaleHeight = lat2 - lat1 - 1

CELFile$ = "rangs(" + Chr$(48 + Resolution%) + ").CEL"            'cells
hCEL = FreeFile
Open CELFile$ For Binary Access Read As hCEL
If LOF(hCEL) = 0 Then MsgBox "Missing " + CELFile$: End

CATFile$ = "rangs(" + Chr$(48 + Resolution%) + ").CAT"              'cell address table
hCAT = FreeFile
Open CATFile$ For Binary Access Read As hCAT
If LOF(hCAT) = 0 Then MsgBox "Missing " + CATFile$: End

RIMFile$ = "gshhs(" + Chr$(48 + Resolution%) + ").RIM"              'gshhs polygons
hRIM = FreeFile
Open RIMFile$ For Binary Access Read As hRIM
If LOF(hRIM) = 0 Then MsgBox "Missing " + RIMFile$: End

For Lat = lat1 To lat2 Step -1
  For lon = lon1 To lon2
    lon0 = (lon + 360) Mod 360
    diff = lon - lon0
    Get hCAT, 1 + 4& * ((89 - Lat) * 360& + lon0), addr&
    Get hCEL, addr&, PolygonByte
    If PolygonByte Then DrawRANGSPolygon 0, flags&, diff
    Me.Refresh
  Next lon
Next Lat

Close hCEL, hCAT, hRIM
End Sub

Sub DrawRANGSPolygon(lvl, flags&, diff)
Dim PolygonByte As Byte, SegmentByte As Byte, Pnt As PixelPoint
Dim First As Boolean

First = True
Get hCEL, , PolyID&
Do
  Get hCEL, , SegmentByte
  nPoints& = SegmentByte And 7
  Select Case nPoints&
    Case 0:      Exit Do
    Case 1 To 6: GoSub ReadCellSegment
    Case 7:      GoSub ReadRimSegment
  End Select
Loop
If Not First Then Me.Line -(x0, y0)

Do
  Get hCEL, , PolygonByte
  If PolygonByte Then DrawRANGSPolygon lvl + 1, flags&, diff
Loop While PolygonByte
Exit Sub

ReadCellSegment:
For Pt& = 1 To nPoints&
  Get hCEL, , Pnt
  If flags& And 1 Then                'Draw Cell?
    GoSub DrawThePoint
  Else
    If PolyID& >= 0 Then
      If Pt& = 1 Then
        GoSub DrawThePoint
      ElseIf Pt& = nPoints& Then
        GoSub DrawTheLastPoint
      End If
    End If
  End If
Next Pt&
Return

ReadRimSegment:
Get hCEL, , addr&
Get hCEL, , nPoints&
If nPoints& = 0 Then Return

Seek hRIM, addr&
For k& = 0 To nPoints& - 1
  Get hRIM, , Pnt
  GoSub DrawThePoint
Next k&
Return

DrawThePoint:
flg% = SegmentByte \ 16
If (flags& And 2 ^ flg%) = 0 Then Return

xpnt = Pnt.X * 0.000001 + diff
ypnt = Pnt.Y * 0.000001
If First Then
  Select Case flg%
    Case 0: clr& = QBColor(3)
    Case 1: clr& = QBColor(4)
    Case 2: clr& = QBColor(1)
    Case 3: clr& = QBColor(2)
    Case 4: clr& = QBColor(9)
    Case Else: clr& = 0
  End Select
  Me.ForeColor = clr&
  Me.PSet (xpnt, ypnt)
  First = False
  x0 = xpnt
  y0 = ypnt
Else
  Me.Line -(xpnt, ypnt)
End If
Return

DrawTheLastPoint:
flg% = SegmentByte \ 16
If (flags& And 2 ^ flg%) = 0 Then Return
xpnt = Pnt.X * 0.000001 + diff
ypnt = Pnt.Y * 0.000001
Me.PSet (xpnt, ypnt)
Return

End Sub