dsmapseries.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 = "DSMapSeries"
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 IDSMapSeries
Implements IDSMapSeriesProps
Implements IDSMapSeriesOptions
Implements IDSMapSeriesOptions2  'Added 6/18/03 to support cross hatching of clip
Implements IPersistVariant

Private m_PageColl As Collection
Private m_bEnableSeries As Boolean
Private m_bClipData As Boolean
Private m_lClipData2 As Long  'Added 6/18/03 to support cross hatching of clip
Private m_sDataDrivenField As String
Private m_lExtentType As Long
Private m_dFixedScale As Double
Private m_bLabelNeighbors As Boolean
Private m_pLabelSymbol As ISymbol
Private m_dMargin As Double
Private m_sMarginType As String
Private m_bRotateFrame As Boolean
Private m_sRotationField As String
Private m_sDataFrameName As String
Private m_sIndexFieldName As String
Private m_sIndexLayerName As String
Private m_SuppressColl As Collection
Private m_bSupressLayers As Boolean
Private m_lTileSelection As Long
Private m_lStartNumber As Long

Private Sub Class_Initialize()
31:   Set m_PageColl = New Collection
32:   Set m_SuppressColl = New Collection
End Sub

Private Sub Class_Terminate()
36:   Set m_PageColl = Nothing
37:   Set m_SuppressColl = Nothing
End Sub

Private Sub IDSMapSeries_AddPage(ByVal Page As DSMapBookPrj.IDSMapPage)
41:   m_PageColl.Add Page
End Sub

Private Property Get IDSMapSeries_Page(Index As Long) As DSMapBookPrj.IDSMapPage
45:   If Index > -1 And Index < m_PageColl.Count Then
46:     Set IDSMapSeries_Page = m_PageColl.Item(Index + 1)
47:   Else
48:     Set IDSMapSeries_Page = Nothing
49:   End If
End Property

Private Property Get IDSMapSeries_PageCount() As Long
53:   IDSMapSeries_PageCount = m_PageColl.Count
End Property

Private Property Let IDSMapSeries_EnableSeries(ByVal RHS As Boolean)
57:   m_bEnableSeries = RHS
End Property

Private Property Get IDSMapSeries_EnableSeries() As Boolean
61:   IDSMapSeries_EnableSeries = m_bEnableSeries
End Property

Private Sub IDSMapSeries_RemovePage(Index As Long)
65:   If Index > -1 And Index < m_PageColl.Count Then
66:     m_PageColl.Remove Index + 1
67:   End If
End Sub

Private Property Let IDSMapSeriesOptions_ClipData(RHS As Boolean)
71:   m_bClipData = RHS
End Property

Private Property Get IDSMapSeriesOptions_ClipData() As Boolean
75:   IDSMapSeriesOptions_ClipData = m_bClipData
End Property

Private Property Let IDSMapSeriesOptions_DataDrivenField(RHS As String)
79:   m_sDataDrivenField = RHS
End Property

Private Property Get IDSMapSeriesOptions_DataDrivenField() As String
83:   IDSMapSeriesOptions_DataDrivenField = m_sDataDrivenField
End Property

Private Property Let IDSMapSeriesOptions_ExtentType(RHS As Long)
87:   m_lExtentType = RHS
End Property

Private Property Get IDSMapSeriesOptions_ExtentType() As Long
91:   IDSMapSeriesOptions_ExtentType = m_lExtentType
End Property

Private Property Let IDSMapSeriesOptions_FixedScale(RHS As Double)
95:   m_dFixedScale = RHS
End Property

Private Property Get IDSMapSeriesOptions_FixedScale() As Double
99:   IDSMapSeriesOptions_FixedScale = m_dFixedScale
End Property

Private Property Let IDSMapSeriesOptions_LabelNeighbors(RHS As Boolean)
103:   m_bLabelNeighbors = RHS
End Property

Private Property Get IDSMapSeriesOptions_LabelNeighbors() As Boolean
107:   IDSMapSeriesOptions_LabelNeighbors = m_bLabelNeighbors
End Property

Private Property Set IDSMapSeriesOptions_LabelSymbol(RHS As ISymbol)
111:   Set m_pLabelSymbol = RHS
End Property

Private Property Get IDSMapSeriesOptions_LabelSymbol() As ISymbol
115:   Set IDSMapSeriesOptions_LabelSymbol = m_pLabelSymbol
End Property

Private Property Let IDSMapSeriesOptions_Margin(RHS As Double)
119:   m_dMargin = RHS
End Property

Private Property Get IDSMapSeriesOptions_Margin() As Double
123:   IDSMapSeriesOptions_Margin = m_dMargin
End Property

