dsmappage.cls

一个不错的插件

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 2006 ESRI
'
' All rights reserved under the copyright laws of the United States
' and applicable international laws, treaties, and conventions.
'
' You may freely redistribute and use this sample code, with or
' without modification, provided you include the original copyright
' notice and use restrictions.
'
' See use restrictions at /arcgis/developerkit/userestrictions.

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()
44:   Set m_PageItemColl = New Collection
End Sub

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

Private Sub IDSMapPage_AddPageItem(ByVal PageItem As IElement)
52:   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
  Dim pSeriesOpts3 As IDSMapSeriesOptions3
63:   Set pSeriesProps = pDSMapSeries
  
  'Find the data frame
66:   Set pMap = FindDataFrame(pDoc, pSeriesProps.DataFrameName)
67:   If pMap Is Nothing Then
68:     MsgBox "Could not find map in DrawPage routine!!!"
    Exit Sub
70:   End If
  
  'Find the Index layer
73:   For lLoop = 0 To pMap.LayerCount - 1
74:     If TypeOf pMap.Layer(lLoop) Is ICompositeLayer Then
75:       Set pFeatLayer = CompositeLayer1(pMap.Layer(lLoop), pSeriesProps.IndexLayerName)
76:       If Not pFeatLayer Is Nothing Then Exit For
77:     Else
78:       If pMap.Layer(lLoop).Name = pSeriesProps.IndexLayerName Then
79:         Set pFeatLayer = pMap.Layer(lLoop)
80:         Exit For
81:       End If
82:     End If
83:   Next lLoop
84:   If pFeatLayer Is Nothing Then
85:     MsgBox "Could not find index layer in DrawPage routine!!!"
    Exit Sub
87:   End If
  
  'Switch to the Layout view if we are not already there
90:   If Not TypeOf pDoc.ActiveView Is IPageLayout Then
91:     Set pDoc.ActiveView = pDoc.PageLayout
92:   End If
  
  'Remove any previous neighbor labels.
95:   Set pGraphicsCont = pDoc.ActiveView
96:   pGraphicsCont.Reset
97:   Set pTempColl = New Collection
98:   Set pElemProps = pGraphicsCont.Next
99:   Do While Not pElemProps Is Nothing
100:     If pElemProps.Name = "DSMAPBOOK TEXT" Then
101:       pTempColl.Add pElemProps
102:     End If
103:     Set pElemProps = pGraphicsCont.Next
104:   Loop
105:   For lLoop = 1 To pTempColl.Count
106:     pGraphicsCont.DeleteElement pTempColl.Item(lLoop)
107:   Next lLoop
108:   Set pTempColl = Nothing
  
  'Rotate the frame if necessary
111:   Set pActive = pMap
112:   Set pSeriesOpts = pSeriesProps
113:   Set pSeriesOpts2 = pSeriesOpts
114:   If pSeriesOpts.RotateFrame Then
'    If m_dPageRotation > 0 Then
116:       pActive.ScreenDisplay.DisplayTransformation.Rotation = m_dPageRotation
'    End If
118:   End If
  
  'Set the extent and possibly the scale for the map
121:   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
129:     pMap.ClipGeometry = m_pPageShape
  Case 2   'clipping with cross hatching of area outside the clip
131:     pMap.ClipGeometry = Nothing
132:     CreateClipElement pDoc, pActive, pFeatLayer
133:   End Select
  
  'Check for indicator maps and update those also
136:   RefreshIndicators pDoc, pSeriesProps, bRefreshFlag
  
  'Check for Date and Title elements
139:   UpdateTaggedElements pDoc, m_sPageName, bRefreshFlag, pDSMapSeries
  
  'Label neighboring tiles if necessary
142:   If pSeriesOpts.LabelNeighbors Then
143:     Set pClone = pSeriesOpts.LabelSymbol
144:     Set pTextSym = pClone.Clone
145:     lIndex = pFeatLayer.FeatureClass.FindField(pSeriesProps.IndexFieldName)
146:     If lIndex >= 0 Then
147:       LabelNeighbors pDoc, pFeatLayer, pTextSym, lIndex, pSeriesProps.DataFrameName
148:     End If
149:   End If
  
   '--------------------------------
  ' DetailExtension:
  '
  ' Update detail maps by executing "Create maps" button.
  ' Added 6/17/2004 to support inset creation from a separate tool.
  '
  Dim pDocument As IDocument
  Dim pUID As IUID
  Dim pCommandItem As ICommandItem
  Dim pCommand As ICommand, bFlag As Boolean
  
