form1.frm

基于visual c++和ESRI公司的组建MAP objects 的程序原码,实现对地图目标的编辑和修改

    
    Dim zoomOutRect As MapObjects2.Rectangle
    Dim newRect As MapObjects2.Rectangle
    
     Set zoomOutRect = Map1.TrackRectangle
     Set newRect = Map1.Extent
     ow = zoomOutRect.Width
     
     If (ow > 0) Then
         newRect.ScaleRectangle Map1.Extent.Width / ow
     Else
         newRect.ScaleRectangle 1.5
     End If
     
     Map1.Extent = newRect
         
  ElseIf Toolbar1.Buttons("Pan").Value = 1 Then
    
    Map1.Pan
  
  ElseIf Toolbar1.Buttons("Identify").Value = 1 Then
  
     Call Id(X, Y)
       
  ElseIf Toolbar1.Buttons("Rect").Value = 1 Then
  
     Dim rect As MapObjects2.Rectangle
    
     Set rect = Map1.TrackRectangle
     
     If (rect.Width > 0) Then
         Call selrect(rect)
     End If
  
  End If


End Sub

Public Sub Id(X As Single, Y As Single)

Dim p As MapObjects2.Point
Dim p2 As MapObjects2.Point
Dim recs As MapObjects2.Recordset
Dim crecs As MapObjects2.Recordset
Dim East_West As String
Dim North_South As String

Dim sTol As Double
Dim theName As String
Dim pol As MapObjects2.Polygon

sTol = 10000
sTol = sTol * Map1.Extent.Width / Map1.FullExtent.Width
Set p = Map1.ToMapPoint(X, Y)
'Debug.Print sTol
Set pol = p.Buffer(sTol)

' Now find the feature use searchpoly instead of searchbydistance to avoid missing by Z on a 3D shapefile !!!
'
'Set recs = map1.layers(1).SearchByDistance(p, sTol, "")
Set recs = Map1.Layers(1).SearchShape(pol, moContains, "")

   If (recs.Count > 0) Then
    
    crecsi = closest(recs, p)
    
    recs.MoveFirst
    n = 0
    For i = 0 To crecsi - 1
      n = n + 1
      recs.MoveNext
    Next i
    
    Set p2 = recs.Fields("Shape").Value
    Map1.FlashShape p2, 3
   
    thetype = recs.Fields("Type").ValueAsString
    theName = recs.Fields("Name").ValueAsString
    nl = vbNewLine
    t = vbTab
    Columns.Caption = "Name: " & nl & "Category: " & nl & "Easting: " & nl & "Northing: " & nl & "Height (m): " & nl & "Height (f): "
    values.Caption = theName & nl & thetype & nl & p2.X & nl & p2.Y & nl & p2.Z & nl & p2.Z * m_to_f
    '
    ' Clue text
    East_West = "East"
    North_South = "North"
    If (p2.X) > theBenEasting Then East_West = "West"
    If (p2.Y) > theBenNorthing Then North_South = "South"
    Clue = "Try and identify Ben Nevis ..." & vbNewLine & "Clue: Go " & East_West & " and " & North_South & " of " & theName & "."
    If theName = "Ben Nevis" Then
        Clue = "Found it !"
        identify.Caption = "Ben Nevis"
        identify.Width = 7140
        identify.Height = 5190
        identify.Visible = True
    Else
        identify.Visible = False
    End If
    
   Else
     identify.Visible = False
     values.Caption = ""
     Columns.Caption = "Missed !"
   End If
 
   
End Sub
Public Sub selrect(rect As MapObjects2.Rectangle)

If (sel3d.Value) Then
  rect.floor = floor.Text
  rect.ceiling = ceiling.Text
End If

Set selRecs = Map1.Layers(0).SearchShape(rect, moContaining, "")

Clue.Caption = selRecs.Count & " Mountains selected"

Map1.TrackingLayer.Refresh True
    
