mapprojection.frm

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

VERSION 5.00
Begin VB.Form frmMapProjection 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Map Projection"
   ClientHeight    =   2625
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   3495
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2625
   ScaleWidth      =   3495
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdProj 
      Caption         =   "Project the map"
      Height          =   375
      Index           =   1
      Left            =   960
      TabIndex        =   4
      Top             =   1680
      Width           =   1575
   End
   Begin VB.CommandButton cmdProj 
      Caption         =   "Unproject the map"
      Height          =   375
      Index           =   0
      Left            =   960
      TabIndex        =   3
      Top             =   2160
      Width           =   1575
   End
   Begin VB.ComboBox cboProjCoordSys 
      Height          =   315
      Left            =   120
      TabIndex        =   2
      Top             =   1200
      Width           =   3255
   End
   Begin VB.Label Label1 
      Caption         =   "Change map projection to:"
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   960
      Width           =   2295
   End
   Begin VB.Label lblProjInfo 
      BackColor       =   &H00E0E0E0&
      Caption         =   "PROJECTION INFORMATION"
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   120
      Width           =   3255
   End
   Begin VB.Label lblUnits 
      BackColor       =   &H00E0E0E0&
      Height          =   255
      Left            =   120
      TabIndex        =   1
      Top             =   600
      Width           =   3255
   End
   Begin VB.Label lblMapCoordSysName 
      BackColor       =   &H00E0E0E0&
      Height          =   255
      Left            =   120
      TabIndex        =   0
      Top             =   360
      Width           =   3255
   End
End
Attribute VB_Name = "frmMapProjection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub cmdProj_Click(Index As Integer)

Select Case Index
  Case 0  'Unproject the map display
    Dim gcsMap As New MapObjects2.GeoCoordSys
    gcsMap.Type = moGeoCS_WGS1984
    Set frmMain.mapDisp.CoordinateSystem = gcsMap
    cboProjCoordSys.Enabled = True
    cmdProj(1).Enabled = True
    frmMain.strMapUnits = "Decimal Degrees"
  Case 1  'Project the map display
    Dim projCode As String
    projCode = stripProjection(cboProjCoordSys.List(cboProjCoordSys.ListIndex))
    Dim pcsMap As New MapObjects2.ProjCoordSys
    pcsMap.Type = CLng(projCode)
    Set frmMain.mapDisp.CoordinateSystem = pcsMap
    cboProjCoordSys.Enabled = False
    cmdProj(1).Enabled = False
    Select Case True
      Case InStr(pcsMap.Unit.Name, "Meter") <> 0
        frmMain.strMapUnits = "Meters"
      Case InStr(pcsMap.Unit.Name, "Foot") <> 0
        frmMain.strMapUnits = "Feet"
      Case InStr(pcsMap.Unit.Name, "Degree") <> 0
        frmMain.strMapUnits = "Decimal Degrees"
      Case Else
        frmMain.strMapUnits = "Unknown"
    End Select
End Select

Select Case frmMain.strMapUnits
  Case "Unknown":  frmMapProperties.cboMapUnits.ListIndex = 0
  Case "Decimal Degrees":  frmMapProperties.cboMapUnits.ListIndex = 1
  Case "Meters":  frmMapProperties.cboMapUnits.ListIndex = 2
  Case "Feet":  frmMapProperties.cboMapUnits.ListIndex = 3
End Select

Set frmMain.mapDisp.Extent = frmMain.mapDisp.FullExtent
frmMain.mapDisp.Refresh
frmMain.updateScale

Call ResetLabels

End Sub


Private Sub Form_Load()

Call ResetLabels

'Position the Map Projection form to the lower right
'corner of the map itself.  Also ensure the this form
'does not go off the screen.
Me.Top = frmMain.Top + frmMain.Height - Me.Height - 600
Me.Left = frmMain.Left + frmMain.Width - Me.Width - 200
If Me.Top > Screen.Height - Me.Height Then
  Me.Top = Screen.Height - Me.Height
End If
If Me.Left > Screen.Width - Me.Width Then
  Me.Left = Screen.Width - Me.Width
End If

Screen.MousePointer = vbHourglass
Dim i As Integer
Dim strs As New MapObjects2.Strings
strs.PopulateWithProjectedCoordSys
cboProjCoordSys.Clear
For i = 0 To strs.count - 1
  cboProjCoordSys.AddItem strs(i)
Next
Screen.MousePointer = vbDefault

End Sub

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


Private Sub ResetLabels()

lblMapCoordSysName.Caption = "Projection:  " & frmMain.mapDisp.CoordinateSystem.Name
lblUnits.Caption = "Map Units: " & frmMain.mapDisp.CoordinateSystem.Unit.Name

End Sub

Private Sub lblGeoCoordSys_Click()

End Sub