geometrylocate.frm

有关geomedia的一个全新的gis工程

VERSION 5.00
Begin VB.Form FrmGeometryLocate 
   Caption         =   "查找几何体"
   ClientHeight    =   3060
   ClientLeft      =   60
   ClientTop       =   360
   ClientWidth     =   5310
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3060
   ScaleWidth      =   5310
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton CmdCancel 
      Caption         =   "关闭"
      Height          =   375
      Left            =   4200
      TabIndex        =   4
      Top             =   2640
      Width           =   975
   End
   Begin VB.CommandButton CmdOk 
      Caption         =   "显示"
      Height          =   375
      Left            =   3000
      TabIndex        =   3
      Top             =   2640
      Width           =   975
   End
   Begin VB.ListBox LstValue 
      Height          =   2010
      Left            =   3600
      TabIndex        =   2
      Top             =   480
      Width           =   1575
   End
   Begin VB.ListBox LstAttributes 
      Height          =   2010
      Left            =   1920
      TabIndex        =   1
      Top             =   480
      Width           =   1575
   End
   Begin VB.ListBox LstTable 
      Height          =   2010
      Left            =   120
      TabIndex        =   0
      Top             =   480
      Width           =   1695
   End
   Begin VB.Label Label3 
      Caption         =   "查找的值："
      Height          =   255
      Left            =   3600
      TabIndex        =   7
      Top             =   120
      Width           =   1575
   End
   Begin VB.Label Label2 
      Caption         =   "查找的属性："
      Height          =   255
      Left            =   1920
      TabIndex        =   6
      Top             =   120
      Width           =   1335
   End
   Begin VB.Label Label1 
      Caption         =   "几何体所在的表："
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   120
      Width           =   1455
   End
End
Attribute VB_Name = "FrmGeometryLocate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Dim RcsUniq As GRecordset
Dim StrField As String
 
Private Sub CmdCancel_Click()
  Unload Me
End Sub

Private Sub CmdOk_Click()
  Dim selgeom As RecordObject
  Dim i As Integer
  
  For i = 1 To FrmMain.GMMapView1.Legend.LegendEntries.Count
      If FrmMain.GMMapView1.Legend.LegendEntries(i).Recordset.GFields(0).SourceTable = LstTable.List(LstTable.ListIndex) Then
          Set selgeom = CreateObject("geomedia.recordobject")
         Set selgeom.Recordset = FrmMain.GMMapView1.Legend.LegendEntries(i).Recordset
         Exit For
      End If
  Next i
     selgeom.Recordset.MoveFirst
     Do While Not selgeom.Recordset.EOF
        If selgeom.Recordset.GFields(StrField) = LstValue.List(LstValue.ListIndex) Then
           FrmMain.GMMapView1.HighlightedObjects.Clear
           selgeom.Bookmark = selgeom.Recordset.Bookmark
           FrmMain.GMMapView1.HighlightedObjects.Add selgeom
           Exit Do
        End If
        selgeom.Recordset.MoveNext
     Loop
End Sub

Private Sub Form_Load()
  Dim lEntryCount As Integer
  Dim i As Integer
  lEntryCount = FrmMain.GMMapView1.Legend.LegendEntries.Count
  For i = 1 To lEntryCount
    LstTable.AddItem FrmMain.GMMapView1.Legend.LegendEntries(i).Recordset.GFields(0).SourceTable
  Next i
End Sub

Private Sub LstAttributes_Click()
On Error Resume Next
   Dim valueCount As Long
   Dim i As Long
   Dim SqlQuery As String
   StrField = LstAttributes.List(LstAttributes.ListIndex)
   SqlQuery = "select distinct " & StrField & " from " & LstTable.List(LstTable.ListIndex)
   Set RcsUniq = gobjConnection.Database.OpenRecordset(SqlQuery, gdbOpenDynaset)
   RcsUniq.MoveLast
   RcsUniq.MoveFirst
   valueCount = RcsUniq.RecordCount
   
   LstValue.Clear
   For i = 1 To valueCount
     LstValue.AddItem RcsUniq.GFields(StrField).Value
     RcsUniq.MoveNext
   Next i
   
End Sub

Private Sub LstTable_Click()
 On Error GoTo ErrorHandler
    Dim oMDS As New MetadataService
    Set oMDS.Connection = gobjConnection
    oMDS.TableName = LstTable.List(LstTable.ListIndex)
    Dim vFields As Variant
    oMDS.GetFields 2 + 4 + 8 + 16 + 32 + 64 + 128 + 256, vFields  ' gmmfByte + gmmfInteger + gmmfLong + gmmfCurrency + gmmfSingle + gmmfDouble + gmmfDate + gmmfText
    LstAttributes.Clear
    Dim i As Long
    For i = LBound(vFields) To UBound(vFields) - 1
        LstAttributes.AddItem vFields(i)
    Next
    LstAttributes.ListIndex = 0
    GoTo Finish

ErrorHandler:
    MsgBox Err.Number & " - " & Err.Source & Chr(13) & _
        Err.Description, vbOKOnly + vbExclamation

Finish:
    On Error Resume Next

End Sub