091813work

gistfile1.txt

Dim ply As MapObjects2.Polygon
Dim rect As MapObjects2.Rectangle
'The DragRect sample implements a locator map that displays the
'current extent of a larger, main map in the same form.
'In addition, when the user clicks in the rectangle of the locator map,
'it can be dragged to a new location, forcing a change to the main map.


Dim g_feedback As DragFeedBack

Sub MapRectToPixels(r As Rectangle, xMin As Integer, yMin As Integer, xMax As Integer, yMax As Integer)
    Dim p As New Point
    Dim xc As Single, yc As Single
    
    p.x = r.Left
    p.y = r.Top
    Map2.FromMapPoint p, xc, yc
    
    xMin = Form1.ScaleX(xc, vbTwips, vbPixels)  ' convert to pixels
    yMin = Form1.ScaleY(yc, vbTwips, vbPixels)  ' convert to pixels

    p.x = r.Right
    p.y = r.Bottom
    Map2.FromMapPoint p, xc, yc
    
    xMax = Form1.ScaleX(xc, vbTwips, vbPixels)  ' convert to pixels
    yMax = Form1.ScaleY(yc, vbTwips, vbPixels)  ' convert to pixels
End Sub

Sub PixelsRectToMap(xMin As Integer, yMin As Integer, xMax As Integer, yMax As Integer, r As Rectangle)
    Dim xc As Single, yc As Single, p As MapObjects2.Point
    
    xc = Form1.ScaleX(xMin, vbPixels, vbTwips) ' convert to twips
    yc = Form1.ScaleY(yMin, vbPixels, vbTwips) ' convert to twips
    Set p = Map2.ToMapPoint(xc, yc)
    r.Left = p.x
    r.Top = p.y
  
    xc = Form1.ScaleX(xMax, vbPixels, vbTwips) ' convert to twips
    yc = Form1.ScaleY(yMax, vbPixels, vbTwips) ' convert to twips
    Set p = Map2.ToMapPoint(xc, yc)
    r.Right = p.x
    r.Bottom = p.y
End Sub


Private Sub Combo1_Click()
    With Combo1
       
        For i = 0 To Map1.Layers.Count - 1
            If Map1.Layers(i).Name = .List(.ListIndex) Then
                Map1.Layers(i).Visible = True
            Else
                Map1.Layers(i).Visible = False
            End If
        Next i
        
        'map2 add visible layer
        With Map1
            For i = 0 To .Layers.Count - 1
                If .Layers(i).Visible = True Then
                    Map2.Layers.Clear
                    Map2.Layers.Add .Layers(i)
                End If
            Next i
        End With
    End With
    
    Map1.Refresh
End Sub

Private Sub exit_Click()
    End
End Sub

