dsmappage.cls

一个不错的插件

697:       Set pGridSel = pGridLayer
698:       Set pQuery = New QueryFilter
699:       pQuery.WhereClause = pSeriesProps.IndexFieldName & " = '" & m_sPageName & "'"
700:       pGridSel.Clear
701:       pGridSel.SelectFeatures pQuery, esriSelectionResultNew, True
        
703:       If pMap.Name = "Global Indicator" Then
704:         Set pActive = pDoc.Maps.Item(lLoop)
705:         If bRefreshFlag Then pActive.Refresh
706:       ElseIf pMap.Name = "Local Indicator" Then
707:         Set pSpatial = New SpatialFilter
708:         Set pSpatial.Geometry = m_pPageShape
709:         pSpatial.GeometryField = pGridLayer.FeatureClass.ShapeFieldName
710:         pSpatial.SpatialRel = esriSpatialRelIntersects
711:         Set pCursor = pGridLayer.Search(pSpatial, False)
712:         Set pFeature = pCursor.NextFeature
713:         Do While Not pFeature Is Nothing
714:           If pEnv Is Nothing Then
715:             Set pEnv = pFeature.Shape.Envelope
716:           Else
717:             pEnv.Union pFeature.Shape.Envelope
718:           End If
719:           Set pFeature = pCursor.NextFeature
720:         Loop
721:         Set pActive = pMap
722:         pActive.Extent = pEnv
723:         If bRefreshFlag Then pActive.Refresh
724:       End If
725:       Set pSelEvents = pMap
726:       pSelEvents.SelectionChanged
      
728:       Set pGridLayer = Nothing
729:     End If
730:   Next lLoop

  Exit Sub
ErrHand:
734:   MsgBox "RefreshIndicators - " & Erl & " - " & 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
744:   Set pGraphicsCont = pDoc.PageLayout
745:   Set pActive = pGraphicsCont
746:   pGraphicsCont.Reset
747:   Set pElemProps = pGraphicsCont.Next
748:   Do While Not pElemProps Is Nothing
749:     If TypeOf pElemProps Is ITextElement Then
750:       bUpdate = True
      Select Case pElemProps.Name
      Case "DSMAPBOOK - DATE"
753:         sText = Format(Date, "mmm dd, yyyy")
      Case "DSMAPBOOK - TITLE"
755:         sText = sTileName
      Case "DSMAPBOOK - PAGENUMBER"
757:         sText = CStr(m_lPageNumber)
      Case "DSMAPBOOK - EXTRAITEM"
759:         sText = GetExtraItemValue(pDoc, sTileName, pElemProps.Type, pDSMapSeries)
      Case Else
761:         bUpdate = False
762:       End Select
      
764:       If bUpdate Then
765:         Set pElem = pElemProps
766:         Set pEnv = New Envelope
767:         pElem.QueryBounds pActive.ScreenDisplay, pEnv
768:         Set pTextElement = pElemProps
769:         pTextElement.Text = sText
770:         pGraphicsCont.UpdateElement pTextElement
771:         Set pEnv2 = New Envelope
772:         pElem.QueryBounds pActive.ScreenDisplay, pEnv2
773:         pEnv.Union pEnv2
774:         If bRefreshFlag Then pActive.PartialRefresh esriViewGraphics, Nothing, pEnv
775:       End If
776:     End If
777:     Set pElemProps = pGraphicsCont.Next
778:   Loop

  Exit Sub
ErrHand:
782:   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
792:   Set pMap = FindDataFrame(pDoc, pSeriesProps.DataFrameName)
793:   If pMap Is Nothing Then
794:     MsgBox "Could not find map in GetExtraItem routine!!!"
795:     GetExtraItemValue = "missing"
    Exit Function
797:   End If
  
  'Find the Index layer
800:   Set pIndexLayer = FindLayer(pSeriesProps.IndexLayerName, pMap)
801:   If pIndexLayer Is Nothing Then
802:     MsgBox "Could not find index layer (" & pSeriesProps.IndexLayerName & ") in GetExtraItemValue routine!!!"
803:     GetExtraItemValue = "missing"
    Exit Function
