SampleCode-MSAccess2003-DigitizingPolygons

This is a back-up of the WIKI.
Not all links might work
We're working on a new wiki.

Main Page | Recent changes | View source | Page history | Log in / create account |

Printable version | Disclaimers | Privacy policy

This is an example of digitizing polygons in a VBA environment (Access 2003 here). This was contributed by Jack MacDonald.

Option Compare Database
Option Explicit

Dim nPoints As Integer  ' number of digitized points
Dim Points() As Double ' array of points in screen coordinates
Dim lastX As Long ' for managing the rubberband effece
Dim lastY As Long ' for managing the rubberband effece
Dim hndlDrawing As Long ' handle to layer where the drawings are made

' Requires these controls on the form:
' MapWinGIS Map named   axMap
' toggle button named tglAddShape
' toggle button named tglRemoveShapeFromLayer
' toggle button named tglCursor

' VERY IMPORTANT: combo box named cboZoneLayer
'   whose VALUE property equals then layer number 
'   where the shapes are created


Private Sub axMap_MouseUp(ByVal Button As Integer, ByVal Shift As 
Integer, ByVal x As Long, ByVal y As Long)
    
    If tglAddShape Then
        EnterPolygonPoints x, y
    End If
    If tglRemoveShapeFromLayer Then
        RemovePolygonContaining x, y
    End If
End Sub


Sub RemovePolygonContaining(x As Long, y As Long)
Dim sf As MapWinGIS.Shapefile
Dim lIndex As Long
Dim ptX As Double
Dim ptY As Double
Dim shp As MapWinGIS.Shape
Dim i As Long

    On Error Resume Next
    Set sf = axMap.Object.GetObject(cboZoneLayer.Value)
    If Err.number <> 0 Then
        MsgBox "A zone must be selected for editing"
    Else
        On Error GoTo errHandle
                    
        axMap.PixelToProj CDbl(x), CDbl(y), ptX, ptY
        lIndex = -1
        For i = 0 To sf.NumShapes - 1
            Set shp = sf.Shape(i)
            If sf.PointInShape(i, ptX, ptY) Then
                lIndex = i
            End If
        Next i
                    
        If lIndex <> -1 Then
            sf.StartEditingShapes True
            sf.EditDeleteShape (lIndex)
            sf.StopEditingShapes
            axMap.Redraw
        End If
    
    End If
errExit:
    Set shp = Nothing
    Set sf = Nothing
    Exit Sub
    
errHandle:
    MsgBox err.Number & err.description
    Resume errExit
End Sub





Sub EnterPolygonPoints(x As Long, y As Long)
Dim dblClosingDistance As Double
    
    ' for all points except the first one, 
    ' check the closing distance to the beginning

    '  bogus value to use for first-point comparison

    dblClosingDistance = 100001 
    If nPoints = 0 Then ' start a new drawing layer
        hndlDrawing = axMap.NewDrawing _
(MapWinGIS.tkDrawReferenceList.dlScreenReferencedList)
        axMap.DrawCircle x, y, 5, RGB(255, 0, 0), False
    Else
        dblClosingDistance = Sqr((x - Points(0, 0)) ^ 2 + (y - Points(1, 0)) ^ 2)
    End If
    
    If dblClosingDistance > 5 Then ' not closed with beginning
        ' draw a line to this point
        If dblClosingDistance < 100000 Then
            axMap.DrawLine lastX, lastY, x, y, 2, RGB(0, 0, 255)
        End If
        ' preserve this point for rubberbanding
        lastX = x
        lastY = y
        
        ReDim Preserve Points(2, nPoints)
        Points(0, nPoints) = x
        Points(1, nPoints) = y
        nPoints = nPoints + 1
    Else ' preserve this drawing in the shapefile
        tglAddShape = False
        tglAddShape_Click 
        tglAddShape = True
        tglAddShape_Click
               
    End If

End Sub





Private Sub tglAddShape_Click()
' user interface -- designate when to enter a shape

    axMap.SendMouseUp = tglAddShape
    tglRemoveShapeFromLayer = False
    
    If tglAddShape Then ' adding a shape

' disable the zooming or panning functions

        axMap.CursorMode = cmSelection 
        nPoints = 0
        ReDim Points(2, 0)
    Else
        tglCursor_Click ' revert to previous cursor behaviour for zoome or pan
        If nPoints >= 3 Then  ' a polygon must have at least three points
            ConvertPointsToRealShape
        End If
        axMap.ClearDrawing hndlDrawing
    End If
        
End Sub




Sub ConvertPointsToRealShape()
Dim sf As MapWinGIS.Shapefile
Dim shp As New MapWinGIS.Shape
Dim pt As New MapWinGIS.Point
Dim success As Boolean
Dim i As Integer
Dim lShapeHandle As Long
Dim ptX As Double
Dim ptY As Double
    On Error GoTo errHandle
    
    success = shp.Create(SHP_POLYGON)
    
    For i = 0 To nPoints - 1
        Set pt = New MapWinGIS.Point
        axMap.PixelToProj Points(0, i), Points(1, i), ptX, ptY
        pt.x = ptX
        pt.y = ptY
        shp.InsertPoint pt, CLng(i)
    Next i
    
    Set sf = axMap.Object.GetObject(cboZoneLayer.Value)
    sf.StartEditingShapes True
    lShapeHandle = sf.NumShapes
    success = sf.EditInsertShape(shp, lShapeHandle)
    sf.StopEditingShapes
errExit:
    Set pt = Nothing
    Set shp = Nothing
    Set sf = Nothing
    axMap.Redraw
    Exit Sub
    
errHandle:
    MsgBox ErrString
    Resume errExit
End Sub




Private Sub tglCursor_Click()
    If tglCursor Then
        axMap.CursorMode = cmPan
    Else
        axMap.CursorMode = cmZoomIn
    End If
End Sub




Private Sub tglRemoveShapeFromLayer_Click()
    axMap.SendMouseUp = tglRemoveShapeFromLayer
    tglAddShape = False
    If tglRemoveShapeFromLayer = True Then
        If vbYes = MsgBox _
            ("Clicking on a zone will delete it " & _
            "from the map without further warning." & vbCrLf & vbCrLf & _
            "Do you want to proceed?", _
            vbYesNo + vbCritical, "Delete zone from map") Then
        axMap.CursorMode = cmSelection
        Else
            tglRemoveShapeFromLayer = False
        End If
    Else
        tglCursor_Click
    End If
End Sub

Retrieved from "http://mapwindow.org/wiki/index.php/SampleCode-MSAccess2003-DigitizingPolygons"

This page has been accessed 3,534 times. This page was last modified on 24 February 2006, at 03:00.