dsmappage.cls

使用VB和ArcObject结合的程序

630:         Set pSpatial.Geometry = m_pPageShape
631:         pSpatial.GeometryField = pGridLayer.FeatureClass.ShapeFieldName
632:         pSpatial.SpatialRel = esriSpatialRelIntersects
633:         Set pCursor = pGridLayer.Search(pSpatial, False)
634:         Set pFeature = pCursor.NextFeature
635:         Do While Not pFeature Is Nothing
636:           If pEnv Is Nothing Then
637:             Set pEnv = pFeature.Shape.Envelope
638:           Else
639:             pEnv.Union pFeature.Shape.Envelope
640:           End If
641:           Set pFeature = pCursor.NextFeature
642:         Loop
643:         Set pActive = pMap
644:         pActive.Extent = pEnv
645:         If bRefreshFlag Then pActive.Refresh
646:       End If
      
648:       Set pGridLayer = Nothing
649:     End If
650:   Next lLoop

  Exit Sub
ErrHand:
654:   MsgBox "RefreshIndicators - " & Err.Description
End Sub

Private Sub UpdateTaggedElements(pDoc As IMxDocument, sTileName As String, bRefreshFlag As Boolean, _
 pDSMapSeries As IDSMapSeries)
'Routine for updating text elements tagged as Date or Title elements
On Error GoTo ErrHand:
  Dim pGraphicsCont As IGraphicsContainer, pElemProps As IElementProperties
  Dim pTextElement As ITextElement, pActive As IActiveView, pElem As IElement
  Dim pEnv As IEnvelope, pEnv2 As IEnvelope, sText As String, bUpdate As Boolean
664:   Set pGraphicsCont = pDoc.PageLayout
665:   Set pActive = pGraphicsCont
666:   pGraphicsCont.Reset
667:   Set pElemProps = pGraphicsCont.Next
668:   Do While Not pElemProps Is Nothing
669:     If TypeOf pElemProps Is ITextElement Then
670:       bUpdate = True
      Select Case pElemProps.Name
      Case "DSMAPBOOK - DATE"
673:         sText = Format(Date, "mmm dd, yyyy")
      Case "DSMAPBOOK - TITLE"
675:         sText = sTileName
      Case "DSMAPBOOK - PAGENUMBER"
677:         sText = CStr(m_lPageNumber)
      Case "DSMAPBOOK - EXTRAITEM"
679:         sText = GetExtraItemValue(pDoc, sTileName, pElemProps.Type, pDSMapSeries)
      Case Else
681:         bUpdate = False
682:       End Select
      
684:       If bUpdate Then
685:         Set pElem = pElemProps
686:         Set pEnv = New Envelope
687:         pElem.QueryBounds pActive.ScreenDisplay, pEnv
688:         Set pTextElement = pElemProps
689:         pTextElement.Text = sText
690:         pGraphicsCont.UpdateElement pTextElement
691:         Set pEnv2 = New Envelope
692:         pElem.QueryBounds pActive.ScreenDisplay, pEnv2
693:         pEnv.Union pEnv2
694:         If bRefreshFlag Then pActive.PartialRefresh esriViewGraphics, Nothing, pEnv
695:       End If
696:     End If
697:     Set pElemProps = pGraphicsCont.Next
698:   Loop

  Exit Sub
ErrHand:
702:   MsgBox "UpdateTaggedElements - " & Erl & " - " & Err.Description
End Sub

Private Function GetExtraItemValue(pDoc As IMxDocument, sTileName As String, sFieldName As String, _
 pSeriesProps As IDSMapSeriesProps) As String
On Error GoTo ErrHand:
  Dim pIndexLayer As IFeatureLayer, pQuery As IQueryFilter, pFCursor As IFeatureCursor
  Dim pFeat As IFeature, lIndex As Long, pMap As IMap, lIndex2 As Long
  
  'Find the data frame
712:   Set pMap = FindDataFrame(pDoc, pSeriesProps.DataFrameName)
713:   If pMap Is Nothing Then
714:     MsgBox "Could not find map in GetExtraItem routine!!!"
715:     GetExtraItemValue = "missing"
    Exit Function
717:   End If
  
  'Find the Index layer
720:   Set pIndexLayer = FindLayer(pSeriesProps.IndexLayerName, pMap)
721:   If pIndexLayer Is Nothing Then
722:     MsgBox "Could not find index layer (" & pSeriesProps.IndexLayerName & ") in GetExtraItemValue routine!!!"
723:     GetExtraItemValue = "missing"
    Exit Function
725:   End If
  
  'Find the field in the index layer
728:   lIndex = pIndexLayer.FeatureClass.FindField(sFieldName)
729:   If lIndex < 0 Then
730:     MsgBox "Could not find the field (" & sFieldName & ") you tagged the item with in the index layer!!!"
731:     GetExtraItemValue = "missing"
    Exit Function
733:   End If
  
  'Find the tile name field in the index layer
