VERSION 5.00
Begin VB.Form FILL_Form 
   AutoRedraw      =   -1  'True
   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 = "FILL_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

Private Path$
Private hCel As Integer
Private hCat As Integer
Private hRIM As Integer

Private Bit(31) As Long

Private Type PixelPoint
  x  As Long
  y  As Long
End Type

Private Declare Function Polyline Lib "gdi32" (ByVal hdc As Long, lpPoint As PixelPoint, ByVal nCount As Long) As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As PixelPoint, ByVal nCount As Long) As Long
Private Declare Function SetPolyFillMode Lib "gdi32" (ByVal hdc As Long, ByVal nPolyFillMode As Long) As Long

Private Const WINDING = 2       'Polygon Fill Mode

Private ShorePixel(16384) As PixelPoint
Private ShorePixels As Long
Private FillPixel(16384) As PixelPoint
Private FillPixels As Long
Private ScalePixelX0, ScalePixelXA, ScalePixelY0, ScalePixelYA
Sub DrawRANGS(lon1, lat1, lon2, lat2, Resolution%, flags&)
Dim Opcode As Byte

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

GetPixelScaling

SetPolyFillMode Me.hdc, WINDING

CELFile$ = Path$ + "rangs(" + Chr$(48 + Resolution%) + ").CEL"           'cells
hCel = OpenTheFile(CELFile$)

CATFile$ = Path$ + "rangs(" + Chr$(48 + Resolution%) + ").CAT"              'cell address table
hCat = OpenTheFile(CATFile$)

RIMFile$ = Path$ + "gshhs(" + Chr$(48 + Resolution%) + ").RIM"              'gshhs polygons
hRIM = OpenTheFile(RIMFile$)

For Lat = lat1 To lat2 Step -1
  For Lon = lon1 To lon2
    GoSub DrawTheCell
    Me.Refresh
  Next Lon
Next Lat

Close hCel, hCat, hRIM
Exit Sub


DrawTheCell:
ix = ((Lon Mod 360) + 360) Mod 360
xOffset = Lon - ix
iy = Lat
If iy < -90 Or iy > 89 Then Return
Get hCat, 1 + 4& * ((89 - iy) * 360& + ix), addr&

Get hCel, addr&, Opcode
If Opcode Then
  DrawRANGSPolygonC 0, xOffset, flags&
End If
Return
End Sub

Sub DrawRANGSPolygonC(lvl, xOffset, flags&)
'Datenstruktur des CEL-File
'An der Adresse im CEL-File, auf die der Zellzeiger zeigt, steht ein Gebiet:
'
'Ein Gebiet beginnt mit einem Byte = 1:  Begin_Polygon_CounterClockwise
'                             oder = 2:  Begin_Polygon_Clockwise
' dann kommt ein Polygon-Descriptor.
' dann folgen beliebig viele Gebiete, "Löcher" , die sich innerhalb des gegebenen
' Polygons befinden
'das Gebiet endet mit einem   Byte = 0:  End_Polygon

'Das äußerste Gebiet der Zelle besteht nur aus den 4 Ecken der Zelle und enthält
'zumeist >Meer<. Das Land bildet Löcher im Meer, Seen bilden Löcher im Land etc.

'Polygon-Descriptor:
'(Das Polygon besteht abwechselnd aus RIM-Segmenten und Wegen entlang des Zellrands)
'  4 Byte Polygon-ID
' dann kommen "pieces", die mit je einem Byte beginnen:
' BIT 0,1,2:
'  Byte AND 7 = 0:  Ende des Polygons, nichts folgt mehr
'  Byte AND 7 = 1..6:  Es folgen n (1..6) Punkte auf dem Rand der Zelle, jeder Punkt mit 2 x 4 Byte
'  Byte AND 7 = 7:  Es folgt 4 Byte Segmentadresse + 4 Byte Segmentlänge
' BIT 3: = 1 wenn Umlauf im Uhrzeigersinn, d.h. wenn innen rechts liegt.
' BIT 4,5,6:
'  16*0: innen ist Meer: Polygon kann nur ein Zellrand sein
'  16*1: innen ist Land (außen Meer, wenn es nicht der Zellrand ist)
'  16*2: innen ist See im Land (außen ist Land, wenn es nicht der Zellrand ist)
'  16*3: innen ist Insel im See im Land, außen ist See
'  16*4: innen ist Teich auf der Insel im See im Land, außen ist Insel
'  16*5..7 noch frei
' BIT 7: gesetzt wenn noch unbestimmt

'===========================================
'Lesezeiger steht HINTER BEGIN_POLYGON!