Private Property Let IDSMapSeriesOptions_MarginType(RHS As String)
127:   m_sMarginType = RHS
End Property

Private Property Get IDSMapSeriesOptions_MarginType() As String
131:   IDSMapSeriesOptions_MarginType = m_sMarginType
End Property

Private Property Let IDSMapSeriesOptions_RotateFrame(RHS As Boolean)
135:   m_bRotateFrame = RHS
End Property

Private Property Get IDSMapSeriesOptions_RotateFrame() As Boolean
139:   IDSMapSeriesOptions_RotateFrame = m_bRotateFrame
End Property

Private Property Let IDSMapSeriesOptions_RotationField(RHS As String)
143:   m_sRotationField = RHS
End Property

Private Property Get IDSMapSeriesOptions_RotationField() As String
147:   IDSMapSeriesOptions_RotationField = m_sRotationField
End Property

Private Property Let IDSMapSeriesOptions2_ClipData(RHS As Long)
'Added 6/18/03 to support cross hatching of clip
152:   m_lClipData2 = RHS
End Property

Private Property Get IDSMapSeriesOptions2_ClipData() As Long
'Added 6/18/03 to support cross hatching of clip
157:   IDSMapSeriesOptions2_ClipData = m_lClipData2
End Property

Private Sub IDSMapSeriesProps_AddLayerToSuppress(ByVal LayerName As String)
161:   m_SuppressColl.Add LayerName
End Sub

Private Property Let IDSMapSeriesProps_DataFrameName(RHS As String)
165:   m_sDataFrameName = RHS
End Property

Private Property Get IDSMapSeriesProps_DataFrameName() As String
169:   IDSMapSeriesProps_DataFrameName = m_sDataFrameName
End Property

Private Property Let IDSMapSeriesProps_IndexFieldName(RHS As String)
173:   m_sIndexFieldName = RHS
End Property

Private Property Get IDSMapSeriesProps_IndexFieldName() As String
177:   IDSMapSeriesProps_IndexFieldName = m_sIndexFieldName
End Property

Private Property Let IDSMapSeriesProps_IndexLayerName(RHS As String)
181:   m_sIndexLayerName = RHS
End Property

Private Property Get IDSMapSeriesProps_IndexLayerName() As String
185:   IDSMapSeriesProps_IndexLayerName = m_sIndexLayerName
End Property

Private Sub IDSMapSeriesProps_RemoveLayerToSuppress(Index As Long)
189:   If Index > -1 And Index < m_SuppressColl.Count Then
190:     m_SuppressColl.Remove Index + 1
191:   End If
End Sub

Private Property Let IDSMapSeriesProps_StartNumber(RHS As Long)
195:   m_lStartNumber = RHS
End Property

Private Property Get IDSMapSeriesProps_StartNumber() As Long
199:   IDSMapSeriesProps_StartNumber = m_lStartNumber
End Property

Private Property Get IDSMapSeriesProps_SuppressLayer(Index As Long) As String
203:   If Index > -1 And Index < m_SuppressColl.Count Then
204:     IDSMapSeriesProps_SuppressLayer = m_SuppressColl.Item(Index + 1)
205:   Else
206:     IDSMapSeriesProps_SuppressLayer = ""
207:   End If
End Property

Private Property Get IDSMapSeriesProps_SuppressLayerCount() As Long
211:   IDSMapSeriesProps_SuppressLayerCount = m_SuppressColl.Count
End Property

Private Property Let IDSMapSeriesProps_SuppressLayers(ByVal RHS As Boolean)
215:   m_bSupressLayers = RHS
End Property

Private Property Get IDSMapSeriesProps_SuppressLayers() As Boolean
219:   IDSMapSeriesProps_SuppressLayers = m_bSupressLayers
End Property

Private Property Let IDSMapSeriesProps_TileSelectionMethod(RHS As Long)
223:   m_lTileSelection = RHS
End Property

Private Property Get IDSMapSeriesProps_TileSelectionMethod() As Long
227:   IDSMapSeriesProps_TileSelectionMethod = m_lTileSelection
End Property

Private Property Get IPersistVariant_ID() As esriSystem.IUID
  Dim id As New UID
232:   id = "DSMapBookPrj.DSMapSeries"
233:   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, pPage As IDSMapPage, vClip As Variant
  Dim bClip As Boolean, vCount As Variant, lPropCount As Long
  
  'Added 2/18/04 to make the list of persisted properties more dynamic
243:   vCount = Stream.Read
244:   If UCase(TypeName(vCount)) = "BOOLEAN" Then  'Version created before the 2/18/04 update.
245:     m_bEnableSeries = CBool(vCount)
    'Added 6/18/03 to support cross hatching of area outside clip
