dsmappage.cls

使用VB和ArcObject结合的程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "DSMapPage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

' Copyright 1995-2004 ESRI

' All rights reserved under the copyright laws of the United States.

' You may freely redistribute and use this sample code, with or without modification.

' Disclaimer: THE SAMPLE CODE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED 
' WARRANTIES, INCLUDING THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 
' FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ESRI OR 
' CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, 
' OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
' SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
' INTERRUPTION) SUSTAINED BY YOU OR A THIRD PARTY, HOWEVER CAUSED AND ON ANY 
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ARISING IN ANY 
' WAY OUT OF THE USE OF THIS SAMPLE CODE, EVEN IF ADVISED OF THE POSSIBILITY OF 
' SUCH DAMAGE.

' For additional information contact: Environmental Systems Research Institute, Inc.

' Attn: Contracts Dept.

' 380 New York Street

' Redlands, California, U.S.A. 92373 

' Email: [e-mail]

Option Explicit

Implements IDSMapPage
Implements IPersistVariant

Dim m_PageItemColl As Collection
Dim m_sPageName As String
Dim m_bPrintPage As Boolean
Dim m_dPageRotation As Double
Dim m_dPageScale As Double
Dim m_dLastOutputted As Date
Dim m_pPageShape As IPolygon
Dim m_lPageNumber As Long

Private Sub Class_Initialize()
16:   Set m_PageItemColl = New Collection
End Sub

Private Sub Class_Terminate()
20:   Set m_PageItemColl = Nothing
End Sub

Private Sub IDSMapPage_AddPageItem(ByVal PageItem As IElement)
24:   m_PageItemColl.Add PageItem
End Sub

Private Sub IDSMapPage_DrawPage(pDoc As IMxDocument, pDSMapSeries As IDSMapSeries, bRefreshFlag As Boolean)
On Error GoTo ErrHand:
  Dim pMap As IMap, lLoop As Long, pEnv As IEnvelope, lIndex As Long
  Dim pFeatLayer As IFeatureLayer, pActive As IActiveView, pTempLayer As ILayer
  Dim pGraphicsCont As IGraphicsContainer, pTempColl As Collection, pElemProps As IElementProperties
  Dim pTextSym As ISimpleTextSymbol, pClone As IClone, pSeriesOpts2 As IDSMapSeriesOptions2
  Dim pSeriesProps As IDSMapSeriesProps, pSeriesOpts As IDSMapSeriesOptions
34:   Set pSeriesProps = pDSMapSeries
  
  'Find the data frame
37:   Set pMap = FindDataFrame(pDoc, pSeriesProps.DataFrameName)
38:   If pMap Is Nothing Then
39:     MsgBox "Could not find map in DrawPage routine!!!"
    Exit Sub
41:   End If
  
  'Find the Index layer
44:   For lLoop = 0 To pMap.LayerCount - 1
45:     If TypeOf pMap.Layer(lLoop) Is ICompositeLayer Then
46:       Set pFeatLayer = CompositeLayer1(pMap.Layer(lLoop), pSeriesProps.IndexLayerName)
47:       If Not pFeatLayer Is Nothing Then Exit For
48:     Else
49:       If pMap.Layer(lLoop).Name = pSeriesProps.IndexLayerName Then
50:         Set pFeatLayer = pMap.Layer(lLoop)
51:         Exit For
52:       End If
53:     End If
54:   Next lLoop
55:   If pFeatLayer Is Nothing Then
56:     MsgBox "Could not find index layer in DrawPage routine!!!"
    Exit Sub
58:   End If
  
  'Switch to the Layout view if we are not already there
61:   If Not TypeOf pDoc.ActiveView Is IPageLayout Then
62:     Set pDoc.ActiveView = pDoc.PageLayout
63:   End If
  
  'Remove any previous neighbor labels.
66:   Set pGraphicsCont = pDoc.ActiveView
67:   pGraphicsCont.Reset
68:   Set pTempColl = New Collection
69:   Set pElemProps = pGraphicsCont.Next
70:   Do While Not pElemProps Is Nothing
71:     If pElemProps.Name = "DSMAPBOOK TEXT" Then
72:       pTempColl.Add pElemProps
73:     End If
74:     Set pElemProps = pGraphicsCont.Next
75:   Loop
76:   For lLoop = 1 To pTempColl.Count
77:     pGraphicsCont.DeleteElement pTempColl.Item(lLoop)
78:   Next lLoop
79:   Set pTempColl = Nothing
  
  'Rotate the frame if necessary