End Sub
Function closest(recs As MapObjects2.Recordset, p As MapObjects2.Point) As Integer

  'Find the closest point
  
  Dim d As Double
  Dim prevd As Double
  
  prevd = 9999999
  recs.MoveFirst
  

    j = 0
    For i = 0 To recs.Count - 1
    
        d = p.DistanceTo(recs.Fields("shape").Value)
        'Debug.Print i & " -- " & d & " -- " & recs.Fields("Name").Value
        If d < prevd Then
            j = i
            prevd = d
        End If
        
        recs.MoveNext
        
   Next i
  
  closest = j
          
   'Debug.Print "The closest is " & j
  
End Function

Public Sub Make3D()

Dim recs As New MapObjects2.Recordset
Dim zrecs As New MapObjects2.Recordset
Dim Height As Integer
Dim X As Double
Dim Y As Double
Dim Z As Double
Dim p As MapObjects2.Point

Map1.MousePointer = moHourglass

  'Find layer to read attribute from
  theName = "mountains2d"
  Dim dc As New MapObjects2.DataConnection
  Dim gd As New MapObjects2.GeoDataset
  Dim mlayer As New MapObjects2.MapLayer
  dc.Database = ReturnDataPath("Scotland")
  If Not dc.Connect Then
       MsgBox "Cannot find directory " & dc.Database
       End
  End If
  If dc.FindGeoDataset(theName) Is Nothing Then
      MsgBox "Cannot find file !"
      End
  End If
  Set mlayer.GeoDataset = dc.FindGeoDataset(theName)

 
 ' Create a new Geodataset supporting Z
 '
  zname = "mountains"
  Dim zdc As New MapObjects2.DataConnection
  Dim zgd As New MapObjects2.GeoDataset
  Dim zdesc As New MapObjects2.TableDesc
  Dim zlayer As New MapObjects2.MapLayer
  zdc.Database = ReturnDataPath("Scotland")

  
  If Not zdc.Connect Then
       MsgBox "Cannot find directory " & zdc.Database
       End
  End If

  If Not zdc.FindGeoDataset(zname) Is Nothing Then
      zdc.DeleteGeoDataset zname
      MsgBox "File already exists - deleted !"
  End If
 
  
    
  With zdesc
        ' define three additional fields
        .FieldCount = 2
  
        'set the field names
        .FieldName(0) = "Name"
        .FieldName(1) = "Type"
  
        ' set the type of field
        .FieldType(0) = moString
        .FieldType(1) = moString
  
        ' set the length of a character fields
        .FieldLength(0) = 32
        .FieldLength(1) = 8
    End With
    
   Set zgd = zdc.AddGeoDataset(zname, moPoint, zdesc, True)
   Set zlayer.GeoDataset = zgd
   
'Set up the recordsets
 Set recs = mlayer.Records
 Set zrecs = zlayer.Records

recs.MoveFirst
zrecs.MoveFirst
zrecs.AutoFlush = False

' Iterate through the records and set the Z shape value equal to the height attribute
For i = 1 To recs.Count

   ' Get from the 2D recordset
   With recs
      Set p = .Fields("Shape").Value
      Height = .Fields("Height").Value
      p.Z = Height
      oName = .Fields("Name").ValueAsString
      oType = recs.Fields("Type").ValueAsString
   End With
   
   ' Insert into the 3D recordset
   With zrecs
        .AddNew
        .Fields("Shape").Value = p
        .Fields("Name").Value = oName
        .Fields("Type").Value = oType
        .Update
   End With
   
   ' Get next record from the 2D recordset
   recs.MoveNext
   
Next i

zrecs.AutoFlush = True

MsgBox "The new recordset HasZ = " & zlayer.Records.Count

End Sub

Private Sub NoRen_Click()

If NoRen Then
   Map1.Layers(1).Renderer = Nothing
   PictureLeg.Picture = LoadPicture()
   Map1.Refresh
End If

End Sub



Private Sub sel2d_Click()

