main.frm

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

  Dim curLayerName As String   'name of current layer
  Dim curLayerType As Integer  'whether MapLayer or ImageLayer type
  Dim curShapeType As Integer  'whether point, line or polygon MapLayer
    
  Dim i As Integer
  For i = 0 To numLayers - 1
    Set curLayer = frmMain.mapDisp.Layers(i)
    curLayerName = curLayer.Name
    
    'Check for and ignore image layers. Do all other layer types.
    curLayerType = curLayer.LayerType
    If curLayerType <> moImageLayer Then
      cboTipLayer.AddItem curLayerName
    End If
  Next i
  
  'Make the first MapLayer the ToolTip layer
  If cboTipLayer.ListCount > 0 Then
    cboTipLayer.ListIndex = 0
    updateTipField
  End If
    
End Sub

Private Sub cboTipField_Click()
  'Update the layer and field in MapTip class
  If cboTipField.text <> "" Then
    m_mapTip.SetLayer frmMain.mapDisp.Layers(cboTipLayer.text), cboTipField.text
  End If
End Sub

Private Sub cboTipLayer_Click()
  updateTipField
End Sub

Private Sub chkTipLayer_Click()
  
  'If no layers, then turn check box off...
  If mapDisp.Layers.count = 0 Then
    chkTipLayer.Value = 0
  
  ElseIf chkTipLayer.Value = 1 Then
    'If on, then make layer and field combo boxes
    'accessible. Then initiate MapTip class.
    Call refreshMapTips
    picMapTip.ZOrder 0
    lblMapTip.ZOrder 0
    
  ElseIf chkTipLayer.Value = 0 Then
    'If off, dim the layer and field combo boxes and
    'disable MapTip.
    cboTipLayer.Clear
    cboTipField.Clear
    picMapTip.ZOrder 1
    lblMapTip.ZOrder 1
  
  End If
End Sub

Private Sub updateMapTip()

  If frmMain.mapDisp.Layers.count = 0 Then
    frmMain.cboTipLayer.Clear
    frmMain.cboTipField.Clear
  Else
    'Set the default layer and field to be the first layer,
    'first field.
    Call frmMain.updateMapTipLayer
  End If

End Sub

'
'******************************************************************************************************************************************
'   ADDING LAYERS TO THE MAP
'******************************************************************************************************************************************
'
Public Sub AddFile()
  'This procedure sets up the common dialog and returns a shapefile or image file
  'for processing into the Layers collection.

  Dim fullFile As String, path As String, tempChar As String, ext As String
  Dim Test As Boolean
  Dim textPos As Long, periodPos As Long
  Dim curPath As String
  
  'Execute common dialog for selecting a file to open.
  
  Dim strShape, strCov, strGRID, strCAD, strVPF, strImage, strMilImage As String
  strShape = "ESRI Shapefiles (*.shp) |*.shp"
  strCov = "ESRI Coverages (*.adf,*.tat,*.pat,*.rat) |aat.adf;pat.adf;nat.adf;txt.adf;*.tat;*.pat;*.rat"
  strGRID = "GRID (hdr.adf) |hdr.adf"
  strCAD = "CAD drawings (*.dwg,*.dxf) | *.dwg;*.dxf"
  strVPF = "VPF (*.pft,*.lat,*.aft,*.tft) |*.pft;*.lat;*.aft;*.tft"
  strImage = "Standard image formats |*.bmp;*.dib;*.tif;*.jpg;*.jff;*.bil;*.bip;*.bsq;*.gis;*.lan;*.rlc;*.sid;*.sun;*.rs;*.ras;*.svf;*.img;*.gif"
  strMilImage = "Military image formats |*.*"
  ' Set CancelError is True
  CommonDialog1.CancelError = True
  On Error GoTo FileOpenCancel
  
  CommonDialog1.Filter = strShape & "|" & strCov & "|" & strGRID & "|" & strCAD & "|" & strVPF & "|" & strImage & "|" & strMilImage
  CommonDialog1.DialogTitle = "Select file for new layer"
  CommonDialog1.ShowOpen
  
  'We have the full path name from the common dialog. Parse out base path.
  If CommonDialog1.FileTitle = "" Then Exit Sub
  fullFile = Trim$(CommonDialog1.filename)
  
  textPos = Len(fullFile)
  Test = False
  'This loop goes backwards through the string, searching for the
  'last back slash. This marks the base path from the returned string.
  Do While Test = False
    textPos = textPos - 1
    tempChar = Mid$(fullFile, textPos, 1)
    If tempChar = "." Then
      periodPos = textPos
    ElseIf tempChar = "\" Or textPos = 0 Then
      Test = True
    End If
  Loop
  
  'Path is the part of the full file string up to the last back slash.
  curPath = Left$(fullFile, textPos - 1)
  
  'Send the file name to the procedures that add the layers...
  Dim filename As String
  Dim pref As String
  filename = CommonDialog1.FileTitle
  
  'Check for file extension.  Add the selected data to the map as a layer
  'according to the syntax of the file format chosen.
  
  ext = LCase(Mid$(fullFile, periodPos + 1, 3))
  
  Select Case ext
    Case "shp"
      Call addShapeFile(curPath, filename)
    Case "pat", "rat", "tat"
      Call addCoverage(curPath, filename)
    Case "adf" 'Could be coverage or grid.  Figure it out.
      If filename = "hdr.adf" Then
        Call addGRID(curPath, filename)
       ElseIf pref = "aat" Or pref = "pat" Or pref = "nat" Or pref = "txt" Then
        Call addCoverage(curPath, filename)
      End If
    Case "dwg", "dxf"
      Call addCAD(curPath, filename)
    Case "aft", "lft", "pft"
      Call addVPF(curPath, filename)
    Case Else
      Call addImage(fullFile)
  End Select
  
  legMapDisp.LoadLegend
  
  Exit Sub
  
