投影转换.frm

本程序利用vb实现了地理信息系统中空间分析的各种方法

VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "mo20.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form 投影转换 
   Caption         =   "投影转换"
   ClientHeight    =   5535
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   8550
   LinkTopic       =   "Form1"
   ScaleHeight     =   5535
   ScaleWidth      =   8550
   StartUpPosition =   3  'Windows Default
   WindowState     =   2  'Maximized
   Begin VB.Frame Frame1 
      Caption         =   "地理--投影坐标系"
      Height          =   5415
      Left            =   5880
      TabIndex        =   1
      Top             =   0
      Width           =   2415
      Begin VB.CommandButton CmdSetMapCS 
         Caption         =   "投影转换"
         Height          =   375
         Left            =   240
         TabIndex        =   5
         Top             =   2040
         Width           =   2055
      End
      Begin VB.ComboBox CboCS 
         Height          =   315
         Left            =   240
         TabIndex        =   4
         Text            =   "请选择坐标系统"
         Top             =   1560
         Width           =   2055
      End
      Begin VB.OptionButton OptCS 
         Caption         =   "地理坐标系"
         Height          =   255
         Index           =   1
         Left            =   480
         TabIndex        =   3
         Top             =   1080
         Width           =   1455
      End
      Begin VB.OptionButton OptCS 
         Caption         =   "投影坐标系"
         Height          =   255
         Index           =   0
         Left            =   480
         TabIndex        =   2
         Top             =   480
         Width           =   1575
      End
      Begin VB.Label LabCSMap 
         Height          =   2655
         Left            =   120
         TabIndex        =   6
         Top             =   2640
         Width           =   2175
      End
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   120
      Top             =   5520
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MapObjects2.Map Map1 
      Height          =   5415
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   5655
      _Version        =   131072
      _ExtentX        =   9975
      _ExtentY        =   9551
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Contents        =   "投影转换.frx":0000
   End
   Begin VB.Menu mnuaddlayer 
      Caption         =   "添加图层(shp)"
   End
End
Attribute VB_Name = "投影转换"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim StrsGCS As New MapObjects2.Strings
Dim StrsPCS As New MapObjects2.Strings



Private Sub CmdSetMapCS_Click()
        Dim CSMap As Object
        If OptCS.Item(0).Value = True Then
          Set CSMap = New MapObjects2.ProjCoordSys
        Else
          Set CSMap = New MapObjects2.GeoCoordSys
        End If
        CSMap.Type = stripProj(CboCS.Text)
        Map1.CoordinateSystem = CSMap
        ReportMapCS Map1.CoordinateSystem
End Sub

Private Sub Form_Load()
StrsPCS.PopulateWithProjectedCoordSys
StrsGCS.PopulateWithGeographicCoordSys
End Sub

Private Sub Form_Resize()
Map1.Move 100, 200, 投影转换.ScaleWidth - 400 - frame1.Width, 投影转换.ScaleHeight - 300
frame1.Move Map1.Width + 200, 200, 2415, 投影转换.ScaleHeight - 300

End Sub

Private Sub mnuaddlayer_Click()
Dim basepath As String
Dim filename As String
Dim dCon As New DataConnection
Dim gSet As GeoDataset
Dim str As String
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
CommonDialog1.Filter = "esri shapefile(*.shp)|*.shp"
CommonDialog1.ShowOpen
basepath = CurDir
filename = CommonDialog1.FileTitle
   If filename = "" Then
      MsgBox ("you haven't select layer!")
      Exit Sub
   End If
fullFile = Trim$(CommonDialog1.filename)
textPos = Len(basepath)
Test = False
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
featAttTable = Left$(filename, Len(filename) - 4)
workspace = basepath
dCon.Database = workspace
If dCon.Connect Then
  Set gSet = dCon.FindGeoDataset(featAttTable)
  If gSet Is Nothing Then
     MsgBox "error spening esri shapefile" & featAttTable
     Exit Sub
  Else
    Dim newLayer As New MapLayer
    newLayer.GeoDataset = gSet
    newLayer.Name = featAttTable
    'newLayer.Symbol.Color = moRed
    Map1.Layers.Add newLayer
    Map1.Refresh
  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
 End If
End Sub
Function stripProj(theProjection As String) As Variant
  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 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