vba10-3.txt

AO的原代码,都是以TXT的文件写的,对你肯定有帮助的.这些都是 我的心血啊.

Option Explicit
Private Sub ZoomToCounty()
    ' This procedure sets the definistion for the Tracts layer
    ' so that only tracts of the slected county is displayed.
    ' It also zooms to the selected county.
    '
    ' (1) Collect the required information.
    Dim strStateName As String
    Dim strCountyName As String
    Dim pTractLayer As IFeatureLayer
    Dim pCountyLayer As IFeatureLayer
    Dim pStateLayer As IFeatureLayer
    strStateName = frmClassify.cboState
    strCountyName = frmClassify.cboCounty
    Set pTractLayer = Main.g_pTractLayer
    Set pCountyLayer = Main.g_pCountyLayer
    Set pStateLayer = Main.g_pStateLayer
    '
    ' (2) Get the FIPS values for the state and county
    '     and zoom to the county.
    Dim pQueryFilter As IQueryFilter
    Dim pFeatureCursor As IFeatureCursor
    Dim pFields As IFields
    Dim pField As IField
    Dim lngIndex As Long
    Dim pFeature As IFeature
    Dim strStateFIPS As String
    Dim strCountyFIPS As String
    Dim pMxDocument As IMxDocument
    Dim pMap As IMap
    Dim pActiveView As IActiveView
    Dim pCountyEnvelope As IEnvelope
    ' State FIPS
    Set pQueryFilter = New QueryFilter
    pQueryFilter.WhereClause = "STATE_NAME = '" & _
    strStateName & "'"
    Set pFeatureCursor = pStateLayer.Search(pQueryFilter, False)
    lngIndex = pFeatureCursor.FindField("STATE_FIPS")
    Set pFeature = pFeatureCursor.NextFeature
    If pFeature Is Nothing Then
        MsgBox "Unable to find State FIPS", _
        vbCritical + vbOKOnly
        Exit Sub
    End If
    strStateFIPS = pFeature.Value(lngIndex)
    ' County FIPS
    Set pQueryFilter = New QueryFilter
    pQueryFilter.WhereClause = "STATE_FIPS = '" & strStateFIPS & _
    "' and NAME = '" & strCountyName & "'"
    Set pFeatureCursor = pCountyLayer.Search(pQueryFilter, False)
    lngIndex = pFeatureCursor.FindField("CNTY_FIPS")
    Set pFeature = pFeatureCursor.NextFeature
    If pFeature Is Nothing Then
        MsgBox "Unable to find County FIPS", _
        vbCritical + vbOKOnly
        Exit Sub
    End If
    strCountyFIPS = pFeature.Value(lngIndex)
    ' Zoom to the county
    Set pCountyEnvelope = pFeature.Extent
    Set pMxDocument = Application.Document
    Set pMap = pMxDocument.FocusMap
    Set pActiveView = pMap
    pActiveView.Extent = pCountyEnvelope.Envelope
    '
    ' (3) Set the defination for the Tract layer to
    '     only display tracts of the selected county.
    '     Also refresh the displayed view.
    Dim pFeatureLayerDefinition As IFeatureLayerDefinition
    Set pFeatureLayerDefinition = pTractLayer
    pFeatureLayerDefinition.DefinitionExpression = _
    "STCOFIPS = '" & _
    strStateFIPS & strCountyFIPS & "'"
    pTractLayer.Visible = True
    pCountyLayer.Visible = False
    pStateLayer.Visible = False
    pActiveView.Refresh
