frmspatialquery.frm

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

VERSION 5.00
Begin VB.Form frmSpatialAnylize 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Spatial Anylize"
   ClientHeight    =   3570
   ClientLeft      =   1815
   ClientTop       =   3885
   ClientWidth     =   6630
   Icon            =   "frmSpatialQuery.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   3570
   ScaleWidth      =   6630
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  'CenterOwner
   Begin VB.ListBox lstSecondTable 
      Height          =   2400
      Left            =   4560
      TabIndex        =   7
      Top             =   480
      Width           =   1935
   End
   Begin VB.ListBox lstFirstTable 
      Height          =   2400
      Left            =   240
      TabIndex        =   6
      Top             =   480
      Width           =   1815
   End
   Begin VB.CommandButton btnCancel 
      Cancel          =   -1  'True
      Caption         =   "Cancel"
      Height          =   350
      Left            =   5400
      TabIndex        =   5
      Top             =   3120
      Width           =   1125
   End
   Begin VB.CommandButton btnOK 
      Caption         =   "OK"
      Default         =   -1  'True
      Height          =   350
      Left            =   4200
      TabIndex        =   4
      Top             =   3120
      Width           =   1125
   End
   Begin VB.ComboBox cboOperator 
      Height          =   315
      Left            =   2280
      Style           =   2  'Dropdown List
      TabIndex        =   2
      Top             =   480
      Width           =   2175
   End
   Begin VB.Label Label3 
      Caption         =   "&Operator:"
      Height          =   255
      Left            =   2280
      TabIndex        =   1
      Top             =   120
      Width           =   1815
   End
   Begin VB.Label Label2 
      Caption         =   "Select &second input table:"
      Height          =   255
      Left            =   4560
      TabIndex        =   3
      Top             =   120
      Width           =   2895
   End
   Begin VB.Label Label1 
      Caption         =   "Select &first input table:"
      Height          =   255
      Left            =   240
      TabIndex        =   0
      Top             =   120
      Width           =   1815
   End
End
Attribute VB_Name = "frmSpatialAnylize"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub btnCancel_Click()
Unload Me
End Sub

Private Sub btnOK_Click()
  Dim objOP As OriginatingPipe
  Dim objRS1 As GRecordset
  Dim objRS2 As GRecordset
  Dim oLE As New RecordLegendEntry
  gobjConnection.CreateOriginatingPipe objOP
  objOP.Table = lstFirstTable.List(lstFirstTable.ListIndex)
  Set objRS1 = objOP.OutputRecordset
  Set objOP = Nothing
  gobjConnection.CreateOriginatingPipe objOP
  objOP.Table = lstSecondTable.List(lstSecondTable.ListIndex)
  Set objRS2 = objOP.OutputRecordset
  
  If FrmMain.MouseAction = "Intersection" Then
     Dim objQry As New SpatialIntersectionPipe
     Set objQry.LeftRecordset = objRS1
     objQry.LeftGeometryFieldName = GetGeometryFieldName(objRS1)
     With objQry
     Set .RightRecordset = objRS2
    .RightGeometryFieldName = GetGeometryFieldName(objRS2)
    .OutputGeometryFieldName = "OutputGeometry"
    .SpatialOperator = cboOperator.ListIndex + 1
    .OutputStatusFieldName = "status"
    End With
    Set FrmMain.RecordsetOutputTable = objQry.OutputRecordset
    With oLE
        .Title = "Intersection" & GetGeometryFieldName(objRS1) & "and" & GetGeometryFieldName(objRS2)
        .GeometryFieldName = objQry.OutputGeometryFieldName
         Set .Recordset = objQry.OutputRecordset
         Set .Style = New AreaStyle '也可定义线类型，只是显示时不填充
        .Style.BackColor = RGB(255, 255, 220)
        .Style.FillType = gmsFPSolid
        .Style.StyleUnits = gmsStyleUnitsView

    End With
    If oLE.ValidateSource Then
        If FrmMain.GMMapView1.Legend.LegendEntries.Count = 0 Then
            FrmMain.GMMapView1.Legend.LegendEntries.Append oLE
            oLE.LoadData
            FrmMain.GMMapView1.Fit
        Else
            FrmMain.GMMapView1.Legend.LegendEntries.Append oLE, 1
            oLE.LoadData
        End If
        FrmMain.GMMapView1.Refresh True
        FrmMain.GMMapView1.Legend.Refresh
    End If
 End If
 If FrmMain.MouseAction = "Difference" Then
    Dim objSpatPipe As New SpatialDifferencePipe
    Set objSpatPipe.InputRecordset = objRS1
    
    With objSpatPipe
    .InputGeometryFieldName = GetGeometryFieldName(objRS1)
    Set .MaskRecordset = objRS2
    .MaskGeometryFieldName = GetGeometryFieldName(objRS2)
    .OutputStatusFieldName = "StatusField"
    .OutputGeometryFieldName = "OutputGeometry"
    End With
    Set FrmMain.RecordsetOutputTable = objQry.OutputRecordset
    With oLE
        .GeometryFieldName = objSpatPipe.OutputGeometryFieldName
        Set .Style = New LinearStyle
        Set .Recordset = objSpatPipe.OutputRecordset
    End With

   If oLE.ValidateSource Then
        If FrmMain.GMMapView1.Legend.LegendEntries.Count = 0 Then
            FrmMain.GMMapView1.Legend.LegendEntries.Append oLE
            oLE.LoadData
            FrmMain.GMMapView1.Fit
        Else
            FrmMain.GMMapView1.Legend.LegendEntries.Append oLE, 1
            oLE.LoadData
        End If
        FrmMain.GMMapView1.Refresh True
        FrmMain.GMMapView1.Legend.Refresh
    End If
  Set oLE = Nothing
   
  FrmMain.GMMapView1.Fit
  FrmMain.GMMapView1.Refresh True
 End If
 Unload Me
End Sub

Private Sub Form_Load()
    Dim oMDS As New MetadataService
    Set oMDS.Connection = gobjConnection
    Dim vFeatures As Variant
    oMDS.GetTables 1 + 2 + 4 + 8 + 32 + 128, vFeatures 'gmmtPoint + gmmtLinear + gmmtAreal + gmmtAnySpatial + gmmtGraphicsText + gmmtGraphic, _
    Dim i As Long
    For i = LBound(vFeatures) To UBound(vFeatures) - 1
        lstFirstTable.AddItem vFeatures(i)
        lstSecondTable.AddItem vFeatures(i)
    Next i
    cboOperator.Clear
    cboOperator.AddItem "Meet"
    cboOperator.AddItem "Overlap"
    cboOperator.AddItem "Contains"
    cboOperator.AddItem "Contained by"
    cboOperator.AddItem "Entirely contains"
    cboOperator.AddItem "Entirely contained by"
    cboOperator.AddItem "Spatially equal"
    cboOperator.AddItem "Touches"
    cboOperator.ListIndex = 0
End Sub