placelocator.frm

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

         Width           =   2535
      End
      Begin VB.Label lblBaseFields 
         Caption         =   "Which field in your base layer's attribute table contains the values that you want to match against?"
         Height          =   615
         Left            =   240
         TabIndex        =   1
         Top             =   720
         Width           =   2535
      End
   End
End
Attribute VB_Name = "frmPlaceLocator"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public thePlaceLocator As MapObjects2.PlaceLocator
Private mlyrBase As MapObjects2.MapLayer
Private ptsPlaces As MapObjects2.Points
Private tbl As New MapObjects2.Table
Private recs As MapObjects2.Recordset

Private Sub Form_Load()

'Bail out if there are no active layers
If frmMain.mapDisp.Layers.count = 0 Or _
   frmMain.legMapDisp.getActiveLayer = -1 Then
  Exit Sub
End If

'Position to the right of the main form
Me.Move frmMain.Left + frmMain.Width, frmMain.Top
If (Me.Left + Me.Width) > Screen.Width Then
  Me.Left = Screen.Width - Me.Width
End If

'Initialize tabs
sstPlaceLocator.Tab = 0
sstPlaceLocator.TabEnabled(1) = False
sstPlaceLocator.TabEnabled(2) = False

'Set a local object variable to hold the layer so that
'it will be possible for the user to change the globally
'active layer without changing the matching base layer.
If frmMain.mapDisp.Layers.count > 0 And _
   frmMain.legMapDisp.getActiveLayer > -1 Then
    Set mlyrBase = frmMain.mapDisp.Layers(frmMain.legMapDisp.getActiveLayer)
    Me.Caption = "Addressmatch to the " & _
                  UCase(mlyrBase.Name) & _
                 " layer."
    Dim i As Integer
    cboMatchField.Clear
    For i = 0 To mlyrBase.Records.TableDesc.FieldCount - 1
      cboMatchField.AddItem mlyrBase.Records.TableDesc.FieldName(i)
    Next
End If
       
       
lblBaseFields.Caption = "Which field in the " & UCase(mlyrBase.Name) & _
                  " layer's attribute table contains the values against" & _
                  " which you want to match?"

cboSingleMatch(0).ListIndex = 2  'Default marker style: Triangle
cboSingleMatch(1).ListIndex = 2  'Default marker size: 6
cboBatchMatch(0).ListIndex = 2
cboBatchMatch(1).ListIndex = 2

End Sub

Private Sub cmdBuildIndex_Click()

Dim indexbuildworked As Boolean
Dim dc As New MapObjects2.DataConnection
Dim gds As MapObjects2.GeoDataset
Dim tag, path, sfname, strFieldNameBase As String

strFieldNameBase = cboMatchField.List(cboMatchField.ListIndex)

'Strip the path string and shapefile name out
'of the base layer's Tag property.
tag = mlyrBase.tag
sfname = Right(tag, Len(tag) - InStr(tag, "|"))
path = Mid(tag, 12, Len(tag) - 12 - Len(sfname))

'Build GeoDataset object and assign to PlaceLocator
dc.Database = path
If Not dc.Connect Then
  MsgBox "Could not connect to:  " & path, vbCritical, "Stop"
  Exit Sub
End If
Set gds = dc.FindGeoDataset(sfname)
Set thePlaceLocator = New MapObjects2.PlaceLocator
Set thePlaceLocator.PlaceNameTable = gds

'Build the matching index
Screen.MousePointer = vbHourglass
indexbuildworked = thePlaceLocator.BuildIndex(strFieldNameBase, (chkForce.Value = 1))
Screen.MousePointer = vbDefault

'If the index build worked, then move the user to the
'next tab, otherwise bail out.
If indexbuildworked Then
  lblSingleMatch(0).Caption = _
     "Find and draw all features that match this " & _
     UCase(strFieldNameBase) & " address."
     sstPlaceLocator.TabEnabled(1) = True
     sstPlaceLocator.TabEnabled(2) = True
     sstPlaceLocator.Tab = 1
 Else
  MsgBox "Unable to create matching index.", vbCritical, "Stop"
  Exit Sub
End If

End Sub

Private Sub cmdSingleMatch_Click()

Dim i As Long

Set ptsPlaces = thePlaceLocator.Locate(txtPlaceName.text)

If ptsPlaces.count = 0 Then
  MsgBox "Could not locate address.", vbInformation
 Else
End If

Call SyncSymbolCombos(1)