Private Sub Form_Load()
    'load map
    Dim lyr As New MapLayer
    Dim dc As New MapObjects2.DataConnection
    
    dc.Database = App.Path & "\data\1988"
    
    If dc.Connect Then
        Set lyr.GeoDataset = dc.FindGeoDataset("1988")
        Map1.Layers.Add lyr
    Else
        MsgBox "Connection failed"
    End If
    
    Set lyr = New MapLayer
    dc.Database = App.Path & "\data\1997"
    
    If dc.Connect Then
        Set lyr.GeoDataset = dc.FindGeoDataset("1997")
        Map1.Layers.Add lyr
    Else
        MsgBox "Connection failed"
    End If
    
    Set lyr = New MapLayer
    dc.Database = App.Path & "\data\2002"
    
    If dc.Connect Then
        Set lyr.GeoDataset = dc.FindGeoDataset("2002")
        Map1.Layers.Add lyr
    Else
        MsgBox "Connection failed"
    End If
    
    Set lyr = New MapLayer
    dc.Database = App.Path & "\data\2005"
    
    If dc.Connect Then
        Set lyr.GeoDataset = dc.FindGeoDataset("2005")
        Map1.Layers.Add lyr
    Else
        MsgBox "Connection failed"
    End If
    
    Set lyr = New MapLayer
    dc.Database = App.Path & "\data\2006"
    
    If dc.Connect Then
        Set lyr.GeoDataset = dc.FindGeoDataset("2006")
        Map1.Layers.Add lyr
    Else
        MsgBox "Connection failed"
    End If
    
    With Map1
        .Layers(0).Visible = False
        .Layers(1).Visible = False
        .Layers(2).Visible = False
        .Layers(3).Visible = False
        .Layers(4).Visible = True
    End With
    
    'map2 add visible layer
    With Map1
        For i = 0 To .Layers.Count - 1
            If .Layers(i).Visible = True Then
                If Map2.Layers.Count = 0 Then
                    Map2.Layers.Add .Layers(i)
                Else
                    Map2.Layers(0) = .Layers(i)
                End If
            End If
        Next i
    End With
    
    
    ' add lyr name to combo1
    For i = 0 To Map1.Layers.Count - 1
        Combo1.AddItem Map1.Layers(i).Name
    Next i
    
    Combo1.ListIndex = Combo1.ListCount - 1
    
    Map1.Refresh
    
    ' drawing
    Dim myTable As New MapObjects2.Table
    
    myTable.Database = "dBASE IV;DATABASE=" & App.Path & "\data"
    myTable.Name = "tdlegend"
    
    Dim recs As New MapObjects2.Recordset
    
    Set recs = myTable.Records
    
    Dim typeCount As Integer
    
    Do While Not recs.EOF
        typeCount = typeCount + 1
        recs.MoveNext
    Loop
    
    Dim myRender As New MapObjects2.ValueMapRenderer
    
    myRender.ValueCount = typeCount
    
    myRender.Field = "myid"
    
    recs.MoveFirst
    
    i = 0
    
    Do While Not recs.EOF
        i = i + 1
        If i < 44 Then
            myRender.Value(i) = recs("myid").ValueAsString
            myRender.Symbol(i).Color = recs("color").Value
            myRender.Symbol(i).Outline = False
        End If
        recs.MoveNext
    Loop
    
    For i = 0 To Map1.Layers.Count - 1
        Set lyr = Map1.Layers(i)
        lyr.AddRelate "myid", myTable, "myid"
        Set lyr.Renderer = myRender
    Next i
    
    recs.MoveFirst
    
    Dim typeName As String
    
    Do While Not recs.EOF
        typeName = recs("type").ValueAsString
        bmpfilename = recs("image").ValueAsString
        ImageList2.ListImages.Add , typeName, LoadPicture(App.Path & "\data\legendbmp\" & bmpfilename & ".bmp")
        recs.MoveNext
    Loop
    
    Set TreeView1.ImageList = ImageList2
    recs.MoveFirst
    Do While Not recs.EOF
        typeName = recs("type").ValueAsString
        TreeView1.Nodes.Add , , typeName, typeName, typeName
        recs.MoveNext
    Loop
    
End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hdc As Stdole.OLE_HANDLE)
    If Not ply Is Nothing Then
        Dim sym As New MapObjects2.Symbol
        sym.Size = 2
        sym.OutlineColor = moRed
        sym.Style = moTransparentFill
        Map1.DrawShape ply, sym
    End If
    
    If Not rect Is Nothing Then
        sym.Size = 2
        sym.OutlineColor = moRed
        sym.Style = moTransparentFill
        Map1.DrawShape rect, sym
    End If
    
     Map2.Refresh