736:   lIndex2 = pIndexLayer.FeatureClass.FindField(pSeriesProps.IndexFieldName)
737:   If lIndex2 < 0 Then
738:     MsgBox "Could not find tile name field (" & pSeriesProps.IndexFieldName & ") in the index layer!!!"
739:     GetExtraItemValue = "missing"
    Exit Function
741:   End If
  
  'Create the query object then select the appropriate tile from the index layer
744:   Set pQuery = New QueryFilter
745:   pQuery.WhereClause = pSeriesProps.IndexFieldName & " = '" & sTileName & "'"
746:   Set pFCursor = pIndexLayer.Search(pQuery, False)
747:   Set pFeat = pFCursor.NextFeature
748:   If pFeat Is Nothing Then
749:     MsgBox "Could not select the tile from the index layer to tag with Extra Item!!!"
750:     GetExtraItemValue = "missing"
    Exit Function
752:   End If
  
  'Send back the value of the field
755:   If IsNull(pFeat.Value(lIndex)) Then
756:     GetExtraItemValue = " "
757:   Else
758:     GetExtraItemValue = pFeat.Value(lIndex)
759:   End If

  Exit Function
ErrHand:
763:   MsgBox "GetExtraItemValue - " & Erl & " - " & Err.Description
End Function

Private Sub CreateClipElement(pDoc As IMxDocument, pActive As IActiveView, _
 pFeatLayer As IFeatureLayer)
'Added 6/18/03 to support cross hatching of area outside the clip
On Error GoTo ErrHand:
  Dim pPoly As IPolygon, pTopoOp As ITopologicalOperator
  Dim pGraphs As IGraphicsContainer, pElem As IElement, pNewElem As IElement
  Dim pNewPoly As IPointCollection, pElemProps As IElementProperties
  Dim pFinalGeom As IPolygon, pPoly2 As IPolygon, lLoop As Long
  
  'Search for an existing clip element and delete it when found
'  Set pGraphs = pDoc.FocusMap
777:   Set pGraphs = pActive
778:   pGraphs.Reset
779:   Set pElemProps = pGraphs.Next
780:   Do While Not pElemProps Is Nothing
781:     If TypeOf pElemProps Is IPolygonElement Then
782:       If UCase(pElemProps.Name) = "DSMAPBOOK CLIP ELEMENT" Then
783:         pGraphs.DeleteElement pElemProps
784:         Exit Do
785:       End If
786:     End If
787:     Set pElemProps = pGraphs.Next
788:   Loop
  
790:   Set pElem = New PolygonElement
791:   Set pPoly = m_pPageShape
792:   Set pNewElem = New PolygonElement
793:   Set pNewPoly = New Polygon
794:   pNewPoly.AddPoint pFeatLayer.AreaOfInterest.LowerLeft
795:   pNewPoly.AddPoint pFeatLayer.AreaOfInterest.UpperLeft
796:   pNewPoly.AddPoint pFeatLayer.AreaOfInterest.UpperRight
797:   pNewPoly.AddPoint pFeatLayer.AreaOfInterest.LowerRight
798:   Set pPoly2 = pNewPoly
799:   pPoly2.Close
  
  Dim pLineSym As ISimpleLineSymbol, pLineFillSym As ILineFillSymbol
  Dim pFillShape As IFillShapeElement, pColor As IGrayColor
803:   Set pColor = New GrayColor
804:   pColor.Level = 150
805:   Set pLineSym = New SimpleLineSymbol
806:   pLineSym.Color = pColor
807:   Set pLineFillSym = New LineFillSymbol
808:   pLineFillSym.Angle = 45
809:   pLineFillSym.Color = pColor
810:   pLineFillSym.Outline = pLineSym
811:   Set pLineFillSym.LineSymbol = pLineSym
812:   pLineFillSym.Separation = 5
  
814:   Set pTopoOp = pPoly2
815:   Set pFinalGeom = pTopoOp.Difference(pPoly)
816:   pNewElem.Geometry = pFinalGeom
817:   Set pFillShape = pNewElem
818:   pFillShape.Symbol = pLineFillSym
819:   Set pElemProps = pFillShape
820:   pElemProps.Name = "DSMapBook Clip Element"
821:   pGraphs.AddElement pNewElem, 0

  Exit Sub
ErrHand:
825:   MsgBox "CreateClipElement - " & Erl & " - " & Err.Description
End Sub

Private Sub SetMapExtent(pSeriesOpts As IDSMapSeriesOptions, pActiveView As IActiveView)
On Error GoTo ErrHand:
'Routine for calculating the extent of the tile to be displayed in the layout
  Dim dMult As Double, pEnv As IEnvelope, pMap As IMap
  
833:   Set pMap = pActiveView
  Select Case pSeriesOpts.ExtentType
  Case 0  'Variable
836:     If pSeriesOpts.Margin > 0 Then
837:       Set pEnv = m_pPageShape.Envelope
      Select Case pSeriesOpts.MarginType
      Case 0  'Percent