FileOpenCancel:
  Exit Sub

End Sub

Private Sub addShapeFile(basepath As String, shpfile As String)
  'This procedure validates and adds a shape file to the Layers collection.
  Dim dCon As New DataConnection
  Dim gSet As GeoDataset
  Dim strShapefileType As String
  
  dCon.Database = basepath                  'Set Database property of DataConnection
  If dCon.Connect Then
    shpfile = GetFirstToken(shpfile, ".")   'Extract suffix of shpfile string
    Set gSet = dCon.FindGeoDataset(shpfile) 'Find shapefile as GeoDataset in DataConnection
    If gSet Is Nothing Then
      MsgBox "Error opening shapefile " & shpfile, vbCritical
      Exit Sub
    Else
    
    If gSet.HasZ Then
      strShapefileType = "[SHAPEFILZ]"
     Else
      strShapefileType = "[SHAPEFILE]"
    End If
    
      Dim newLayer As New MapLayer
      newLayer.GeoDataset = gSet            'Set GeoDataset property of new MapLayer
      newLayer.Name = shpfile               'Set Name property of new MapLayer
      
      'Attach path location to the layer's Tag, also add "[SHAPEFILE]"
      'or "[SHAPEFILZ]" to the Tag so that any subsequent addressmatching
      'or Elevation rendering will be able to tell that this is a
      'shapefile, and if so, if the shapefile supports Z shapes.
      
      newLayer.tag = strShapefileType & dCon.Database & "|" & newLayer.Name
      mapDisp.Layers.Add newLayer   'Add MapLayer to Layers collection
    End If
  Else
    MsgBox ConnectErrorMsg(dCon.ConnectError), vbCritical, "Connection error"
  End If
End Sub

Private Sub addImage(imageFile As String)
  'This procedure validates and adds an image file to the Layers collection
  Dim iLayer As New ImageLayer
  iLayer.File = imageFile
  'If the file is a valid image file, add it and move it to the
  'bottom (last index) of the Layers collection.
  If mapDisp.Layers.Add(iLayer) Then
    mapDisp.Layers.MoveToBottom 0
  Else
    MsgBox "This file, " & imageFile & ", is not a valid image file."
  End If
End Sub