82:   Set pActive = pMap
83:   Set pSeriesOpts = pSeriesProps
84:   Set pSeriesOpts2 = pSeriesOpts
85:   If pSeriesOpts.RotateFrame Then
'    If m_dPageRotation > 0 Then
87:       pActive.ScreenDisplay.DisplayTransformation.Rotation = m_dPageRotation
'    End If
89:   End If
  
  'Set the extent and possibly the scale for the map
92:   SetMapExtent pSeriesOpts, pActive
    
  'Set the clip property
  'Updated 6/18/03 to support cross hatching of area outside the clip
  Select Case pSeriesOpts2.ClipData
  Case 0   'No clipping
'    pMap.ClipGeometry = Nothing
  Case 1   'Clipping only
100:     pMap.ClipGeometry = m_pPageShape
  Case 2   'clipping with cross hatching of area outside the clip
102:     pMap.ClipGeometry = Nothing
103:     CreateClipElement pDoc, pActive, pFeatLayer
104:   End Select
  
  'Check for indicator maps and update those also
107:   RefreshIndicators pDoc, pSeriesProps, bRefreshFlag
  
  'Check for Date and Title elements
110:   UpdateTaggedElements pDoc, m_sPageName, bRefreshFlag, pDSMapSeries
  
  'Label neighboring tiles if necessary
113:   If pSeriesOpts.LabelNeighbors Then
114:     Set pClone = pSeriesOpts.LabelSymbol
115:     Set pTextSym = pClone.Clone
116:     lIndex = pFeatLayer.FeatureClass.FindField(pSeriesProps.IndexFieldName)
117:     If lIndex >= 0 Then
118:       LabelNeighbors pDoc, pFeatLayer, pTextSym, lIndex, pSeriesProps.DataFrameName
119:     End If
120:   End If
  
122:   If bRefreshFlag Then
123:     pDoc.ActiveView.Refresh
124:   End If

  Exit Sub
ErrHand:
128:   MsgBox "IDSMapPage_DrawPage - " & Erl & " - " & Err.Description
End Sub

Private Function IDSMapPage_IndexPage(pIndexLayer As IFeatureLayer, sFieldName As String) As Collection
On Error GoTo ErrHand:
  Dim pFilter As ISpatialFilter, pIndex As Collection, lFieldIndex As Long
  Dim pCursor As IFeatureCursor, pFeat As IFeature, sValue As String, lLoop As Long
  
  'Check for a valid index layer
137:   Set IDSMapPage_IndexPage = Nothing
138:   If pIndexLayer Is Nothing Then
139:     MsgBox "You did not send a valid index layer to the IndexPage function!!"
    Exit Function
141:   End If
  
  'Check for a valid field name
144:   If sFieldName = "" Or sFieldName = " " Then
145:     MsgBox "You did not send a valid field name to the IndexPage function!!"
    Exit Function
147:   End If
  
  'Check for field name in the layer
150:   lFieldIndex = pIndexLayer.FeatureClass.FindField(sFieldName)
151:   If lFieldIndex < 0 Then
152:     MsgBox "Could not find field name in the index layer of the IndexPage function!!"
    Exit Function
154:   End If
  
  'Perform the query of the index layer using the page shape
157:   Set pFilter = New SpatialFilter
158:   pFilter.AddField sFieldName
159:   pFilter.WhereClause = sFieldName & " <> '' and " & sFieldName & " <> ' '"
160:   Set pFilter.Geometry = m_pPageShape
161:   pFilter.GeometryField = pIndexLayer.FeatureClass.ShapeFieldName
162:   pFilter.SpatialRel = esriSpatialRelIntersects
163:   Set pCursor = pIndexLayer.Search(pFilter, True)
  
  'Populate the collection with the results of the query