End Sub
Private Sub ClassifyMap()
    ' This procedure classifies the tract layer
    ' based on the selections on frmClassify.
    '
    ' (1) Collect the required information
    Dim strClassFieldName As String
    Dim lngClassCount As Long
    Dim pLayer As IFeatureLayer
    Dim pFeatureClass As IFeatureClass
    strClassFieldName = frmClassify.cboField
    lngClassCount = frmClassify.cboClassCount
    Set pLayer = Main.g_pTractLayer
    Set pFeatureClass = pLayer.FeatureClass
    '
    ' (2) Use a histogram to calculate class breaks
    Dim pTable As ITable
    Dim pTableHistogram As ITableHistogram
    Dim pHistogram As IHistogram
    Dim vntDataValues As Variant
    Dim vntDataFrequencies As Variant
    Set pTable = pLayer
    Set pTableHistogram = New TableHistogram
    Set pTableHistogram.Table = pTable
    pTableHistogram.Field = strClassFieldName
    Set pHistogram = pTableHistogram
    pHistogram.GetHistogram vntDataValues, vntDataFrequencies
    '
    ' (3) Setup a classification
    Dim pClassify As IClassify
    Dim dblBreakValues() As Double
    Set pClassify = New Quantile
    pClassify.SetHistogramData vntDataValues, vntDataFrequencies
    pClassify.Classify lngClassCount
    dblBreakValues = pClassify.ClassBreaks
    '
    ' (4) Build a color ramp for renderer
    Dim pColorRamp As IColorRamp
    Dim blnOK As Boolean
    Set pColorRamp = New RandomColorRamp
    pColorRamp.Size = lngClassCount
    pColorRamp.CreateRamp blnOK
    '
    ' (4) Create a ClassBreaks type renderer
    Dim pRenderer As IClassBreaksRenderer
    Dim lngIndex As Long
    Dim pColor As IColor
    Dim pEnumColors As IEnumColors
    Dim pFillSymbol As IFillSymbol
    Set pRenderer = New ClassBreaksRenderer
    pRenderer.Field = strClassFieldName
    pRenderer.BreakCount = lngClassCount
    pRenderer.MinimumBreak = dblBreakValues(0)
    For lngIndex = 0 To pRenderer.BreakCount - 1
        Set pColor = pColorRamp.Color(lngIndex)
        Set pFillSymbol = New SimpleFillSymbol
        pFillSymbol.Color = pColor
        pRenderer.Symbol(lngIndex) = pFillSymbol
        pRenderer.Break(lngIndex) = dblBreakValues(lngIndex + 1)
        If lngIndex = 0 Then
            pRenderer.Label(lngIndex) = "0 - " & _
            dblBreakValues(lngIndex + 1)
        Else
            pRenderer.Label(lngIndex) = dblBreakValues(lngIndex) _
            & " - " & dblBreakValues(lngIndex + 1)
        End If
    Next lngIndex
    '
    ' (5) Update the legend and display the thematic map
    Dim pGeoFeaturelayer As IGeoFeatureLayer
    Dim pDoc As IMxDocument
    Dim pLegendInfo As ILegendInfo
    Set pLegendInfo = pRenderer
    pLegendInfo.LegendGroup(0).Heading = strClassFieldName
    Set pGeoFeaturelayer = pLayer
    Set pGeoFeaturelayer.Renderer = pRenderer
    Set pDoc = ThisDocument
    pDoc.UpdateContents
    pDoc.ActivatedView.Refresh
