VB改DELPHI

Option Explicit
'*-----------------------------------------------------------------------
'* "Getting Started with the Map control and Visual Basic"
'* ESRI ArcGIS 8.1
'* ----------------------------------------------------------------------
Private m_pElementColn As IElementCollection 'For the TrackEvents
Private m_pQuery As ICommand ' used for the Query command
Private m_pCommand As ICommand 'used for the Identify tool
 

Private Sub Form_Load()
 Form_Resize
 InitializeMap 'loads the data
 
 ' Create the AfCommandsVB Identify tool
 Set m_pCommand = New AfCommandsVB.Identify
 ' Pass the Map control as the hook
 m_pCommand.OnCreate MapControl1.Object
 
 ' Set the mouse pointer to be zoomin
 MapControl1.MousePointer = esriPointerZoomIn
 
 ' Create the collection for the TrackEvents
 Set m_pElementColn = New ElementCollection
 
 ' Create the AfCommandsVB Query tool
 Set m_pQuery = New AfCommandsVB.Query
 m_pQuery.OnCreate MapControl1.Object

 ' Set the scale breaks according to the layers
 Dim pLayer As ILayer
 Dim i As Integer
 ' Iterate through all layers
 For i = 0 To MapControl1.LayerCount - 1
    Set pLayer = MapControl1.Layer(i)
    '  Note case sensitivity
    If UCase(pLayer.Name) = "COUNTIES" Then
      pLayer.MaximumScale = 0#
      pLayer.MinimumScale = 15000000#

    ElseIf UCase(pLayer.Name) = "STATES" Then
      pLayer.MaximumScale = 14999999#
      pLayer.MinimumScale = 0#
    End If
 Next i

' Create a red color object for the FeatureSelection highlight for each layer
Dim pColor As IColor
Set pColor = New RgbColor
pColor.RGB = 255
Dim pFeatSeln As IFeatureSelection

'iterate layers and set the color
For i = 0 To MapControl1.LayerCount - 1
Set pLayer = MapControl1.Layer(i)
'work only with feature layers
 If (TypeOf pLayer Is IFeatureLayer) Then
  ' QI for the FeatureSelection
  Set pFeatSeln = pLayer
  Set pFeatSeln.SelectionColor = pColor
 End If
Next i


End Sub


Private Sub MapControl1_OnAfterDraw(ByVal display As esriCore.IDisplay, ByVal phase As esriCore.esriViewDrawPhase)
' Iterate through the collection of TrackEvents and draw them to the screen
If (phase = esriViewForeground) Then
    Dim pElement As IElement
    Dim i As Integer
    For i = 0 To m_pElementColn.Count - 1
        m_pElementColn.QueryItem i, pElement
        MapControl1.DrawShape pElement.Geometry
    Next
End If
End Sub


Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
  ' Find the States layer
    Dim i As Integer
    Dim pFeatLyr As IFeatureLayer
    For i = 0 To MapControl1.LayerCount - 1
       Set pFeatLyr = MapControl1.Layer(i)
       If pFeatLyr.Name = "states" Then
           ' Found it and exit loop
            Exit For
       End If
    Next i
  
  ' Create a string to use in the query
   Dim queryStr As String
   queryStr = "STATE_NAME = '" & Text1.Text & "'"
    ' Create the query filter
    Dim pQueryFltr As IQueryFilter
    Set pQueryFltr = New QueryFilter
    pQueryFltr.WhereClause = queryStr
  
    ' Perform the selection
    Dim pFeatSeln As IFeatureSelection
    Set pFeatSeln = pFeatLyr
    pFeatSeln.SelectFeatures _
    pQueryFltr, esriSelectionResultNew, False
    ' Get the selection set
    Dim pSelSet As ISelectionSet
    Set pSelSet = pFeatSeln.SelectionSet
  
   ' Get the cursor from the selection set
    Dim pFeatCursor As IFeatureCursor
    pSelSet.Search Nothing, True, pFeatCursor
    ' Assume only one feature
    Dim pFeature As IFeature
    Set pFeature = pFeatCursor.NextFeature
    If Not pFeature Is Nothing Then
        ' Get the extent of the selected feature
         Dim pExtent As IEnvelope
         Set pExtent = pFeature.Shape.Envelope
         ' And set the MapControl's extent
         MapControl1.Extent = pFeature.Shape.Envelope
     End If
  End If
End Sub


Private Sub Toolbar1_ButtonClick(ByVal Button As MSComCtlLib.Button)
With MapControl1
' Reset the CurrentTool
Set .CurrentTool = Nothing
Select Case Button.Key
Case "Zoom"
    .MousePointer = esriPointerZoomIn
  
Case "Pan"
    .MousePointer = esriPointerPan
                
Case "FullExtent"
    .MousePointer = esriPointerDefault
    .Extent = MapControl1.FullExtent

    .MousePointer = esriPointerCrosshair

Case "SelectByPolygon"
Case "TrackEvent"
    .MousePointer = esriPointerHotLink

Case "Identify"
    .MousePointer = esriPointerDefault
    Set .CurrentTool = m_pCommand
          
Case "Query"
    .MousePointer = esriPointerDefault
    ' Fire the actual command
    m_pQuery.OnClick
    
End Select
End With
End Sub




