frmproperties.frm

有关geomedia的定义我的鼠标事件

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Object = "{2635E9FF-96C9-11CF-8638-08003601B01F}#5.0#0"; "event.ocx"
Begin VB.Form frmProperties 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Attributes"
   ClientHeight    =   4005
   ClientLeft      =   2355
   ClientTop       =   6315
   ClientWidth     =   5055
   ControlBox      =   0   'False
   Icon            =   "frmProperties.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4005
   ScaleWidth      =   5055
   ShowInTaskbar   =   0   'False
   Begin ComctlLib.ListView lvProperties 
      Height          =   2775
      Left            =   120
      TabIndex        =   1
      Top             =   480
      Width           =   4695
      _ExtentX        =   8281
      _ExtentY        =   4895
      View            =   3
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   327682
      ForeColor       =   -2147483640
      BackColor       =   -2147483633
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   2
      BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7} 
         Key             =   ""
         Object.Tag             =   ""
         Text            =   "Field"
         Object.Width           =   2540
      EndProperty
      BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7} 
         SubItemIndex    =   1
         Key             =   ""
         Object.Tag             =   ""
         Text            =   "Value"
         Object.Width           =   2540
      EndProperty
   End
   Begin VB.CommandButton cmdClose 
      Cancel          =   -1  'True
      Caption         =   "Close"
      Default         =   -1  'True
      Height          =   375
      Left            =   3600
      TabIndex        =   0
      Top             =   3480
      Width           =   1215
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   600
      Top             =   0
   End
   Begin GMEventControlLib.EventControl EventControl1 
      Left            =   120
      Top             =   0
      _Version        =   327680
      _ExtentX        =   741
      _ExtentY        =   741
      _StockProps     =   0
   End
End
Attribute VB_Name = "frmProperties"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim m_objSmart As SmartLocateService
Dim m_objLoc As LocatedObjectsCollection
Dim m_objPntGeom As PointGeometry
Dim m_objMapView As Object
Dim m_objSelObjs As DocSelectedObjects
Private Sub cmdClose_Click()
    Hide
End Sub


Private Sub EventControl1_Click(ByVal MapviewDispatch As Object, ByVal Button As Long, ByVal Key As Long, ByVal WindowX As Double, ByVal WindowY As Double, ByVal WindowZ As Double, ByVal worldX As Double, ByVal worldY As Double, ByVal worldZ As Double)
On Error GoTo ErrorHandler

    Dim I As Integer
    
    ' Initialize geometry
    m_objPntGeom.Origin.X = worldX
    m_objPntGeom.Origin.Y = worldY
    m_objPntGeom.Origin.Z = worldZ
    
    ' Clear located and highlighted objects
    m_objSelObjs.Clear
    m_objLoc.Clear
    MapviewDispatch.HighlightedObjects.Clear

    
    ' Locate objects
    m_objSmart.Locate m_objPntGeom, MapviewDispatch, m_objLoc
    
    ' Select objects
    For I = 1 To m_objLoc.Count
        m_objSelObjs.Add m_objLoc.Item(I)
    Next I
    
    ShowAttributes
    Exit Sub
    
ErrorHandler:
    MsgBox Err.Description, vbOKOnly + vbExclamation
End Sub

Private Sub ShowAttributes()
    Dim objSelObj As Object
    Dim objSelGeoObj As GeometryObject
    Dim objField As GField
    Dim I As Integer
    
    ' Show properties
    If m_objSelObjs.NumOfGeometryObjects > 0 Then
        ' Get first selected geometry object
        For I = 1 To m_objSelObjs.Count
            Set objSelObj = m_objSelObjs.Item(I)
            If objSelObj.Type = "GeometryObject" Then
                Set objSelGeoObj = objSelObj
                Exit For
            End If
        Next I
        
        If objSelGeoObj Is Nothing Then
            ' No geometry objects selected!
            Exit Sub
        End If
        
        ' Clear attributes grid
        lvProperties.ListItems.Clear
            
        ' Make selected object current
        objSelGeoObj.Recordset.Bookmark = objSelGeoObj.Bookmark
        
        ' Display attribute values
        For Each objField In objSelGeoObj.Recordset.GFields
            If objField.Type <> gdbLongBinary And _
               objField.Type <> gdbSpatial And _
               objField.Type <> gdbGraphic Then
                If Not IsNull(objField.Value) Then
                    lvProperties.ListItems.Add(, , objField.Name).SubItems(1) = CStr(objField.Value)
                Else
                    lvProperties.ListItems.Add , , objField.Name
                End If
            End If
        Next objField
        
        ' Show modal dialog
        Show vbModal
    End If
End Sub

Private Sub EventControl1_MouseMove(ByVal MapviewDispatch As Object, ByVal Button As Long, ByVal Key As Long, ByVal WindowX As Double, ByVal WindowY As Double, ByVal WindowZ As Double, ByVal worldX As Double, ByVal worldY As Double, ByVal worldZ As Double)
On Error Resume Next

    ' Initialize geometry
    m_objPntGeom.Origin.X = worldX
    m_objPntGeom.Origin.Y = worldY
    m_objPntGeom.Origin.Z = worldZ
    
    ' Keep MapView
    Set m_objMapView = MapviewDispatch
    
    Timer1.Enabled = True
    Timer1.Interval = 1000
End Sub

Private Sub Form_Initialize()
On Error GoTo ErrorHandler

    Set m_objSmart = gobjGeoApp.CreateService("GeoMedia.SmartLocateService")
    Set m_objLoc = gobjGeoApp.CreateService("GeoMedia.LocatedObjectsCollection")
    Set m_objPntGeom = gobjGeoApp.CreateService("GeoMedia.PointGeometry")
    Set m_objSelObjs = gobjGeoApp.Document.SelectedObjects
    
    m_objSmart.PixelTolerance = 1
    m_objLoc.MaxNumOfObjects = 1
    Exit Sub
    
ErrorHandler:
    MsgBox Err.Description, vbOKOnly + vbExclamation
End Sub

Private Sub Form_Load()
    lvProperties.ColumnHeaders(2).Width = lvProperties.Width - lvProperties.ColumnHeaders(1).Width - 100
End Sub

Private Sub Form_Terminate()
    Set m_objSmart = Nothing
    Set m_objLoc = Nothing
    Set m_objPntGeom = Nothing
    Set m_objMapView = Nothing
    Set m_objSelObjs = Nothing
End Sub

Private Sub Timer1_Timer()
    Dim I As Integer
    
    ' Clear located and highlighted objects
    m_objLoc.Clear
    m_objMapView.HighlightedObjects.Clear
    
    ' Locate objects
    m_objSmart.Locate m_objPntGeom, m_objMapView, m_objLoc
    
    ' Highlight objects
    For I = 1 To m_objLoc.Count
        m_objMapView.HighlightedObjects.Add m_objLoc.Item(I)
    Next I
    
    Timer1.Enabled = False
End Sub