247:     vClip = Stream.Read
248:     If UCase(TypeName(vClip)) = "BOOLEAN" Then
249:       bClip = CBool(vClip)
250:       If bClip Then
251:         m_lClipData2 = 1
252:       Else
253:         m_lClipData2 = 0
254:       End If
255:     Else
256:       m_lClipData2 = CLng(vClip)
257:     End If
258:     lPropCount = 14
259:   Else
260:     lPropCount = CLng(Mid(CStr(vCount), 21)) - 2
261:     m_bEnableSeries = Stream.Read
262:     m_lClipData2 = Stream.Read
263:   End If

  'Original set of properties that every persisted map book will have.
266:   m_sDataDrivenField = Stream.Read
267:   m_lExtentType = Stream.Read
268:   m_dFixedScale = Stream.Read
269:   m_bLabelNeighbors = Stream.Read
270:   Set m_pLabelSymbol = Stream.Read
271:   m_dMargin = Stream.Read
272:   m_sMarginType = Stream.Read
273:   m_bRotateFrame = Stream.Read
274:   m_sRotationField = Stream.Read
275:   m_sDataFrameName = Stream.Read
276:   m_sIndexFieldName = Stream.Read
277:   m_sIndexLayerName = Stream.Read
278:   m_bSupressLayers = Stream.Read
279:   m_lTileSelection = Stream.Read
  
  'Additional properties added after 2/18/04
282:   If lPropCount > 14 Then    'Checking for start number property
283:     m_lStartNumber = Stream.Read
284:   Else
285:     m_lStartNumber = 1
286:   End If
  
  'More original properties.  Writen out below the new properties because they are of variable length
289:   lCount = Stream.Read
290:   If lCount > 0 Then
291:     For lLoop = 1 To lCount
292:       m_SuppressColl.Add Stream.Read
293:     Next lLoop
294:   End If
  
296:   lCount = Stream.Read
297:   If lCount > 0 Then
298:     For lLoop = 1 To lCount
299:       Set pPage = Stream.Read
300:       If lPropCount <= 14 Then   'MapBook created before page numbers were added.  In this case we manually assign the page numbers.
301:         pPage.PageNumber = lLoop
302:       End If
303:       m_PageColl.Add pPage
304:     Next lLoop
305:   End If
    
  Exit Sub
ErrHand:
309:   MsgBox "MapSeries - IPersistVariant_Load - " & Erl & " - " & Err.Description
End Sub

Private Sub IPersistVariant_Save(ByVal Stream As esriSystem.IVariantStream)
'Write it all out
On Error GoTo ErrHand:
  Dim lLoop As Long
  
  'Added 2/18/04 to make the list of persisted properties more dynamic
318:   Stream.Write "SERIESPROPERTYCOUNT-17"
    
320:   Stream.Write m_bEnableSeries
  
  'Added 6/18/03 to support cross hatching of area outside the clip
323:   Stream.Write m_lClipData2
324:   Stream.Write m_sDataDrivenField
325:   Stream.Write m_lExtentType
326:   Stream.Write m_dFixedScale
327:   Stream.Write m_bLabelNeighbors
328:   Stream.Write m_pLabelSymbol
329:   Stream.Write m_dMargin
330:   Stream.Write m_sMarginType
331:   Stream.Write m_bRotateFrame
332:   Stream.Write m_sRotationField
333:   Stream.Write m_sDataFrameName
334:   Stream.Write m_sIndexFieldName
335:   Stream.Write m_sIndexLayerName
336:   Stream.Write m_bSupressLayers
337:   Stream.Write m_lTileSelection
338:   Stream.Write m_lStartNumber   'Added 2/18/04

On Error GoTo ErrHand2:
341:   Stream.Write m_SuppressColl.Count
342:   If m_SuppressColl.Count > 0 Then
343:     For lLoop = 1 To m_SuppressColl.Count
344:       Stream.Write m_SuppressColl.Item(lLoop)
345:     Next lLoop
346:   End If
347:   Stream.Write m_PageColl.Count
348:   If m_PageColl.Count > 0 Then
349:     For lLoop = 1 To m_PageColl.Count
350:       Stream.Write m_PageColl.Item(lLoop)
351:     Next lLoop
352:   End If
    
  Exit Sub
ErrHand:
356:   MsgBox "MapSeries - IPersistVariant_Save - " & Err.Description
ErrHand2:
358:   MsgBox "MapSeriesCOLLS - IPersistVariant_Save - " & Err.Description
End Sub