805:   End If
  
  'Find the field in the index layer
808:   lIndex = pIndexLayer.FeatureClass.FindField(sFieldName)
809:   If lIndex < 0 Then
810:     MsgBox "Could not find the field (" & sFieldName & ") you tagged the item with in the index layer!!!"
811:     GetExtraItemValue = "missing"
    Exit Function
813:   End If
  
  'Find the tile name field in the index layer
816:   lIndex2 = pIndexLayer.FeatureClass.FindField(pSeriesProps.IndexFieldName)
817:   If lIndex2 < 0 Then
818:     MsgBox "Could not find tile name field (" & pSeriesProps.IndexFieldName & ") in the index layer!!!"
819:     GetExtraItemValue = "missing"
    Exit Function
821:   End If
  
  'Create the query object then select the appropriate tile from the index layer
824:   Set pQuery = New QueryFilter
825:   pQuery.WhereClause = pSeriesProps.IndexFieldName & " = '" & sTileName & "'"
826:   Set pFCursor = pIndexLayer.Search(pQuery, False)
827:   Set pFeat = pFCursor.NextFeature
828:   If pFeat Is Nothing Then
829:     MsgBox "Could not select the tile from the index layer to tag with Extra Item!!!"
830:     GetExtraItemValue = "missing"
    Exit Function
832:   End If
  
  'Send back the value of the field
835:   If IsNull(pFeat.Value(lIndex)) Then
836:     GetExtraItemValue = " "
837:   Else
838:     GetExtraItemValue = pFeat.Value(lIndex)
839:   End If

  Exit Function
ErrHand:
843:   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
857:   Set pGraphs = pActive
858:   pGraphs.Reset
859:   Set pElemProps = pGraphs.Next
860:   Do While Not pElemProps Is Nothing
861:     If TypeOf pElemProps Is IPolygonElement Then
862:       If UCase(pElemProps.Name) = "DSMAPBOOK CLIP ELEMENT" Then
863:         pGraphs.DeleteElement pElemProps
864:         Exit Do
865:       End If
866:     End If
867:     Set pElemProps = pGraphs.Next
868:   Loop
  
870:   Set pElem = New PolygonElement
871:   Set pPoly = m_pPageShape
872:   Set pNewElem = New PolygonElement
873:   Set pNewPoly = New Polygon
874:   pNewPoly.AddPoint pFeatLayer.AreaOfInterest.LowerLeft
875:   pNewPoly.AddPoint pFeatLayer.AreaOfInterest.UpperLeft
876:   pNewPoly.AddPoint pFeatLayer.AreaOfInterest.UpperRight
877:   pNewPoly.AddPoint pFeatLayer.AreaOfInterest.LowerRight
878:   Set pPoly2 = pNewPoly
879:   pPoly2.Close
  
  Dim pLineSym As ISimpleLineSymbol, pLineFillSym As ILineFillSymbol
  Dim pFillShape As IFillShapeElement, pColor As IGrayColor
883:   Set pColor = New GrayColor
884:   pColor.Level = 150
885:   Set pLineSym = New SimpleLineSymbol
886:   pLineSym.Color = pColor
887:   Set pLineFillSym = New LineFillSymbol
888:   pLineFillSym.Angle = 45
889:   pLineFillSym.Color = pColor
890:   pLineFillSym.Outline = pLineSym
891:   Set pLineFillSym.LineSymbol = pLineSym
892:   pLineFillSym.Separation = 5
  
894:   Set pTopoOp = pPoly2
895:   Set pFinalGeom = pTopoOp.Difference(pPoly)
896:   pNewElem.Geometry = pFinalGeom
897:   Set pFillShape = pNewElem
898:   pFillShape.Symbol = pLineFillSym
899:   Set pElemProps = pFillShape
900:   pElemProps.Name = "DSMapBook Clip Element"
901:   pGraphs.AddElement pNewElem, 0

  Exit Sub
ErrHand:
905:   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
  