End Sub



Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
redraw:

    Dim r As MapObjects2.Rectangle
    If Toolbar1.Buttons("zoomin").Value = tbrPressed Then
        Map1.Extent = Map1.TrackRectangle
        
    ElseIf Toolbar1.Buttons("zoomout").Value = tbrPressed Then
        Set r = Map1.Extent
        r.ScaleRectangle (1.5)
        Set Map1.Extent = r
        
    ElseIf Toolbar1.Buttons("move").Value = tbrPressed Then
        Map1.Pan
    
    ElseIf Toolbar1.Buttons("find").Value = tbrPressed Then
        Dim lyr As MapLayer
        Dim recs As MapObjects2.Recordset
        Dim GeoPt As MapObjects2.Point
        Dim selectedPoly As MapObjects2.Polygon
        
        Set GeoPt = Map1.ToMapPoint(x, y)
        Debug.Print x, y
        
        With Map1
        For i = 0 To .Layers.Count - 1
            If .Layers(i).Name = Combo1.List(Combo1.ListIndex) Then
                layerIndex = i
            End If
        Next i
        End With
        
        Set lyr = Map1.Layers(layerIndex)
        Set recs = lyr.SearchByDistance(GeoPt, 1, "")
        If recs.Count >= 1 Then
            Set selectedPoly = recs("shape").Value
            Map1.FlashShape selectedPoly, 3
            StatusBar1.Panels(1) = "类型:" & recs("type").ValueAsString
            StatusBar1.Panels(2) = "面积:" & recs("shape").Value.Area
        End If
        
    ElseIf Toolbar1.Buttons("stat").Value = tbrPressed Then
    
        Set ply = Map1.TrackPolygon
        
        With Map1
            For i = 0 To .Layers.Count - 1
                If .Layers(i).Name = Combo1.List(Combo1.ListIndex) Then
                    layerIndex = i
                End If
            Next i
        End With
        
        Set lyr = Map1.Layers(layerIndex)

        Set recs = lyr.SearchShape(ply, moAreaIntersect, "")
        Debug.Print recs.Count
        Map1.Refresh
        
        Dim areaArray() As Double
        Dim typeStrings As New MapObjects2.Strings
        typeStrings.Unique = True
        
        If recs.Count >= 1 Then
            recs.MoveFirst
            Do While Not recs.EOF
                typeStrings.Add recs("type").ValueAsString
                recs.MoveNext
            Loop
            
            ReDim areaArray(typeStrings.Count)
            Dim typeIndex As Integer
            Dim intersectPly As MapObjects2.Polygon
            
            recs.MoveFirst
            Do While Not recs.EOF
                typeIndex = typeStrings.Find(recs("type").ValueAsString)
                Set intersectPly = ply.Intersect(recs("shape").Value)
                If intersectPly Is Nothing Then
                    MsgBox "you draw a wrong polygon, please draw a right one(eg: triangle)"
                    For i = 1 To Toolbar1.Buttons.Count
                        Toolbar1.Buttons(i).Value = tbrUnpressed
                    Next i
                    GoTo redraw
                End If
                
                intersectArea = intersectPly.Area
                areaArray(typeIndex) = areaArray(typeIndex) + intersectArea
                recs.MoveNext
            Loop
            
            ' add data to form2.mschart1
           idx = typeStrings.Count - 1
            ReDim chartArray(idx)
            
            With Form2.MSChart1
                Debug.Print "form2.mschart1.columncount:" & typeStrings.Count
                .RowLabel = "所选区域统计图"
                .ColumnCount = typeStrings.Count
                For typeIndex = 0 To typeStrings.Count - 1
                    .Plot.SeriesCollection(typeIndex + 1).LegendText = "类型 " & i + 1 & ":" & typeStrings(typeIndex) & " " & "面积:" & areaArray(typeIndex) & "平方米"
                    chartArray(typeIndex) = areaArray(typeIndex)
                Next typeIndex
                
                .RowCount = 1
                Debug.Print "Count" & .ColumnCount
                For i = 1 To .ColumnCount
                    With .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel
                       .LocationType = VtChLabelLocationTypeOutside
                       .Component = VtChLabelComponentPercent
                       .PercentFormat = "0%"
                       .VtFont.Size = 10
                    End With
                Next i
                
                Form2.MSChart1.ChartData = chartArray
            End With
            Form2.Show
            
            Map1.Refresh
        End If
        
    ElseIf Toolbar1.Buttons("stat2").Value = tbrPressed Then
        Set rect = Map1.TrackRectangle
        If rect.Width < 200 Then
            MsgBox "please draw a rectangle include multi regions, if you want to find a region, please click 查询 icon"
            For i = 1 To Toolbar1.Buttons.Count
                Toolbar1.Buttons(i).Value = tbrUnpressed
            Next i
            GoTo redraw
        End If
        With Map1
        For i = 0 To .Layers.Count - 1
            If .Layers(i).Name = Combo1.List(Combo1.ListIndex) Then
                layerIndex = i
            End If
        Next i
        End With
        
        Set lyr = Map1.Layers(layerIndex)

        Set recs = lyr.SearchShape(rect, moAreaIntersect, "")
        Debug.Print recs.Count
        Map1.Refresh
        
        typeStrings.Unique = True
        
        If recs.Count >= 1 Then
            recs.MoveFirst
            Do While Not recs.EOF
                typeStrings.Add recs("type").ValueAsString
                recs.MoveNext
            Loop
            
            ReDim areaArray(typeStrings.Count)
            
            recs.MoveFirst
            Do While Not recs.EOF
                typeIndex = typeStrings.Find(recs("type").ValueAsString)
                Set intersectPly = rect.Intersect(recs("shape").Value)
                
                intersectArea = intersectPly.Area
                areaArray(typeIndex) = areaArray(typeIndex) + intersectArea
                recs.MoveNext
            Loop
            
            ' add data to form2.mschart1
            idx = typeStrings.Count - 1
            ReDim chartArray(idx)
            
            With Form2.MSChart1
                Debug.Print "form2.mschart1.columncount:" & typeStrings.Count
                .RowLabel = "所选区域统计图"
                .ColumnCount = typeStrings.Count
                For typeIndex = 0 To typeStrings.Count - 1
                    .Plot.SeriesCollection(typeIndex + 1).LegendText = "类型 " & i + 1 & ":" & typeStrings(typeIndex) & " " & "面积:" & areaArray(typeIndex) & "平方米"
                    chartArray(typeIndex) = areaArray(typeIndex)
                Next typeIndex
                
                .RowCount = 1
                Debug.Print "Count" & .ColumnCount
                For i = 1 To .ColumnCount
                    With .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel
                       .LocationType = VtChLabelLocationTypeOutside
                       .Component = VtChLabelComponentPercent
                       .PercentFormat = "0%"
                       .VtFont.Size = 10
                    End With
                Next i
                
                Form2.MSChart1.ChartData = chartArray
            End With
            Form2.Show
            
            Map1.Refresh
        End If
        
    ElseIf Toolbar1.Buttons("stat3").Value = tbrPressed Then
        Dim myTable As New MapObjects2.Table
        ' make a typeNames for unit form3.mschart1 legend color
        myTable.Database = "dBASE IV;DATABASE=" & App.Path & "\data"
        myTable.Name = "tdlegend"
        
        Set recs = myTable.Records
        Dim typeNames()
        
        typeCount = 0
    
        Do While Not recs.EOF
            typeCount = typeCount + 1
            recs.MoveNext
        Loop
        
        ReDim typeNames(typeCount - 1)
        typeNamesIndex = 0
        
        recs.MoveFirst
        Do While Not recs.EOF
            typeNames(typeNamesIndex) = recs("type").ValueAsString
            Debug.Print "type:" & recs("type").ValueAsString
            typeNamesIndex = typeNamesIndex + 1
            recs.MoveNext
        Loop
        
        'make a form3.mschart legend
        With Form3.MSChart1
            .ColumnCount = UBound(typeNames)
            For i = 0 To UBound(typeNames) - 1
                .Plot.SeriesCollection(i + 1).LegendText = "类型 " & i + 1 & ":" & typeNames(i)
                .Plot.SeriesCollection(i + 1).DataPoints(-1).Brush.FillColor.Set (Rnd * i * 250) Mod 255, (Rnd * i * 250) Mod 255, (Rnd * i * 250) Mod 255
            Next i
        End With
    
        Set ply = Map1.TrackPolygon
        
        ' add data to form3.mschart1
        
        Dim stat3Arr()
        ReDim stat3Arr(Map1.Layers.Count - 1, 45)
        
        For layerIndex = 0 To Map1.Layers.Count - 1
            
            
            Set lyr = Map1.Layers(layerIndex)

            Set recs = lyr.SearchShape(ply, moAreaIntersect, "")
            Map1.Refresh
            
            recs.MoveFirst
            If recs.Count >= 1 Then
                Do While Not recs.EOF
                    typeStrings.Add recs("type").ValueAsString
                    recs.MoveNext
                Loop
            
                recs.MoveFirst
                ReDim areaArray(typeStrings.Count)
                
                Do While Not recs.EOF
                    c = c + 1
                    Debug.Print "count is:" & c
                    typeIndex = typeStrings.Find(recs("type").ValueAsString)
                    Debug.Print "shape type:" & recs("shape").Name
                  
                    Set intersectPly = ply.Intersect(recs("shape").Value)
                    If intersectPly Is Nothing Then
                    MsgBox "you must draw a rectangle, not a point, please drag mouse, but not click it"
                    For i = 1 To Toolbar1.Buttons.Count
                        Toolbar1.Buttons(i).Value = tbrUnpressed
                    Next i
                        GoTo redraw
                    End If
                    intersectArea = intersectPly.Area
                    Debug.Print "intersectarea:" & intersectPly.Area
                    areaArray(typeIndex) = areaArray(typeIndex) + intersectArea
                    recs.MoveNext
                Loop
                 
                 
                typeStrings.Unique = True
                
                recs.MoveFirst
                Do While Not recs.EOF
                    typeStrings.Add recs("type").ValueAsString
                    recs.MoveNext
                Loop
                
                stat3Arr(layerIndex, 0) = "年份:" & Map1.Layers(layerIndex).Name
                
                For typeIndex = 0 To typeStrings.Count - 1
                    For i = 0 To UBound(typeNames) - 1
                        Debug.Print "typename:" & typeNames(i)
                        If typeNames(i) = typeStrings(typeIndex) Then
                            Debug.Print "typename:" & typeNames(i)
                            stat3Arr(layerIndex, i + 1) = areaArray(typeIndex)
                        End If
                    Next i
                Next typeIndex
            End If
            
        Next layerIndex
    
        Form3.MSChart1.ChartData = stat3Arr
        
        Form3.Show
        
    ElseIf Toolbar1.Buttons("full_extent").Value = tbrPressed Then
        Map1.Extent = Map1.FullExtent
    End If