'Reposition the map to see all of the found places
If ptsPlaces.count = 1 Then
  If Not frmMain.mapDisp.Extent.IsPointIn(ptsPlaces(0)) Then
    frmMain.mapDisp.CenterAt ptsPlaces(0).x, ptsPlaces(0).y
    'frmMain.mapDisp.FlashShape ptsPlaces(0), 3
  End If
  frmMain.mapDisp.TrackingLayer.Refresh True
 Else
  Dim Rect As MapObjects2.Rectangle
  Set Rect = frmMain.mapDisp.Extent
  For i = 0 To ptsPlaces.count - 1
    If ptsPlaces(i).x < Rect.Left Then
      Rect.Left = ptsPlaces(i).x
    End If
    If ptsPlaces(i).x > Rect.Right Then
      Rect.Right = ptsPlaces(i).x
    End If
    If ptsPlaces(i).y < Rect.Bottom Then
      Rect.Bottom = ptsPlaces(i).y
    End If
    If ptsPlaces(i).y > Rect.Top Then
      Rect.Top = ptsPlaces(i).y
    End If
  Next
  Rect.ScaleRectangle 1.2
  frmMain.mapDisp.Extent = Rect
End If

End Sub

Private Sub cboBatchMatch_Click(Index As Integer)

If Index = 2 Then
  lblBatchMatch(4).Visible = True
  picBatchMatch.Visible = True
  cboBatchMatch(0).Visible = True
  cboBatchMatch(1).Visible = True
  cmdBatchMatch.Visible = True
End If

End Sub

Private Sub cmdBatchMatch_Click()

Dim pts As MapObjects2.Points
Dim strFieldNameSource, strAddress As String
Dim i As Long

strFieldNameSource = cboBatchMatch(2).List(cboBatchMatch(2).ListIndex)
Set ptsPlaces = New MapObjects2.Points

recs.MoveFirst
Do Until recs.EOF
  strAddress = recs.Fields(strFieldNameSource).Value
  Set pts = thePlaceLocator.Locate(strAddress)
  If pts.count > 0 Then
    For i = 0 To pts.count - 1
      ptsPlaces.Add pts(i)
    Next
  End If
  recs.MoveNext
Loop

Call SyncSymbolCombos(2)
frmMain.mapDisp.TrackingLayer.Refresh True

Unload Me

End Sub

Private Sub cmdOpenDatabase_Click()

Dim fnsource, pathsource As String
Dim i As Integer

cdlPlaceLocator.Filter = "dBASE Files (*.dbf)|*.dbf"
cdlPlaceLocator.ShowOpen
If Len(cdlPlaceLocator.filename) = 0 Then Exit Sub
fnsource = Left(cdlPlaceLocator.FileTitle, Len(cdlPlaceLocator.FileTitle) - 4)
pathsource = Left(cdlPlaceLocator.filename, _
             Len(cdlPlaceLocator.filename) - Len(fnsource) - 4)

tbl.Database = "dBASE IV;DATABASE=" & pathsource
tbl.Name = fnsource
Set recs = tbl.Records
cboBatchMatch(2).Clear
For i = 0 To recs.TableDesc.FieldCount - 1
  cboBatchMatch(2).AddItem recs.TableDesc.FieldName(i)
Next

'Update additional controls
lblBatchMatch(1).Visible = True
lblBatchMatch(2).Visible = True
lblBatchMatch(2).Caption = cdlPlaceLocator.filename
lblBatchMatch(3).Visible = True
cboBatchMatch(2).Visible = True

End Sub

Public Sub DrawLocatedPlaces(ByVal hDC As StdOle.OLE_HANDLE)
    
'This global procedure is called by frmMain.mapDisp.AfterTrackingLayerDraw
'to draw all located placed onto the map.
Dim i As Integer

If Not ptsPlaces Is Nothing Then
    Dim sym As New MapObjects2.Symbol
    sym.SymbolType = moPointSymbol
    sym.style = cboSingleMatch(0).ListIndex
    sym.color = picSingleMatch.BackColor
    sym.Size = cboSingleMatch(1).List(cboSingleMatch(1).ListIndex)
  For i = 0 To ptsPlaces.count - 1
    frmMain.mapDisp.DrawShape ptsPlaces(i), sym
  Next
End If

End Sub
'
'
'
'THE NEXT FOUR PROCEDURES
'Change colors for located places and synchronize
'with the symbol controls on both tabs.
Private Sub picBatchMatch_Click()
  cdlPlaceLocator.ShowColor
  picBatchMatch.BackColor = cdlPlaceLocator.color
  Call SyncSymbolCombos(2)
End Sub
Private Sub picSingleMatch_Click()
  cdlPlaceLocator.ShowColor
  picSingleMatch.BackColor = cdlPlaceLocator.color
  Call SyncSymbolCombos(1)
End Sub
Private Sub sstPlaceLocator_Click(PreviousTab As Integer)
  Call SyncSymbolCombos(PreviousTab)
End Sub
Private Sub SyncSymbolCombos(otherTab As Integer)
  Select Case otherTab
    Case 1
      cboBatchMatch(0).ListIndex = cboSingleMatch(0).ListIndex
      cboBatchMatch(1).ListIndex = cboSingleMatch(1).ListIndex
      picBatchMatch.BackColor = cdlPlaceLocator.color
    Case 2
      cboSingleMatch(0).ListIndex = cboBatchMatch(0).ListIndex
      cboSingleMatch(1).ListIndex = cboBatchMatch(1).ListIndex
      picSingleMatch.BackColor = cdlPlaceLocator.color
  End Select
End Sub