floor.Enabled = False
ceiling.Enabled = False
MsgBox "The Select by Rectangle tool will now select all features within a " & vbNewLine & " 2D rectangle , ignoring the Z dimension."

End Sub

Private Sub sel3d_Click()
  floor.Enabled = True
  ceiling.Enabled = True
  MsgBox "The Select by Rectangle tool will now select features within a cube" & vbNewLine & " with a floor property of " & floor & " and a ceiling property of " & ceiling

End Sub

Private Sub lplacer_click()

Map1.Refresh

End Sub
Private Sub make_LPlacer()

Dim lp As New MapObjects2.LabelPlacer
Dim fnt As New StdFont
fnt.Name = "Arial"
fnt.Bold = True

With lp
    Set .DefaultSymbol.Font = fnt
'    Set .DefaultSymbol.Color = moDarkGray
    
    .UseDefault = True
    
    .DefaultSymbol.Height = text_height * Map1.Extent.Height / scale_width 'arbitrary map units
    .Field = "NAME"
    .DrawBackground = True 'draws the line features
End With

Map1.Layers(0).Renderer = lp

End Sub




Private Sub Zren_Click()

Dim Zren As New MapObjects2.ZRenderer
Dim f_to_m As Double

f_to_m = 917 / 3000 ' to convert from Feet to metres (approx)

 With Zren
  
    .BreakCount = 6

    .Break(0) = 1000 * f_to_m
    .Break(1) = 2500 * f_to_m
    .Break(2) = 3000 * f_to_m
    .Break(3) = 3500 * f_to_m
    .Break(4) = 4000 * f_to_m
    .Break(5) = 4500 * f_to_m
    
    .SymbolType = moPointSymbol
    
    For i = 0 To .BreakCount - 1
        .Symbol(i).Color = moGray
        .Symbol(i).Style = moTriangleMarker
        .Symbol(i).Size = (i) * 3
        'Debug.Print i & "  ||  " & .Break(i) & " || " & .Break(i) / f_to_m
    Next i

   End With
  
 Set Map1.Layers(1).Renderer = Zren
 PictureLeg.Picture = LoadPicture(App.Path & "\ZLeg.bmp")
 Map1.Refresh
  
 End Sub

Private Sub Vren_Click()

Dim VRen As New MapObjects2.ValueMapRenderer

 With VRen
  
    .ValueCount = 3
    .Field = "Type"
    .SymbolType = moPointSymbol
    
    .Value(0) = "Munro"
    .Value(1) = "Corbett"
    .Value(2) = "Other"
 
    .SymbolType = moPointSymbol
    .Symbol(0).Color = moBlue
    .Symbol(1).Color = moRed
    .Symbol(2).Color = moGreen

    
    For i = 0 To .ValueCount - 1
        .Symbol(i).Size = 6
        .Symbol(i).Style = moTriangleMarker
    Next i
    
   End With
  
 Set Map1.Layers(1).Renderer = VRen
 PictureLeg.Picture = LoadPicture(App.Path & "\classleg.bmp")
 Map1.Refresh
End Sub


Private Sub Toolbar1_ButtonClick(ByVal Button As ComctlLib.Button)

  '
  '  Change the mouse based upon tool and Enable / disable the selection radio button based on ID button
  '
  If Button.Key = "FullExtent" Then
    Map1.Extent = Map1.FullExtent
  ElseIf Button.Key = "Identify" Then
     Map1.MousePointer = moIdentify
     Call selection_enable(False)
  ElseIf Button.Key = "ZoomIn" Then
     Map1.MousePointer = moZoomIn
     Call selection_enable(False)
  ElseIf Button.Key = "ZoomOut" Then
     Map1.MousePointer = moZoomOut
     Call selection_enable(False)
  ElseIf Button.Key = "Pan" Then
     Map1.MousePointer = moPan
     Call selection_enable(False)
  ElseIf Button.Key = "Rect" Then
     Map1.MousePointer = moCross
    Call selection_enable(True)
  ElseIf Button.Key = "" Then

  End If



End Sub