Dim Opcode As Byte, piece As Byte, Pnt As PixelPoint
FirstShore% = True
FirstFill% = True
Get hCel, , PolyID&

fill% = 0
shore% = 0
Do
  Get hCel, , piece
  nPoints& = piece And 7
  flg% = piece \ 16
  If nPoints& Then
    fill% = flags& And Bit(8 + flg%)
    shore% = flags& And Bit(flg%)
  End If
  Select Case nPoints&
    Case 0:      Exit Do
    Case 1 To 6: GoSub ReadCellSegment
    Case 7:      GoSub ReadRimSegment
  End Select
Loop
If FirstFill% = False Then
  BufferAddLine x0Fill, y0Fill, 1
  BufferRestart x0Fill, y0Fill, 1
End If
If FirstShore% = False Then
  BufferAddLine x0Shore, y0Shore, 0
  BufferRestart x0Shore, y0Shore, 0
End If

Do
  Get hCel, , Opcode
  If Opcode = 0 Then
    BufferRestart 0, 0, 1  'empty the Fill Buffer
    BufferRestart 0, 0, 0  'empty the Shore Buffer
    Exit Sub
  End If
  DrawRANGSPolygonC lvl + 1, xOffset, flags&
Loop

ReadCellSegment:
For i = 1 To nPoints&
  Get hCel, , Pnt
  
  If fill% Then GoSub AddFillPoint
  
  If shore% Then
    If flags& And 1 Then  'Cell malen?
      GoSub AddShorePoint                'ja
    Else
      If PolyID& >= 0 Then
        If i = 1 Then
          GoSub AddShorePoint                 'first Point on Cell Border
        ElseIf i = nPoints& Then
          GoSub AddFinalShorePoint            'last Point on Cell Border
        End If
      End If
    End If
  End If
  
Next i
Return

ReadRimSegment:
Get hCel, , addr&
Get hCel, , nPoints&
If nPoints& = 0 Then Return     'Rim in Cell, but no internal point!

Seek hRIM, addr&
For k& = 0 To nPoints& - 1
  Get hRIM, , Pnt
  If fill% Then GoSub AddFillPoint
  If shore% Then GoSub AddShorePoint
Next k&
Return

AddShorePoint:
xpnt = xOffset + Pnt.x * 0.000001
ypnt = Pnt.y * 0.000001
If FirstShore% Then
  GoSub SetShoreColor
  BufferRestart xpnt, ypnt, 0
  FirstShore% = False
  x0Shore = xpnt
  y0Shore = ypnt
Else
  BufferAddLine xpnt, ypnt, 0
End If
Return

AddFillPoint:
xpnt = xOffset + Pnt.x * 0.000001
ypnt = Pnt.y * 0.000001
If FirstFill% Then
  GoSub SetFillColor
  BufferRestart xpnt, ypnt, 1
  FirstFill% = False
  x0Fill = xpnt
  y0Fill = ypnt
Else
  BufferAddLine xpnt, ypnt, 1
End If
Return

AddFinalShorePoint:
xpnt = xOffset + Pnt.x * 0.000001
ypnt = Pnt.y * 0.000001
BufferRestart xpnt, ypnt, 0
Return

SetShoreColor:
  
'Specify Colors
  Select Case flg%
    Case 17: clr& = QBColor(14)  'Error
    Case 0:  clr& = QBColor(1)    'Ocean
    Case 1:  clr& = QBColor(1)    'Land
    Case 2:  clr& = QBColor(1)   'Lake
    Case 3:  clr& = QBColor(1)   'Island
    Case 4:  clr& = QBColor(1)    'Pond
    Case Else: clr& = QBColor(15)  'unknown
  End Select
  
  'Shoreline color
  Me.ForeColor = clr&
  
Return

SetFillColor:
  
'Specify Colors
  Select Case flg%
    Case 17: clr& = QBColor(14)  'Error
    Case 0:  clr& = QBColor(9)    'Ocean
    Case 1:  clr& = QBColor(6)    'Land
    Case 2:  clr& = QBColor(3)   'Lake
    Case 3:  clr& = QBColor(6)   'Island
    Case 4:  clr& = QBColor(3)    'Pond
    Case Else: clr& = QBColor(15)  'unknown
  End Select
  
  'Fill color
  Me.FillColor = clr&
  
Return

End Sub

Private Sub BufferAddLine(x, y, fill%)
If fill% Then
  FillPixels = FillPixels + 1
  FillPixel(FillPixels).x = (x - ScalePixelX0) * ScalePixelXA
  FillPixel(FillPixels).y = (y - ScalePixelY0) * ScalePixelYA
  If FillPixels = UBound(FillPixel) Then BufferRestart x, y, fill%