End Sub

'Public Function make_chart(rect, layerIndex, chartArray)
'
'
'    Set lyr = Map1.Layers(layerIndex)
'
'    Set recs = lyr.SearchShape(rect, moAreaIntersect, "")
'    Debug.Print recs.Count
'    Map1.Refresh
'
'    Dim typeStrings As New MapObjects2.Strings
'    typeStrings.Unique = True
'
'    If recs.Count >= 1 Then
'        recs.MoveFirst
'        Do While Not recs.EOF
'            typeStrings.Add recs("type").ValueAsString
'            recs.MoveNext
'        Loop
'
'        ReDim areaArray(typeStrings.Count)
'
'        recs.MoveFirst
'        Do While Not recs.EOF
'            typeIndex = typeStrings.Find(recs("type").ValueAsString)
'            Set intersectPly = rect.Intersect(recs("shape").Value)
'            intersectArea = intersectPly.Area
'            areaArray(typeIndex) = areaArray(typeIndex) + intersectArea
'            recs.MoveNext
'        Loop
'
'        ' add data to form2.mschart1
'        idx = typeStrings.Count - 1
'
'
'        For typeIndex = 0 To typeStrings.Count - 1
'            chartArray(typeIndex, 0) = typeStrings(typeIndex)
'            chartArray(typeIndex, layerIndex + 1) = areaArray(typeIndex)
'        Next typeIndex
'    End If
'End Function

Private Sub Map2_AfterTrackingLayerDraw(ByVal hdc As Stdole.OLE_HANDLE)
  ' draw a rectangle indicating the current extent of Map1
  Dim sym As New Symbol
  sym.OutlineColor = moRed
  sym.Style = moTransparentFill
  Map2.DrawShape Map1.Extent, sym
End Sub

Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  ' convert to map point
  Dim p As Point
  Set p = Map2.ToMapPoint(x, y)
  
  ' if the click happened inside the indicator, then start dragging
  If Map1.Extent.IsPointIn(p) Then
    Set g_feedback = New DragFeedBack
    g_feedback.DragStart Map1.Extent, Map2, x, y
  End If
End Sub

Private Sub Map2_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Not g_feedback Is Nothing Then
    g_feedback.DragMove x, y
  End If
End Sub

Private Sub Map2_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Not g_feedback Is Nothing Then
    Map1.Extent = g_feedback.DragFinish(x, y)
    Set g_feedback = Nothing
  End If
End Sub