Private Sub MapControl1_OnMouseDown(ByVal Button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long, ByVal mapX As Double, ByVal mapY As Double)
    If Toolbar1.Buttons.Item("Zoom").Value = tbrPressed Then
        MapControl1.Extent = MapControl1.TrackRectangle
        
    ElseIf Toolbar1.Buttons.Item("Pan").Value = tbrPressed Then
        MapControl1.Pan
        
    ElseIf Toolbar1.Buttons("SelectByPolygon").Value = tbrPressed Then
        Call SearchShape
        
    ElseIf Toolbar1.Buttons("TrackEvent").Value = tbrPressed Then
        AddGeoEvent mapX, mapY
        
    End If
End Sub

Private Sub Form_Resize()
 If (ScaleWidth <> 0) Then
     ' y coord for Text and Label
     Dim yFind As Integer
    ' a constant spacing
     Dim space As Integer
     space = Text1.Top - (MapControl1.Top + MapControl1.Height)
     yFind = ScaleHeight - Text1.Height - space

     ' x coord for Text and Label
     Dim xFind As Integer
     xFind = ScaleWidth - Text1.Width
  
     Dim mapTop As Integer
     mapTop = Toolbar1.Top + Toolbar1.Height
     Dim mapHeight As Integer
     mapHeight = yFind - space - mapTop
     If (mapHeight > 0) Then
      ' move all the controls
       Check1.Move 0, yFind
       Text1.Move xFind, yFind
       Label1.Move xFind - Label1.Width - 20, yFind
       MapControl1.Move 0, mapTop, ScaleWidth, mapHeight
     End If
   End If
End Sub

Private Sub SearchShape()
    Dim pSearchShape As IPolygon
    '  Create the search shape
    Set pSearchShape = MapControl1.TrackPolygon
    
     '  Do the actual selection - invalidate the old selection
    MapControl1.Map.ClearSelection
    MapControl1.Refresh esriViewGeoSelection, Nothing, Nothing
    MapControl1.Map.SelectByShape pSearchShape, Nothing, False
    
     '  And refresh the map
    MapControl1.Refresh esriViewGeoSelection, Nothing, Nothing
End Sub

Private Sub AddGeoEvent(mapX As Double, mapY As Double)
    ' Make the point
    Dim pPoint As IPoint
    Set pPoint = New Point
    pPoint.PutCoords mapX, mapY
    ' Make the element
    Dim pElement As IElement
    Set pElement = New MarkerElement
    pElement.Geometry = pPoint
    ' Add the element to the collection
    m_pElementColn.Add pElement
    
    ' And finally redraw the map
    MapControl1.Refresh esriViewForeground, Nothing, Nothing

End Sub
Private Sub Timer1_Timer()
    Dim maxDist As Double
    Dim nEventCount As Integer
    Dim pt As IPoint
    maxDist = MapControl1.Extent.Width / 20
    nEventCount = m_pElementColn.Count
    
    Dim newX As Double
    Dim newY As Double
    Dim i As Integer
    
    ' If the collection is not empty
    If (nEventCount > 0) Then
     Dim pGeometry As IPoint
     Dim pElement As IElement
     ' Iterate the colllection
    
     For i = 0 To nEventCount - 1
        m_pElementColn.QueryItem i, pElement
        Set pGeometry = pElement.Geometry
        newX = pGeometry.x - (maxDist * (Rnd - 0.5))
        newY = pGeometry.y - (maxDist * (Rnd - 0.5))
        pGeometry.PutCoords newX, newY
        pElement.Geometry = pGeometry
      
     Next i
    
     MapControl1.Refresh esriViewForeground, Nothing, Nothing
    End If
End Sub

Private Sub Check1_Click()
    ' Turn the timer on/off
    Timer1.Interval = Check1.Value * 500
End Sub
Sub InitializeMap()
    Dim pFactory As IWorkspaceFactory
    Dim pWorkspace As IFeatureWorkspace
    Dim pFeatLayer As IFeatureLayer
    Dim sPath As String
    'Data path - change to reflect your installation!
    sPath = App.Path & "\..\..\Data\usa"
    ' Create a new ShapefileWorkspaceFactory object
    Set pFactory = New ShapefileWorkspaceFactory
    Set pWorkspace = pFactory.OpenFromFile(sPath, 0)
    ' Create a new FeatureLayer and assign a shapefile to it
    Set pFeatLayer = New FeatureLayer
    Set pFeatLayer.FeatureClass = pWorkspace.OpenFeatureClass("States")
    pFeatLayer.Name = pFeatLayer.FeatureClass.AliasName
    
    ' Add the FeatureLayer(s) to the map
    With MapControl1
        .AddLayer pFeatLayer
        .AddShapeFile sPath, "counties"
        .AddShapeFile sPath, "USHigh"
    End With
End Sub
上面的VB程序用DELPHI 怎么样写. 谢谢

谢谢.楼上的兄弟

我已经传到论坛上了。看"Ao代码共享"

你发到我的邮箱里好了。谢谢。WANTZER@163.COM

我传了.但是好象不行,说我权限不够.包含了你的这个问题?

楼上的兄弟贴出来好吗？谢谢！！

我有这些Delphi的代码?但传不上来.

FORM_LOAD这一部分的。谢谢楼上的兄弟加以指点