Public Sub addSDElayer(SDEConn As mapobjects2.DataConnection)
  
  If frmConnectSDE.lstLayers.text = "" Then
    Exit Sub
  End If
  
  Dim gSet As GeoDataset
  
  If SDECon.Connect Then
    Set gSet = SDECon.FindGeoDataset(frmConnectSDE.lstLayers.text)
    If gSet Is Nothing Then
      MsgBox "Error opening SDE layer " & frmConnectSDE.lstLayers.text
      Exit Sub
    Else
      Dim newLayer As New mapobjects2.MapLayer
      newLayer.GeoDataset = gSet
      If gSet.HasZ Then
        newLayer.tag = "[SDEZ]"
       Else
        newLayer.tag = "[SDE]"
      End If
      newLayer.Name = frmConnectSDE.lstLayers.text
       
      mapDisp.Layers.Add newLayer
    End If
   Else
    MsgBox "Error# " & SDECon.ExtendedError & ": " & SDECon.ExtendedErrorString, _
           vbCritical, "SDE Connection error"
    MsgBox "Error# " & SDECon.ConnectError & ": " & ConnectErrorMsg(SDECon.ConnectError), _
           vbCritical, "SDE Connection error"
  End If

  legMapDisp.LoadLegend

End Sub

Private Sub addCoverage(basepath As String, filename As String)
  'This procedure validates and adds a coverage feature attribute table
  'to the Layers collection.
  Dim dCon As New DataConnection
  Dim gSet As GeoDataset
  Dim str As String
  
  'For ARC/INFO coverages, the Database property of the DataConnection object
  'needs to be the workspace directory, not the coverage directory, so we need
  'to specify the folder one level above what the common dialog returned...
  Dim textPos As Long, periodPos As Long
  Dim Test As Boolean
  Dim tempChar As String
  Dim fullFile As String, workspace As String, featAttTable As String
  
  fullFile = Trim$(CommonDialog1.filename)

  textPos = Len(basepath)
  Test = False
  
  'This loop goes backwards through the string, searching for the
  'last back slash. This marks the base path from the returned string.
  Do While Test = False
    textPos = textPos - 1
    tempChar = Mid$(basepath, textPos, 1)
    If tempChar = "." Then
      periodPos = textPos
    ElseIf tempChar = "\" Or textPos = 0 Then
      Test = True
    End If
  Loop
  
  'Path is the part of the full file string up to the last back slash.
  workspace = "[arc]" & Left$(basepath, textPos - 1)
  
  'Send the file name to the procedures that add the layers...
  Dim coverage As String
  Dim lenBasePath As Long
  Dim ext As String
  ext = LCase(Right$(filename, 3))
  lenBasePath = Len(basepath)
  coverage = Right$(basepath, lenBasePath - textPos)
  
  If ext = "adf" Then
    featAttTable = coverage & "." & Left$(filename, Len(filename) - 4)
  Else
    featAttTable = coverage & "." & ext & Left$(filename, Len(filename) - 4)
  End If
    
  featAttTable = LCase(featAttTable)
  workspace = LCase(workspace)

  'Also, feature attribute tables are specified by the coverage name followed
  'by the feature attribute table, minus its .adf extension...
  
  dCon.Database = workspace                      'Set Database property of DataConnection
  If dCon.Connect Then
    Set gSet = dCon.FindGeoDataset(featAttTable) 'Find shapefile as GeoDataset in DataConnection
    If gSet Is Nothing Then
      MsgBox "Error opening coverage feature attribute table " & featAttTable
      Exit Sub
    Else
      Dim newLayer As New MapLayer
      newLayer.GeoDataset = gSet            'Set GeoDataset property of new MapLayer
      newLayer.Name = featAttTable          'Set Name property of new MapLayer
      mapDisp.Layers.Add newLayer   'Add MapLayer to Layers collection
    End If
  Else
    MsgBox ConnectErrorMsg(dCon.ConnectError), vbCritical, "Connection error"
  End If

End Sub

Private Sub addGRID(basepath As String, gridfile As String)

Dim ilyr As New mapobjects2.ImageLayer

