frmgcsprop.frm

都是基于VB所做的程序集合,值得大家作为实践的参考资料.

            TabIndex        =   10
            Top             =   1240
            Width           =   1575
         End
         Begin VB.Label Label11 
            Caption         =   "类型(Type)"
            Height          =   255
            Left            =   240
            TabIndex        =   9
            Top             =   720
            Width           =   855
         End
         Begin VB.Label Label12 
            Caption         =   "名称(Name)"
            Height          =   255
            Left            =   240
            TabIndex        =   8
            Top             =   360
            Width           =   975
         End
      End
   End
   Begin VB.Frame Frame1 
      Height          =   1095
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   6375
      Begin VB.ComboBox cmbGCSType 
         Height          =   315
         ItemData        =   "frmGCSProp.frx":0129
         Left            =   1800
         List            =   "frmGCSProp.frx":013D
         TabIndex        =   19
         Text            =   "Combo1"
         Top             =   650
         Width           =   4335
      End
      Begin VB.TextBox txtGCSName 
         Enabled         =   0   'False
         Height          =   285
         Left            =   1800
         TabIndex        =   1
         Text            =   "Text2"
         Top             =   240
         Width           =   4335
      End
      Begin VB.Label Label2 
         Caption         =   "坐标系名称(Name)"
         Height          =   255
         Left            =   120
         TabIndex        =   3
         Top             =   320
         Width           =   1695
      End
      Begin VB.Label Label3 
         Caption         =   "坐标系类型(Type)"
         Height          =   255
         Left            =   120
         TabIndex        =   2
         Top             =   720
         Width           =   1455
      End
   End
End
Attribute VB_Name = "frmGCSProp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public objGCS As soPJGeoCoordSys
Public objPCS As soPJCoordSys
Public bFormLoaded As Boolean

Private Sub cmbDatumType_Click()
    If bFormLoaded Then
        objGCS.PJDatum.Type = cmbDatumType.ItemData(cmbDatumType.ListIndex)
        
        If objGCS.PJDatum.Type = scDATUM_USER_DEFINED Then
            cmbSperoidType.Enabled = True
        Else
            cmbSperoidType.Enabled = False
        End If
        InitGCS
    End If
End Sub

Private Sub cmbGCSType_Click()
    If bFormLoaded Then
        objGCS.Type = cmbGCSType.ItemData(cmbGCSType.ListIndex)
        InitGCS
        
        If objGCS.Type = scGCS_USER_DEFINED Then
            cmbDatumType.Enabled = True
            cmbUnit.Enabled = True
            cmbMeriType.Enabled = True
        Else
            cmbDatumType.Enabled = False
            cmbUnit.Enabled = False
            cmbMeriType.Enabled = False
        End If
        cmdapply.Enabled = True
    End If
End Sub

Private Sub cmbSperoidType_Click()
    If bFormLoaded Then
        objGCS.PJDatum.PJSpheroid.Type = cmbSperoidType.ItemData(cmbSperoidType.ListIndex)
        If objGCS.PJDatum.PJSpheroid.Type = scSPHEROID_USER_DEFINED Then
            lvwSperoid.Enabled = True
        Else
            lvwSperoid.Enabled = False
        End If
        InitGCS
    End If
End Sub

Private Sub cmbUnit_Click()
    If bFormLoaded Then
        objGCS.CoordUnits = cmbUnit.ItemData(cmbUnit.ListIndex)
    End If
End Sub

Private Sub cmdapply_Click()
   Set frmPCSProp.objPCS.GeoCoordSys = objGCS
   frmPCSProp.InitPCS
End Sub

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdOK_Click()
    'cmdapply_Click
    Set objPCS = Nothing
    Set objGCS = Nothing
    Unload Me
End Sub

Private Sub Form_Load()
    bFormLoaded = False
    
    If objPCS Is Nothing Then
        MsgBox "无效的投影坐标系"
        Exit Sub
    Else
        Set objGCS = objPCS.GeoCoordSys
        InitGCS
        bFormLoaded = True
    End If
End Sub
Private Sub InitGCS()
    Dim i As Integer
    
    If objGCS Is Nothing Then
        MsgBox "无效的地理坐标系!"
        Exit Sub
    Else
        txtGCSName.Text = objGCS.Name
     '地理坐标系类型
        For i = 0 To cmbGCSType.ListCount - 1
            If cmbGCSType.ItemData(i) = objGCS.Type Then
                cmbGCSType.Text = cmbGCSType.List(i)
                Exit For
            End If
        Next
        If (i = cmbGCSType.ListCount) Then
            MsgBox "不存在的地理坐标系: " & objGCS.Type
        End If
    
    '坐标系单位
        For i = 0 To cmbUnit.ListCount - 1
            If cmbUnit.ItemData(i) = objGCS.CoordUnits Then
                cmbUnit.Text = cmbUnit.List(i)
                Exit For
            End If
        Next
        If (i = cmbUnit.ListCount) Then
            MsgBox "不存在的坐标单位: " & objGCS.CoordUnits
        End If
     
     '大地参照系
        txtDatumName.Text = objGCS.PJDatum.Name
        For i = 0 To cmbDatumType.ListCount - 1
            If cmbDatumType.ItemData(i) = objGCS.PJDatum.Type Then
                cmbDatumType.Text = cmbDatumType.List(i)
                Exit For
            End If
        Next
        If (i = cmbDatumType.ListCount) Then
            MsgBox "不存在的参照系: " & objGCS.PJDatum.Type
        End If
      
      '地球椭球体
        txtSperoidName.Text = objGCS.PJDatum.PJSpheroid.Name
        For i = 0 To cmbSperoidType.ListCount - 1
            If cmbSperoidType.ItemData(i) = objGCS.PJDatum.PJSpheroid.Type Then
                cmbSperoidType.Text = cmbSperoidType.List(i)
                Exit For
            End If
        Next
        If (i = cmbSperoidType.ListCount) Then
            MsgBox "不存在的椭球体: " & objGCS.PJDatum.PJSpheroid.Type
        End If
        
        lvwSperoid.ListItems.Clear
        lvwSperoid.ListItems.Add 1, , objGCS.PJDatum.PJSpheroid.Axis
        lvwSperoid.ListItems.Item(1).SubItems(1) = "长轴"
        
        lvwSperoid.ListItems.Add 2, , objGCS.PJDatum.PJSpheroid.Flatten
        lvwSperoid.ListItems.Item(1).SubItems(1) = "扁率"
        
      
      '起始经线
        txtMeriName.Text = objGCS.PJPrimeMeridian.Name
        txtLongitudeValue.Text = objGCS.PJPrimeMeridian.LongitudeValue
        For i = 0 To cmbMeriType.ListCount - 1
            If cmbMeriType.ItemData(i) = objGCS.PJPrimeMeridian.Type Then
                cmbMeriType.Text = cmbMeriType.List(i)
                Exit For
            End If
        Next
        If (i = cmbMeriType.ListCount) Then
            MsgBox "不存在的起始经线: " & objGCS.PJPrimeMeridian.Type
        End If
    
    End If
End Sub