913:   Set pMap = pActiveView
  Select Case pSeriesOpts.ExtentType
  Case 0  'Variable
916:     If pSeriesOpts.Margin > 0 Then
917:       Set pEnv = m_pPageShape.Envelope
      Select Case pSeriesOpts.MarginType
      Case 0  'Percent
920:         dMult = 1 + (pSeriesOpts.Margin / 100)
921:         pEnv.Expand dMult, dMult, True
      Case 1  'mapunits
923:         pEnv.Expand pSeriesOpts.Margin, pSeriesOpts.Margin, False
924:       End Select
925:       pActiveView.Extent = pEnv
926:     Else
927:       pActiveView.Extent = m_pPageShape.Envelope
928:     End If
  Case 1  'Fixed
930:     pActiveView.Extent = m_pPageShape.Envelope
931:     pMap.MapScale = pSeriesOpts.FixedScale
  Case 2  'DataDriven
933:     pActiveView.Extent = m_pPageShape.Envelope
934:     pMap.MapScale = m_dPageScale
935:   End Select

  Exit Sub
ErrHand:
939:   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
947:   For lLoop = 0 To pDoc.Maps.Count - 1
948:     If pDoc.Maps.Item(lLoop).Name = sFrameName Then
949:       Set pMap = pDoc.Maps.Item(lLoop)
950:       Exit For
951:     End If
952:   Next lLoop
953:   If Not pMap Is Nothing Then
954:     Set FindDataFrame = pMap
955:   End If

  Exit Function
ErrHand:
959:   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
965:   For lLoop = 0 To pCompLayer.Count - 1
966:     If TypeOf pCompLayer.Layer(lLoop) Is ICompositeLayer Then
967:       Set pFeatLayer = CompositeLayer1(pCompLayer.Layer(lLoop), sIndexName)
968:       If Not pFeatLayer Is Nothing Then
969:         Set CompositeLayer1 = pFeatLayer
        Exit Function
971:       End If
972:     Else
973:       If pCompLayer.Layer(lLoop).Name = sIndexName Then
974:         Set CompositeLayer1 = pCompLayer.Layer(lLoop)
        Exit Function
976:       End If
977:     End If
978:   Next lLoop
  
980:   Set CompositeLayer1 = Nothing

  Exit Function
ErrHand:
984:   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

994:   For lLoop = 0 To pMap.LayerCount - 1
995:     If TypeOf pMap.Layer(lLoop) Is ICompositeLayer Then
996:       Set pFLayer = FindCompositeLayer(pMap.Layer(lLoop), sLayerName, pMap)
997:       If Not pFLayer Is Nothing Then
998:         Set FindLayer = pFLayer
        Exit Function
1000:       End If
1001:     ElseIf TypeOf pMap.Layer(lLoop) Is IFeatureLayer Then
1002:       Set pFLayer = pMap.Layer(lLoop)
1003:       If UCase(pFLayer.Name) = UCase(sLayerName) Then
1004:         Set FindLayer = pFLayer
        Exit Function
1006:       End If
1007:     End If
1008:   Next lLoop
  
1010:   Set FindLayer = Nothing
  
  Exit Function
  
ErrHand:
1015:   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
1021:   For lLoop = 0 To pCompLayer.Count - 1
1022:     If TypeOf pCompLayer.Layer(lLoop) Is ICompositeLayer Then
1023:       Set pFeatLayer = FindCompositeLayer(pCompLayer.Layer(lLoop), sLayerName, pMap)
1024:       If Not pFeatLayer Is Nothing Then
1025:         Set FindCompositeLayer = pFeatLayer
        Exit Function
1027:       End If
1028:     Else
1029:       If TypeOf pCompLayer.Layer(lLoop) Is IFeatureLayer Then
1030:         If UCase(pCompLayer.Layer(lLoop).Name) = UCase(sLayerName) Then
1031:           Set FindCompositeLayer = pCompLayer.Layer(lLoop)
          Exit Function
1033:         End If
1034:       End If
1035:     End If
1036:   Next lLoop

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