projector.frm

MO VB地理信息系统程序设计

  Form2.Refresh
  
  'Fill each of the strings objects with the codes for the predefined Coordinate systems
  StrsPCS.PopulateWithProjectedCoordSys
  StrsGCS.PopulateWithGeographicCoordSys
  
  'Enable / disable the appropriate buttons etc
  OptCS(0).Value = True
  Map1.Enabled = False
  CboCS.Enabled = False
  CmdFullExt.Enabled = False
  CmdSetMapCS.Enabled = False
  CmdSetLyrCS.Enabled = False
  CmdExport.Enabled = False
  CmdReadPRJ.Enabled = False
  OptCS(0).Enabled = False
  OptCS(1).Enabled = False
  OptCS(2).Enabled = False

  'Kill the splash form
  Unload Form2
End Sub
  
Private Sub CmdAddLyr_Click()
  Dim DC As New MapObjects2.DataConnection
  Dim gds As MapObjects2.GeoDataset
  Dim FName As String
  
  'Set up dailog box to prompt user to load a shapefile
  CommonDialog1.Filter = "ESRI Shapefiles (*.shp)|*.shp|ArcINFO Coverages (*.adf)| aat.adf;pat.adf"
  'Set cancel error so that if cancel is used then we can trap it an exit
  CommonDialog1.CancelError = True
  On Error GoTo ErrorTrap
  CommonDialog1.ShowOpen
  If Len(CommonDialog1.filename) = 0 Then Exit Sub
  
     
  If Right(CommonDialog1.filename, 3) = "adf" Then
      addCoverage CurDir, CommonDialog1.FileTitle
  Else
      'Set up the DataConnection
      DC.Database = CurDir
      If Not DC.Connect Then Exit Sub
    
      'Get the dialog's returned filename
      FName = Left(CommonDialog1.FileTitle, Len(CommonDialog1.FileTitle) - 4)
      
      Set gds = DC.FindGeoDataset(FName)
      If gds Is Nothing Then Exit Sub
       
      Set ShpLayer.GeoDataset = gds
  End If
  
  'Check if any coordsys info has been read from the disk ie was a PRJ file read in?
  'If so then let the user set the Map's coordinate system
  If Not ShpLayer.CoordinateSystem Is Nothing Then
    CmdSetMapCS.Enabled = True
    CmdExport.Enabled = True

    ReportLyrCS ShpLayer.CoordinateSystem
  Else ' otherwise tell the user that the layer did not come with any Coordsys meta data
    MsgBox "The layer you have added has no associated coordinate system information - this should be set manually before continuing.", vbInformation
    CmdSetLyrCS.Enabled = True
  End If
  
  'Add the new layer
  Map1.Layers.Add ShpLayer
  Map1.Layers.MoveToBottom 0
  
  'Enable the controls allowing the user to specify the map's coordinate system
  Map1.Enabled = True
  OptCS(0).Enabled = True
  OptCS(1).Enabled = True
  CboCS.Enabled = True
  CmdFullExt.Enabled = True
  CmdReadPRJ.Enabled = True
  'Disable the AddLayer button (one layer at a time)
  CmdAddLyr.Enabled = False
  
  Exit Sub
  
ErrorTrap:
  If Err.Number <> 32755 Then 'Error is something other than Cancel
    MsgBox Err.Description, vbCritical
  End If
  
  Exit Sub
  
End Sub


Private Sub Map1_DblClick()
   Dim myRect As MapObjects2.Rectangle
   
   Set myRect = Map1.Extent
   myRect.ScaleRectangle 2
   Map1.Extent = myRect
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button = 1 Then 'Zoom IN
    Map1.Extent = Map1.TrackRectangle
  Else
    Dim SrchPt As MapObjects2.Point
    Dim RecsFnd As MapObjects2.Recordset
        
    'Get the user's point in the units of the Map's coordinate system
    Set SrchPt = Map1.ToMapPoint(X, Y)
    

    'Check the shape type of the layer
    'If it is a Polygon layer then we can use point-in-poly
    'Otherwise we have to use a buffer and search with a tolerance
    'NB we assume if the Map's coordsys is set the the Layer's must also be set
    If ShpLayer.shapeType = moShapeTypePolygon Then 'POLYGON Shapefile
      'Check whether the Map has a coordsys set - if so we'll have to transform the search shape
      If Not Map1.CoordinateSystem Is Nothing Then
        'Transform the search shape from the coordsys of the map to that of the maplayer
        Set SrchPt = ShpLayer.CoordinateSystem.Transform(Map1.CoordinateSystem, SrchPt)
      End If
      'Find all of the records which intersect the point
      Set RecsFnd = ShpLayer.SearchShape(SrchPt, moAreaIntersect, "")
    Else 'POINT, MULTIPOINT or LINE Shapefile
      Dim SrchShp As MapObjects2.Polygon
      Dim Tol As Double
      
      'Set up a tolerance (in control units) to use for searching
      Tol = Map1.ToMapDistance(40) ' Convert the tolerance to be in map units
      Set SrchShp = SrchPt.Buffer(Tol) 'Create a polygon based upon a buffer of the searchshape
      
      'Check whether the Map has a coordsys set - if so we'll have to transform the search shape
      If Not Map1.CoordinateSystem Is Nothing Then
        'Transform the search shape from the coordsys of the map to that of the maplayer
        Set SrchShp = ShpLayer.CoordinateSystem.Transform(Map1.CoordinateSystem, SrchShp)
      End If
      
      'Find all of the records which intersect the polygon
      Set RecsFnd = ShpLayer.SearchShape(SrchShp, moAreaIntersect, "")
      
    End If
     
     
    'Process the results - first checking if we got any records
    If Not RecsFnd.EOF Then
      Dim FndShp As Object
      
      'Loop through all the records getting the shapefield value of each one
      Do While Not RecsFnd.EOF
        Set FndShp = RecsFnd.Fields("Shape").Value
        'Check whether the Map has a coordsys set - if so we'll have to transform the found shape
        If Not Map1.CoordinateSystem Is Nothing Then
          'Transform the found shape from the coordsys of the layer to that of the map
          Set FndShp = Map1.CoordinateSystem.Transform(ShpLayer.CoordinateSystem, FndShp)
        End If
        'Flash the shape!
        Map1.FlashShape FndShp, 3
        RecsFnd.MoveNext
      Loop
    Else 'No records were found - so BEEP!
      Beep
    End If
  End If
