main.frm

这个是grs源程序,mo在图象显示上很好,所以大家一定要下载

  For i = 1 To collGtextStrings.count
    mapDisp.DrawText collGtextStrings(i), collGtextPoints(i), symGtext
  Next
End If

Select Case BarState
Case "Graphics"
    mapDisp.MousePointer = moCross
Case "Spatial Select"
    mapDisp.MousePointer = moArrow
Case "Zoom in"
    mapDisp.MousePointer = moZoomIn
Case "Zoom out"
    mapDisp.MousePointer = moZoomOut
Case "Pan"
    mapDisp.MousePointer = moPan
Case "Identify"
    mapDisp.MousePointer = moIdentify
Case Else
    mapDisp.MousePointer = moDefault
End Select

End Sub

Private Sub mapdisp_BeforeLayerDraw(ByVal Index As Integer, ByVal hDC As StdOle.OLE_HANDLE)

  mapDisp.MousePointer = moHourglass
  'Update scale in status bar
  If Index = mapDisp.Layers.count - 1 Then
    updateScale
  End If
End Sub

Private Sub mapDisp_DragFiles(ByVal fileNames As Object, ByVal x As Single, ByVal y As Single, ByVal state As Integer, dropValid As Boolean)
  If fileNames.count > 0 Then
    dropValid = True
  End If
End Sub

Private Sub mapDisp_DropFiles(ByVal fileNames As Object, ByVal x As Single, ByVal y As Single)
  Dim dcx As New mapobjects2.DataConnection
  Dim shpfile As Variant
  Dim i As Integer
  Dim ml As mapobjects2.MapLayer
  shpfile = (Dir(fileNames.Item(0), vbDirectory))
  shpfile = CStr(Left(shpfile, Len(shpfile) - 4))

  dcx.Database = Left(fileNames.Item(0), Len(fileNames.Item(0)) - Len(shpfile) - 5)
  If dcx.Connect Then
    For i = 0 To fileNames.count - 1
      Set ml = New mapobjects2.MapLayer
      shpfile = Dir(fileNames.Item(i), vbDirectory)
      shpfile = CStr(Left(shpfile, Len(shpfile) - 4))
      Set ml.GeoDataset = dcx.FindGeoDataset(shpfile)
      mapDisp.Layers.Add ml
      legMapDisp.LoadLegend
    Next i
    
    'prepare collections to sort layers
    Dim ptcoll As New Collection
    Dim linecoll As New Collection
    Dim polycoll As New Collection
    Dim imagecoll As New Collection
    
    For i = 0 To mapDisp.Layers.count - 1
      If mapDisp.Layers(i).LayerType = moImageLayer Then
          imagecoll.Add mapDisp.Layers(i)
      ElseIf mapDisp.Layers(i).LayerType = moMapLayer Then
        Select Case mapDisp.Layers(i).shapeType
          Case moShapeTypePoint
            ptcoll.Add mapDisp.Layers(i)
          Case moShapeTypeLine
            linecoll.Add mapDisp.Layers(i)
          Case moShapeTypePolygon
            polycoll.Add mapDisp.Layers(i)
        End Select
      End If
    Next i
    mapDisp.Layers.Clear

    'add all the layers back in sorted by type
    Dim p As mapobjects2.MapLayer
    For Each p In polycoll
      mapDisp.Layers.Add p
    Next p
    
    Dim l As mapobjects2.MapLayer
    For Each l In linecoll
      mapDisp.Layers.Add l
    Next l
    
    For Each p In ptcoll
      mapDisp.Layers.Add p
    Next p
  
    Dim im As mapobjects2.ImageLayer
    For Each im In imagecoll
      mapDisp.Layers.Add im
    Next im
    
  End If
  mapDisp.Extent = mapDisp.FullExtent
  mapDisp.Refresh
    
End Sub