Else
  ShorePixels = ShorePixels + 1
  ShorePixel(ShorePixels).x = (x - ScalePixelX0) * ScalePixelXA
  ShorePixel(ShorePixels).y = (y - ScalePixelY0) * ScalePixelYA
  If ShorePixels = UBound(ShorePixel) Then BufferRestart x, y, fill%
End If
End Sub


Private Sub BufferRestart(x, y, fill%)
If fill% Then
  If FillPixels Then
    ThisFillStyle = Me.FillStyle
    Me.FillStyle = 0
    ThisForeColor = Me.ForeColor
    Me.ForeColor = Me.FillColor
    'MsgBox "Fill"
    Polygon Me.hdc, FillPixel(0), FillPixels + 1
    Me.ForeColor = ThisForeColor
    Me.FillStyle = ThisFillStyle
    'Me.Refresh
  End If
  FillPixels = 0
  FillPixel(FillPixels).x = (x - ScalePixelX0) * ScalePixelXA
  FillPixel(FillPixels).y = (y - ScalePixelY0) * ScalePixelYA
Else
  If ShorePixels Then
    'Debug.Print Me.ForeColor
    'MsgBox "Shore"
    Polyline Me.hdc, ShorePixel(0), ShorePixels + 1
    'Me.Refresh
  End If
  ShorePixels = 0
  ShorePixel(ShorePixels).x = (x - ScalePixelX0) * ScalePixelXA
  ShorePixel(ShorePixels).y = (y - ScalePixelY0) * ScalePixelYA
End If

End Sub

Sub GetPixelScaling()
ScalePixelX0 = Me.ScaleLeft
ScalePixelY0 = Me.ScaleTop

ThisScaleLeft = Me.ScaleLeft
ThisScaleTop = Me.ScaleTop
ThisScaleWidth = Me.ScaleWidth
ThisScaleHeight = Me.ScaleHeight
ThisScaleMode = Me.ScaleMode

Me.ScaleMode = 3  'Pixels
ScalePixelXA = Me.ScaleWidth
ScalePixelYA = Me.ScaleHeight

Me.ScaleLeft = ThisScaleLeft
Me.ScaleTop = ThisScaleTop
Me.ScaleWidth = ThisScaleWidth
Me.ScaleHeight = ThisScaleHeight
Me.ScaleMode = ThisScaleMode
  
ScalePixelXA = ScalePixelXA / Me.ScaleWidth
ScalePixelYA = ScalePixelYA / Me.ScaleHeight
End Sub

Function OpenTheFile(File$) As Integer
h% = FreeFile
Open File$ For Binary Access Read As h%
If LOF(h%) Then
  OpenTheFile = h%
  Exit Function
End If

MsgBox "File not found " + File$
Close h%
End
End Function

Private Sub Form_Load()
Bit(0) = 1
For i = 1 To 30
  Bit(i) = 2 * Bit(i - 1)
Next i
Bit(31) = &H80000000
Me.Show

Path$ = "g:\shorelin\"
Path$ = InputBox("Path", "RANGS Folder", Path$)
If Path$ = "" Then End

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

'UK & Ireland:
'lon1 = -10
'lat1 = 60
'lon2 = 10
'lat2 = 50

'Great Lakes
'lon1 = -95
'lat1 = 50
'lon2 = -75
'lat2 = 40

'Australia
'lon1 = 110
'lat1 = -5
'lon2 = 160
'lat2 = -45

'South Africa
'lon1 = 15
'lat1 = -25
'lon2 = 30
'lat2 = -35

Resolution% = 0
flags& = 0
'Select Borders to be drawn
'flags& = Bit(0)             'Box border
flags& = flags& Or Bit(1)    'Land border
flags& = flags& Or Bit(2)    'lake border
flags& = flags& Or Bit(3)    'isle border
flags& = flags& Or Bit(4)    'pond border

'Select objects to be filled
'Note: You can fill land without filling ocean
'      you cannot fill ocean without filling land, though

'flags& = flags& Or Bit(8)  'Fill Ocean
flags& = flags& Or Bit(9)   'Fill Land
flags& = flags& Or Bit(10)  'Fill Lakes
flags& = flags& Or Bit(11)  'Fill Isles
flags& = flags& Or Bit(12)  'Fill Ponds

DrawRANGS lon1, lat1, lon2, lat2, Resolution%, flags&

'Note: to have shorelines overdrawn nowhere by filling,
'you need to draw each cell twice, first filling, then
'outlining.

End Sub