840:         dMult = 1 + (pSeriesOpts.Margin / 100)
841:         pEnv.Expand dMult, dMult, True
      Case 1  'mapunits
843:         pEnv.Expand pSeriesOpts.Margin, pSeriesOpts.Margin, False
844:       End Select
845:       pActiveView.Extent = pEnv
846:     Else
847:       pActiveView.Extent = m_pPageShape.Envelope
848:     End If
  Case 1  'Fixed
850:     pActiveView.Extent = m_pPageShape.Envelope
851:     pMap.MapScale = pSeriesOpts.FixedScale
  Case 2  'DataDriven
853:     pActiveView.Extent = m_pPageShape.Envelope
854:     pMap.MapScale = m_dPageScale
855:   End Select

  Exit Sub
ErrHand:
859:   MsgBox "SetMapExtent - " & Err.Description
End Sub

Public Function FindDataFrame(pDoc As IMxDocument, sFrameName As String) As IMap
On Error GoTo ErrHand:
  Dim lLoop As Long, pMap As IMap
  
  'Find the data frame
867:   For lLoop = 0 To pDoc.Maps.Count - 1
868:     If pDoc.Maps.Item(lLoop).Name = sFrameName Then
869:       Set pMap = pDoc.Maps.Item(lLoop)
870:       Exit For
871:     End If
872:   Next lLoop
873:   If Not pMap Is Nothing Then
874:     Set FindDataFrame = pMap
875:   End If

  Exit Function
ErrHand:
879:   MsgBox "FindDataFrame - " & Err.Description
End Function

Private Function CompositeLayer1(pCompLayer As ICompositeLayer, sIndexName As String) As IFeatureLayer
On Error GoTo ErrHand:
  Dim lLoop As Long, pFeatLayer As IFeatureLayer
885:   For lLoop = 0 To pCompLayer.Count - 1
886:     If TypeOf pCompLayer.Layer(lLoop) Is ICompositeLayer Then
887:       Set pFeatLayer = CompositeLayer1(pCompLayer.Layer(lLoop), sIndexName)
888:       If Not pFeatLayer Is Nothing Then
889:         Set CompositeLayer1 = pFeatLayer
        Exit Function
891:       End If
892:     Else
893:       If pCompLayer.Layer(lLoop).Name = sIndexName Then
894:         Set CompositeLayer1 = pCompLayer.Layer(lLoop)
        Exit Function
896:       End If
897:     End If
898:   Next lLoop
  
900:   Set CompositeLayer1 = Nothing

  Exit Function
ErrHand:
904:   MsgBox "CompositeLayer - " & Err.Description
End Function

Private Function FindLayer(sLayerName As String, pMap As IMap) As IFeatureLayer
' Routine for finding a layer based on a name and then returning that layer as
' a IFeatureLayer
On Error GoTo ErrHand:
  Dim lLoop As Integer
  Dim pFLayer As IFeatureLayer

914:   For lLoop = 0 To pMap.LayerCount - 1
915:     If TypeOf pMap.Layer(lLoop) Is ICompositeLayer Then
916:       Set pFLayer = FindCompositeLayer(pMap.Layer(lLoop), sLayerName, pMap)
917:       If Not pFLayer Is Nothing Then
918:         Set FindLayer = pFLayer
        Exit Function
920:       End If
921:     ElseIf TypeOf pMap.Layer(lLoop) Is IFeatureLayer Then
922:       Set pFLayer = pMap.Layer(lLoop)
923:       If UCase(pFLayer.Name) = UCase(sLayerName) Then
924:         Set FindLayer = pFLayer
        Exit Function
926:       End If
927:     End If
928:   Next lLoop
  
930:   Set FindLayer = Nothing
  
  Exit Function
  
ErrHand:
935:   MsgBox "FindLayer - " & Erl & " - " & Err.Description
End Function

Private Function FindCompositeLayer(pCompLayer As ICompositeLayer, sLayerName As String, pMap As IMap) As IFeatureLayer
On Error GoTo ErrHand:
  Dim lLoop As Long, pFeatLayer As IFeatureLayer
941:   For lLoop = 0 To pCompLayer.Count - 1
942:     If TypeOf pCompLayer.Layer(lLoop) Is ICompositeLayer Then
943:       Set pFeatLayer = FindCompositeLayer(pCompLayer.Layer(lLoop), sLayerName, pMap)
944:       If Not pFeatLayer Is Nothing Then
945:         Set FindCompositeLayer = pFeatLayer
        Exit Function
947:       End If
948:     Else
949:       If TypeOf pCompLayer.Layer(lLoop) Is IFeatureLayer Then
950:         If UCase(pCompLayer.Layer(lLoop).Name) = UCase(sLayerName) Then
951:           Set FindCompositeLayer = pCompLayer.Layer(lLoop)
          Exit Function
953:         End If
954:       End If
955:     End If
956:   Next lLoop

  Exit Function
ErrHand:
960:   MsgBox "CompositeLayer - " & Erl & " - " & Err.Description
End Function