End Sub

Private Sub OptCS_Click(Index As Integer)
 Dim I As Integer
 
 CboCS.Clear
 If Index = 0 Then 'PCS has been selected so fill the combo box with those strings
     For I = 0 To StrsPCS.Count - 1
       CboCS.AddItem (StrsPCS.Item(I))
     Next I
     CboCS.ListIndex = 0
 ElseIf Index = 1 Then 'GCS has been selected so fill the combo box with those strings
     For I = 0 To StrsGCS.Count - 1
       CboCS.AddItem (StrsGCS.Item(I))
     Next I
     CboCS.ListIndex = 0
 ElseIf Index = 2 Then 'CS from File has been selected
    CboCS.Text = "Custom: " & CSfile.Name
 End If
 
End Sub

Function stripProj(theProjection As String) As Variant
'Gets the integer value (within square brackets) for a PCS or GCS out of its description string

 
  Dim openB As Integer
  'Get position of open bracket
  openB = InStr(theProjection, "[")
  'Get the string
  stripProj = Left(Right(theProjection, Len(theProjection) - openB), Len(theProjection) - openB - 1)
End Function

Public Sub ReportLyrCS(LyrCS As Object)
  Dim strCSType As String

    If LyrCS.IsProjected Then
      strCSType = "Projected Coordinate System" & vbNewLine & "Projection: " & LyrCS.Projection.Name
      Dim ParamStr As New MapObjects2.Strings
      Dim I As Integer
      
      ParamStr.PopulateWithParameters (LyrCS.Projection.Type)
      
      
      LabCSLyr.Caption = "Layer CoordSys:" & vbNewLine & strCSType & vbNewLine & "Name: " & LyrCS.Name & vbNewLine & "Unit: " & LyrCS.Unit.Name & vbNewLine & "Datum: " & LyrCS.GeoCoordSys.Datum.Name & vbNewLine & "Speroid: " & LyrCS.GeoCoordSys.Datum.Spheroid.Name
      For I = 0 To ParamStr.Count - 1
        LabCSLyr.Caption = LabCSLyr.Caption & vbNewLine & ParamStr.Item(I) & ": " & LyrCS.GetParameter(stripProj(ParamStr.Item(I)))
      Next I


    Else
      strCSType = "Geographic Coordinate System"
      LabCSLyr.Caption = "Layer CoordSys:" & vbNewLine & strCSType & "Name: " & LyrCS.Name & vbNewLine & "Type: " & LyrCS.Type
    End If

End Sub

Public Sub ReportMapCS(MapCS As Object)
  'Report the Map's CoordSys onto the form
  Dim strCSType As String

    If MapCS.IsProjected Then
      strCSType = "Projected Coordinate System" & vbNewLine & "Projection: " & MapCS.Projection.Name
      Dim ParamStr As New MapObjects2.Strings
      Dim I As Integer
      
      ParamStr.PopulateWithParameters (MapCS.Projection.Type)
      
      'Explicitly add gfalse E & N and Origin of lat & lon
      ParamStr.Add ("moParm_FalseEasting[3082]")
      ParamStr.Add ("moParm_FalseNorthing[3083]")
      ParamStr.Add ("moParm_OriginLongitude[3080]")
      ParamStr.Add ("moParm_OriginLatitude[3081]")
      
      LabCSMap.Caption = "Map CoordSys:" & vbNewLine & strCSType & vbNewLine & "Name: " & MapCS.Name & vbNewLine & "Unit: " & MapCS.Unit.Name & vbNewLine & "Datum: " & MapCS.GeoCoordSys.Datum.Name & vbNewLine & "Speroid: " & MapCS.GeoCoordSys.Datum.Spheroid.Name
      For I = 0 To ParamStr.Count - 1
        LabCSMap.Caption = LabCSMap.Caption & vbNewLine & ParamStr.Item(I) & ": " & MapCS.GetParameter(stripProj(ParamStr.Item(I)))
      Next I

    Else
      strCSType = "Geographic Coordinate System"
      LabCSMap.Caption = "Map CoordSys:" & vbNewLine & strCSType & vbNewLine & "Name: " & MapCS.Name & vbNewLine & "Type: " & MapCS.Type
    End If
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
      ShpLayer.GeoDataset = gSet            'Set GeoDataset property of new MapLayer
      ShpLayer.Name = featAttTable          'Set Name property of new MapLayer
    End If
  Else
    MsgBox dCon.ConnectError, vbCritical, "Connection error"
  End If

End Sub