End Sub
Private Sub BuildLayout()
    ' This procedure creates the layout based on
    ' user's options.
    '
    ' (1) Set the page size
    Dim pMxDocument As IMxDocument
    Dim pPageLayout As IPageLayout
    Dim pPage As IPage
    Dim pActiveView As IActiveView
    Dim dblPageWidth As Double, dblPageHeight As Double
    Set pMxDocument = Application.Document
    Set pActiveView = pMxDocument.PageLayout
    Set pPageLayout = pMxDocument.PageLayout
    Set pPage = pPageLayout.Page
    pPage.Units = esriInches
    dblPageWidth = 8.5
    dblPageHeight = 11
    pPage.PutCustomSize dblPageWidth, dblPageHeight
    '
    ' (2) Configure location of the map frame
    Dim pMap As IMap
    Dim pGraphicsContainer As IGraphicsContainer
    Dim pMapFrame As IMapFrame
    Dim pElement As IElement
    Dim pEnvelope As IEnvelope
    Set pMap = pMxDocument.FocusMap
    Set pGraphicsContainer = pPageLayout
    Set pMapFrame = pGraphicsContainer.FindFrame(pMap)
    Set pElement = pMapFrame
    Set pEnvelope = New Envelope
    pEnvelope.XMin = 0.5
    pEnvelope.XMax = 8
    pEnvelope.YMin = 4
    pEnvelope.YMax = 10.5
    pElement.Geometry = pEnvelope
    '
    ' (3) Add text and other layout elements.
    Dim pTextElement As ITextElement
    Dim pTextSymbol As ITextSymbol
    Dim pFont As IFontDisp
    Dim pID As UID
    Dim pMapSurround As IMapSurround
    Dim pMapSurroundFrame As IMapSurroundFrame
    ' Text
    If frmLayout.txtTitle > "" Then
        Set pTextElement = New TextElement
        pTextElement.Text = frmLayout.txtTitle
        Set pTextSymbol = pTextElement.Symbol
        Set pFont = pTextSymbol.Font
        pFont.Size = 24
        pTextSymbol.Font = pFont
        pTextElement.Symbol = pTextSymbol
        Set pElement = pTextElement
        Set pEnvelope = New Envelope
        pEnvelope.XMin = 0.5
        pEnvelope.XMax = 8
        pEnvelope.YMin = 3
        pEnvelope.YMax = 3.75
        pElement.Geometry = pEnvelope
        pGraphicsContainer.AddElement pTextElement, 0
    End If
    ' North Arrow
    If frmLayout.chkNorthArrow Then
        Set pEnvelope = New Envelope
        pEnvelope.XMin = 5
        pEnvelope.XMax = 8
        pEnvelope.YMin = 2
        pEnvelope.YMax = 2.75
        Set pID = New UID
        pID.Value = "esriCore.MarkerNorthArrow"
        Set pMapSurroundFrame = _
        pMapFrame.CreateSurroundFrame(pID, Nothing)
        pMapSurroundFrame.MapSurround.Name = "North Arrow"
        Set pElement = pMapSurroundFrame
        pElement.Geometry = pEnvelope
        pElement.Activate pActiveView.ScreenDisplay
        pGraphicsContainer.AddElement pElement, 0
    End If
    ' Scale
    If frmLayout.chkScale Then
        Set pEnvelope = New Envelope
        pEnvelope.XMin = 5
        pEnvelope.XMax = 8
        pEnvelope.YMin = 1
        pEnvelope.YMax = 1.75
        Set pID = New UID
        pID.Value = "esriCore.ScaleLine"
        Set pMapSurroundFrame = _
        pMapFrame.CreateSurroundFrame(pID, Nothing)
        pMapSurroundFrame.MapSurround.Name = "Scale Line"
        Set pElement = pMapSurroundFrame
        pElement.Geometry = pEnvelope
        pElement.Activate pActiveView.ScreenDisplay
        pGraphicsContainer.AddElement pElement, 0
    End If
    ' Legend
    If frmLayout.chkLegend Then
        Set pEnvelope = New Envelope
        pEnvelope.XMin = 0.5
        pEnvelope.XMax = 3.5
        pEnvelope.YMin = 1
        pEnvelope.YMax = 2.75
        Set pID = New UID
        pID.Value = "esriCore.Legend"
        Set pMapSurroundFrame = _
        pMapFrame.CreateSurroundFrame(pID, Nothing)
        pMapSurroundFrame.MapSurround.Name = "Legend"
        Set pElement = pMapSurroundFrame
        pElement.Geometry = pEnvelope
        pElement.Activate pActiveView.ScreenDisplay
        pGraphicsContainer.AddElement pElement, 0
    End If
    '
    ' (4) Unselect the layout elements and refresh the map
    Dim pGraphicsContainerSelect As IGraphicsContainerSelect
    Set pGraphicsContainerSelect = pPageLayout
    pGraphicsContainerSelect.UnselectAllElements
    pActiveView.Refresh
End Sub
Private Sub cmdCancel_Click()
    End
End Sub

Private Sub cmdOK_Click()
    ' This procedure calls other routines to create
    ' the layout.
    '
    ' (1) Change the map extent
    ZoomToCounty
    '
    ' (2) Create the thematic map
    ClassifyMap
    '
    ' (3)
    BuildLayout
    
End Sub