162:   Set pUID = New UID
163:   bFlag = False
On Error GoTo NoDetails:
165:   pUID.Value = "DetailAreaExt.CreateDetailsCmd"
On Error GoTo ErrHand:
   
168:    If Not bFlag Then
169:     Set pDocument = pDoc
170:     Set pCommandItem = pDocument.CommandBars.Find(pUID)
171:     If Not pCommandItem Is Nothing Then
172:       If TypeOf pCommandItem Is ICommand Then
173:         Set pCommand = pCommandItem
174:         If pCommand.Enabled Then
175:           pCommandItem.Execute
176:         End If
177:       End If
178:     End If
179:   End If
  
  '  End of DetailExtension additions
  '-------------------------------
  
  'Select the tile if this option is selected - Added 11/23/2004 by LY
  Dim pFeatSel As IFeatureSelection, pQuery As IQueryFilter
186:   Set pSeriesOpts3 = pDSMapSeries
187:   If pSeriesOpts3.SelectTile Then
188:     Set pQuery = New QueryFilter
189:     pQuery.WhereClause = pSeriesProps.IndexFieldName & " = '" & m_sPageName & "'"
190:     Set pFeatSel = pFeatLayer
191:     pFeatSel.SelectFeatures pQuery, esriSelectionResultNew, True
192:   End If
  '-------------------------------------------------------------------------
  
195:   If bRefreshFlag Then
196:     pDoc.ActiveView.Refresh
197:   End If

  Exit Sub
  
NoDetails:
202:   bFlag = True
203:   Resume Next
  
ErrHand:
206:   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
215:   Set IDSMapPage_IndexPage = Nothing
216:   If pIndexLayer Is Nothing Then
217:     MsgBox "You did not send a valid index layer to the IndexPage function!!"
    Exit Function
219:   End If
  
  'Check for a valid field name
222:   If sFieldName = "" Or sFieldName = " " Then
223:     MsgBox "You did not send a valid field name to the IndexPage function!!"
    Exit Function
225:   End If
  
  'Check for field name in the layer
228:   lFieldIndex = pIndexLayer.FeatureClass.FindField(sFieldName)
229:   If lFieldIndex < 0 Then
230:     MsgBox "Could not find field name in the index layer of the IndexPage function!!"
    Exit Function
232:   End If
  
  'Perform the query of the index layer using the page shape
235:   Set pFilter = New SpatialFilter
236:   pFilter.AddField sFieldName
237:   pFilter.WhereClause = sFieldName & " is not null"
'237:   pFilter.WhereClause = sFieldName & " <> '' and " & sFieldName & " <> ' '"
238:   Set pFilter.Geometry = m_pPageShape
239:   pFilter.GeometryField = pIndexLayer.FeatureClass.ShapeFieldName
240:   pFilter.SpatialRel = esriSpatialRelIntersects
241:   Set pCursor = pIndexLayer.Search(pFilter, True)
  
  'Populate the collection with the results of the query
244:   Set pIndex = New Collection
245:   Set pFeat = pCursor.NextFeature
246:   Do While Not pFeat Is Nothing
247:     sValue = pFeat.Value(lFieldIndex)
248:     If pIndex.Count > 0 Then
249:       For lLoop = 1 To pIndex.Count
250:         If sValue < pIndex.Item(lLoop) Then
251:           pIndex.Add sValue, sValue, lLoop
252:           Exit For
253:         ElseIf sValue = pIndex.Item(lLoop) Then
254:           Exit For
255:         End If
256:         If lLoop = pIndex.Count Then
257:           pIndex.Add sValue, sValue
258:         End If
259:       Next lLoop
260:     Else
261:       pIndex.Add sValue, sValue
262:     End If
    
264:     Set pFeat = pCursor.NextFeature
265:   Loop
  
267:   Set IDSMapPage_IndexPage = pIndex

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

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

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

Private Property Get IDSMapPage_PageItem(Index As Long) As IElement
284:   If Index > -1 And Index < m_PageItemColl.Count Then
285:     Set IDSMapPage_PageItem = m_PageItemColl.Item(Index + 1)
286:   Else
287:     Set IDSMapPage_PageItem = Nothing
288:   End If
End Property

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

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

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

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

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

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

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

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

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

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

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

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

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

Private Sub IDSMapPage_RemovePageItem(Index As Long)
344:   If Index > -1 And Index < m_PageItemColl.Count Then
345:     m_PageItemColl.Remove Index + 1
346:   End If
End Sub

Private Property Get IPersistVariant_ID() As esriSystem.IUID