Private Sub mapDisp_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  
  'This procedure invokes the active map tool; zoom in, zoom out, pan, or other.
  Dim curRectangle As Rectangle
  
  'Zoom in button was pushed
  If barDisplay.Buttons("Zoom in").Value = 1 Then
    Set curRectangle = mapDisp.TrackRectangle
    Set mapDisp.Extent = curRectangle
    
  'Zoom out button was pushed
  ElseIf barDisplay.Buttons("Zoom out").Value = 1 Then
    Dim Loc As New Point
    Set Loc = mapDisp.ToMapPoint(x, y)
    'We calculate the full width and height. Adding and substracting
    'the full values from Loc has the effect of zooming out by a factor of 2.
    Dim MapWidth As Double, MapHeight As Double
    Set curRectangle = mapDisp.Extent
    MapWidth = mapDisp.Extent.Width
    MapHeight = mapDisp.Extent.Height
    curRectangle.Right = Loc.x + MapWidth
    curRectangle.Left = Loc.x - MapWidth
    curRectangle.Top = Loc.y + MapHeight
    curRectangle.Bottom = Loc.y - MapHeight
    Set mapDisp.Extent = curRectangle
            
  'Pan button
  ElseIf barDisplay.Buttons("Pan").Value = 1 Then
    mapDisp.Pan
    
  'Identify button
  ElseIf barDisplay.Buttons("Identify").Value = 1 Then
    Call frmIdentify.Identify(x, y)
    frmIdentify.ZOrder 0
    
  'Spatial selection of features
  ElseIf barDisplay.Buttons("Spatial Select").Value = 1 Then
    Call frmSpatial.SelectFeatures(Button, Shift, x, y)
    frmSpatial.ZOrder 0
  End If
  
  'Add and select shape features
  If barGraphics.Visible Then
    Dim tl As mapobjects2.TrackingLayer
    Set tl = mapDisp.TrackingLayer
    tl.SymbolCount = 3
    
    Select Case True
      Case barGraphics.Buttons("Add text").Value = 1
        Dim strGText As String
        Dim ptGText As mapobjects2.Point
        strGText = InputBox("Enter text label")
        Set ptGText = mapDisp.ToMapPoint(x, y)
        collGtextStrings.Add strGText
        collGtextPoints.Add ptGText
      Case barGraphics.Buttons("Add point").Value = 1
        Dim ptGraphic As mapobjects2.Point
        Set ptGraphic = mapDisp.ToMapPoint(x, y)
        tl.AddEvent ptGraphic, 0
      Case barGraphics.Buttons("Add line").Value = 1
        Dim lnGraphic As mapobjects2.Line
        Set lnGraphic = mapDisp.TrackLine
        tl.AddEvent lnGraphic, 1
      Case barGraphics.Buttons("Add rectangle").Value = 1
        Dim rectGraphic As mapobjects2.Rectangle
        Set rectGraphic = mapDisp.TrackRectangle
        tl.AddEvent rectGraphic, 2
      Case barGraphics.Buttons("Add polygon").Value = 1
        Dim polyGraphic As mapobjects2.Polygon
        Set polyGraphic = mapDisp.TrackPolygon
        tl.AddEvent polyGraphic, 2
      Case barGraphics.Buttons("Add ellipse").Value = 1
        Dim cirGraphic As mapobjects2.Ellipse
        Set cirGraphic = mapDisp.TrackCircle
        tl.AddEvent cirGraphic, 2
    End Select
    
    mapDisp.TrackingLayer.Refresh True
  End If
  
End Sub

Private Sub mapDisp_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  
  'This procedure updates the coordinate display in the status bar.
  Dim curPoint As Point
  Dim curX As Double
  Dim curY As Double
  'Convert screen coordinates to map coordinates
  Set curPoint = mapDisp.ToMapPoint(x, y)
  curX = curPoint.x
  curY = curPoint.y
  'If map coordinates are large, suppress digits to right of decimal place.
  Dim cX As String, cy As String
  cX = curX
  cy = curY
  cX = Left(cX, InStr(cX, ".") + 2)
  cy = Left(cy, InStr(cy, ".") + 2)
  sbrStatus.Panels(2).text = "X:" & cX & " Y:" & cy

  'Now trigger the MapTip's mousemove...
  If chkTipLayer.Value = 1 And cboTipLayer.ListCount > 0 Then
    m_mapTip.MouseMove x, y
  End If
  
End Sub
'
'******************************************************************************************************************************************
'   MENUS
'******************************************************************************************************************************************
'


Private Sub mnuClearGraphics_Click()

mapDisp.TrackingLayer.ClearEvents
Set collGtextStrings = New VBA.Collection
Set collGtextPoints = New VBA.Collection
mapDisp.TrackingLayer.Refresh True

End Sub

Private Sub mnuEdit_Find_Click()

  Call doTask("Find")

End Sub


Private Sub mnuFile_Exit_Click()

  End

End Sub

Private Sub mnuView_MapProperties_Click()

  Call doTask("Map Properties")

End Sub

Private Sub mnuFile_Print_Click()

  Call doTask("Print")

End Sub

Private Sub mnuHelp_About_Click()

  Call doTask("About")

End Sub

Private Sub mnuHelp_Summary_Click()

  Call doTask("Summary")

End Sub

Private Sub mnuView_FullExtent_Click()

  Call doTask("Full extent")

End Sub

Private Sub mnuView_Graphics_Click()

  barDisplay.Buttons("Graphics").Value = 1
  Call doTask("Graphics")

End Sub

Private Sub mnuView_Identify_Click()

  barDisplay.Buttons("Identify").Value = 1
  Call doTask("Identify")

End Sub

Private Sub mnuView_Pan_Click()

  barDisplay.Buttons("Pan").Value = 1
  Call doTask("Pan")