ilyr.File = basepath & "\" & gridfile
mapDisp.Layers.Add ilyr
'legMapDisp.LoadLegend

End Sub

Private Sub addCAD(basepath As String, cadfile As String)

'Load frmCAD so that the user can choose which
'CAD feature types within the "cadfile" to load
'into the map
frmCAD.cadFileName = cadfile
frmCAD.Show vbModal


Dim dc As New mapobjects2.DataConnection
Dim mlyr As New mapobjects2.MapLayer

If frmCAD.chkCAD(2).Value = 1 Then
  dc.Database = "[CADArea]" & basepath
  If Not dc.Connect Then
    GoTo CADerror
  End If
  Set mlyr.GeoDataset = dc.FindGeoDataset(cadfile)
  mapDisp.Layers.Add mlyr
End If

Set dc = New mapobjects2.DataConnection
Set mlyr = New mapobjects2.MapLayer

If frmCAD.chkCAD(1).Value = 1 Then
  dc.Database = "[CADLine]" & basepath
  If Not dc.Connect Then
    GoTo CADerror
  End If
  Set mlyr.GeoDataset = dc.FindGeoDataset(cadfile)
  mapDisp.Layers.Add mlyr
End If

Set dc = New mapobjects2.DataConnection
Set mlyr = New mapobjects2.MapLayer

If frmCAD.chkCAD(0).Value = 1 Then
  dc.Database = "[CADPoint]" & basepath
  If Not dc.Connect Then
    GoTo CADerror
  End If
  Set mlyr.GeoDataset = dc.FindGeoDataset(cadfile)
  mapDisp.Layers.Add mlyr
End If

Set dc = New mapobjects2.DataConnection
Set mlyr = New mapobjects2.MapLayer

If frmCAD.chkCAD(3).Value = 1 Then
  dc.Database = "[CADText]" & basepath
  If Not dc.Connect Then
    GoTo CADerror
  End If
  Set mlyr.GeoDataset = dc.FindGeoDataset(cadfile)
  mapDisp.Layers.Add mlyr
End If

'Reset map legend and map contents list
'legMapDisp.LoadLegend

Unload frmCAD

Exit Sub

CADerror:
MsgBox "Unable to connect to " & basepath, vbCritical, "Stop"

End Sub

Private Sub addVPF(ByVal basepath As String, ByVal vpffile As String)

Dim dc As New mapobjects2.DataConnection
Dim mlyr As New mapobjects2.MapLayer

dc.Database = "[VPF]" & basepath
If Not dc.Connect Then
  MsgBox "Could not connect to " & basepath
  Exit Sub
End If

Set mlyr.GeoDataset = dc.FindGeoDataset(vpffile)
mapDisp.Layers.Add mlyr

'Reset map legend and map contents list
'legMapDisp.LoadLegend

End Sub

Public Sub updateScale()
  
  'This procedure updates the scale dislay in the status bar.
  Dim mapScreenWidth As Double
  Dim mapExtentWidth As Double
  Dim mapScale As Double
  Dim convFactor As Double
  
  'If there are no layers, we cannot calculate scale
  If mapDisp.Layers.count = 0 Then
    sbrStatus.Panels(1).text = "Scale Unknown"
    Exit Sub
  End If
  
  'If the map units are unknown, we cannot calculate scale
  If strMapUnits = "Unknown" Then
    sbrStatus.Panels(1) = "Map Units Unknown"
    Exit Sub
  End If
  
  Select Case strMapUnits
    Case "Decimal Degrees":  convFactor = INCH2DEGREES
    Case "Meters":           convFactor = INCH2METERS
    Case "Feet":             convFactor = INCH2FEET
  End Select
  
  'Get width of screen and convert twips to inches.
  mapScreenWidth = mapDisp.Width / 1440
  
  'Get map width and convert to inches
  mapExtentWidth = mapDisp.Extent.Width * convFactor
  
  'Calculate scale and update text of status bar
  mapScale = Int(mapExtentWidth / mapScreenWidth)
  sbrStatus.Panels(1).text = "RATIO Scale 1 : " & Format(mapScale, "#,000")
 
End Sub