166:   Set pIndex = New Collection
167:   Set pFeat = pCursor.NextFeature
168:   Do While Not pFeat Is Nothing
169:     sValue = pFeat.Value(lFieldIndex)
170:     If pIndex.Count > 0 Then
171:       For lLoop = 1 To pIndex.Count
172:         If sValue < pIndex.Item(lLoop) Then
173:           pIndex.Add sValue, sValue, lLoop
174:           Exit For
175:         ElseIf sValue = pIndex.Item(lLoop) Then
176:           Exit For
177:         End If
178:         If lLoop = pIndex.Count Then
179:           pIndex.Add sValue, sValue
180:         End If
181:       Next lLoop
182:     Else
183:       pIndex.Add sValue, sValue
184:     End If
    
186:     Set pFeat = pCursor.NextFeature
187:   Loop
  
189:   Set IDSMapPage_IndexPage = pIndex

  Exit Function
  
ErrHand:
194:   MsgBox "IDSMapPage_IndexPage - " & Err.Description
End Function

Private Property Let IDSMapPage_LastOutputted(RHS As Date)
198:  m_dLastOutputted = RHS
End Property

Private Property Get IDSMapPage_LastOutputted() As Date
202:   IDSMapPage_LastOutputted = m_dLastOutputted
End Property

Private Property Get IDSMapPage_PageItem(Index As Long) As IElement
206:   If Index > -1 And Index < m_PageItemColl.Count Then
207:     Set IDSMapPage_PageItem = m_PageItemColl.Item(Index + 1)
208:   Else
209:     Set IDSMapPage_PageItem = Nothing
210:   End If
End Property

Private Property Get IDSMapPage_PageItemCount() As Long
214:   IDSMapPage_PageItemCount = m_PageItemColl.Count
End Property

Private Property Let IDSMapPage_PageName(RHS As String)
218:   m_sPageName = RHS
End Property

Private Property Get IDSMapPage_PageName() As String
222:   IDSMapPage_PageName = m_sPageName
End Property

Private Property Let IDSMapPage_EnablePage(RHS As Boolean)
226:   m_bPrintPage = RHS
End Property

Private Property Get IDSMapPage_EnablePage() As Boolean
230:   IDSMapPage_EnablePage = m_bPrintPage
End Property

Private Property Let IDSMapPage_PageNumber(RHS As Long)
234:   m_lPageNumber = RHS
End Property

Private Property Get IDSMapPage_PageNumber() As Long
238:   IDSMapPage_PageNumber = m_lPageNumber
End Property

Private Property Let IDSMapPage_PageRotation(RHS As Double)
242:   m_dPageRotation = RHS
End Property

Private Property Get IDSMapPage_PageRotation() As Double
246:   IDSMapPage_PageRotation = m_dPageRotation
End Property

Private Property Let IDSMapPage_PageScale(RHS As Double)
250:   m_dPageScale = RHS
End Property

Private Property Get IDSMapPage_PageScale() As Double
254:   IDSMapPage_PageScale = m_dPageScale
End Property

Private Property Set IDSMapPage_PageShape(RHS As IPolygon)
258:   Set m_pPageShape = RHS
End Property

Private Property Get IDSMapPage_PageShape() As IPolygon
262:   Set IDSMapPage_PageShape = m_pPageShape
End Property

Private Sub IDSMapPage_RemovePageItem(Index As Long)
266:   If Index > -1 And Index < m_PageItemColl.Count Then
267:     m_PageItemColl.Remove Index + 1
268:   End If
End Sub

Private Property Get IPersistVariant_ID() As esriSystem.IUID
  Dim id As New UID
273:   id = "DSMapBookPrj.DSMapPage"
274:   Set IPersistVariant_ID = id
End Property

Private Sub IPersistVariant_Load(ByVal Stream As esriSystem.IVariantStream)
'Load the persisted parameters of the renderer
On Error GoTo ErrHand:
  Dim lLoop As Long, lCount As Long, pElem As IElement, sFirstItem As String
  Dim lPropCount As Long
  
  'Added 2/18/04 to make the list of persisted properties more dynamic
284:   sFirstItem = Stream.Read
285:   If UCase(Left(sFirstItem, 18)) = "PAGEPROPERTYCOUNT-" Then
286:     lPropCount = Mid(sFirstItem, 19) - 1
287:     m_sPageName = Stream.Read
288:   Else
289:     lPropCount = 5
290:     m_sPageName = sFirstItem
291:   End If
    
  'Original page properties
294:   m_bPrintPage = Stream.Read