End Sub

Private Sub mnuView_SpatialSelect_Click()

  barDisplay.Buttons("Spatial Select").Value = 1
  Call doTask("Spatial Select")

End Sub

Private Sub mnuView_ZoomIn_Click()
  
  barDisplay.Buttons("Zoom in").Value = 1
  Call doTask("Zoom in")

End Sub

Private Sub mnuView_ZoomOut_Click()

  barDisplay.Buttons("Zoom out").Value = 1
  Call doTask("Zoom out")

End Sub

Private Sub mnuAddSDELayer_Click()

  Load frmConnectSDE
  frmConnectSDE.Show vbModal
  'Update the MapTip layer and field values in the combo boxes.
  If frmMain.chkTipLayer.Value = 1 Then refreshMapTips

End Sub

Private Sub mnuAddLayer_Click()

  Call AddFile
  'Update the MapTip layer and field values in the combo boxes.
  If chkTipLayer.Value = 1 Then refreshMapTips

End Sub

Private Sub mnuLegendEditor_Click()
  
  Dim Index As Integer
  Index = legMapDisp.getActiveLayer
  
  If Index = -1 Then
    MsgBox "There is no active layer.", vbCritical, "Stop"
    Exit Sub
  End If
  
  Set g_ActiveLayer = mapDisp.Layers(Index)
  
  If mapDisp.Layers(Index).LayerType = moImageLayer Then
    MsgBox "Sorry, you cannot set properties for an image layer.", _
           vbCritical, "Stop"
    Exit Sub
  End If

  'Invoke property sheet for new layer.
  frmLayerSymbol.Show vbModal

End Sub

Private Sub mnuRemoveAllLayers_Click()

  'Clear the Layers collection
  mapDisp.Layers.Clear
  'Clear the Main form's scale status area
  Call updateScale
  legMapDisp.LoadLegend
  frmMain.Refresh
  'Update the MapTip layer and field values in the combo boxes.
  If frmMain.chkTipLayer.Value = 1 Then refreshMapTips

End Sub

Private Sub mnuRemoveLayer_Click()
  
  'Extract the index of the selected item and
  'remove it from the layers collection of the map.
  Dim Index As Long
  Index = legMapDisp.getActiveLayer
  If Index <> -1 Then
    mapDisp.Layers.Remove Index
    legMapDisp.LoadLegend  'Refresh legend
   Else
    MsgBox "The map has no active layer.", vbCritical, "Stop"
    Exit Sub
  End If
  
  'Update the MapTip layer and field values in the combo boxes.
  If frmMain.chkTipLayer.Value = 1 Then refreshMapTips

End Sub
'
'******************************************************************************************************************************************
'   TOOLTIP
'******************************************************************************************************************************************
'
Private Sub tmrMapTip_Timer()
  
  m_mapTip.Timer

End Sub

Public Sub updateMapTipLayer()
    
  m_mapTip.SetLayer mapDisp.Layers(cboTipLayer.text), _
                      cboTipField.text

End Sub

Public Sub updateTipField()

  cboTipField.Clear

  'If we've selected tips on an image layer, set check box to false cuz we can't display
  'tips for images.
  If cboTipLayer = "" Then
    chkTipLayer.Value = 0
    Exit Sub
  End If

  'Now populate the listbox for the selected field
  Dim tb As mapobjects2.TableDesc
  Set tb = mapDisp.Layers(frmMain.cboTipLayer.text).Records.TableDesc
  Dim fType As String, itemToSet As String
  Dim numFields As Integer
  numFields = tb.FieldCount
  Dim firstString As Boolean
  firstString = True
  
  Dim i As Integer
  For i = 0 To numFields - 1
    fType = tb.FieldType(i)
    If fType = moString Or fType = moLong Or fType = moDouble Then
      cboTipField.AddItem tb.FieldName(i)
      If firstString = True And fType = moString Then
        firstString = False
        itemToSet = tb.FieldName(i)
      End If
    End If
  Next i
  
  'Make the first string field the default field
  If itemToSet <> "" Then
    frmMain.cboTipField.text = itemToSet
  Else
    frmMain.cboTipField.text = cboTipField.List(0)
  End If
  
  'Update the layer and field in MapTip class
  m_mapTip.SetLayer mapDisp.Layers(cboTipLayer.text), cboTipField.text

End Sub

Public Sub refreshMapTips()

  'This procedure rebuilds the combo boxes in the tray panels
  'on the bottom of the moView main form.
    
  'Clear the layer and field combo boxes
  cboTipLayer.Clear
  cboTipField.Clear

  'Get the number of layers in the Layers collection.
  Dim numLayers As Integer
  numLayers = mapDisp.Layers.count
  
  Dim curLayer As Object       'declared as object because it might be MapLayer or ImageLayer