dsmappage.cls

使用VB和ArcObject结合的程序

295:   m_dPageRotation = Stream.Read
296:   m_dPageScale = Stream.Read
297:   m_dLastOutputted = Stream.Read
298:   Set m_pPageShape = Stream.Read
  
  'Additional properties added after 2/18/04
301:   If lPropCount > 5 Then    'Checking for page number
302:     m_lPageNumber = Stream.Read
303:   Else
304:     m_lPageNumber = -1
305:   End If
  
  'More original properties.  Writen out below the new properties because they are of variable length
308:   lCount = Stream.Read
309:   If lCount > 0 Then
310:     For lLoop = 1 To lCount
311:       Set pElem = Stream.Read
312:       m_PageItemColl.Add pElem
313:     Next lLoop
314:   End If
    
  Exit Sub
ErrHand:
318:   MsgBox "MapPage - 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
327:   Stream.Write "PAGEPROPERTYCOUNT-7"
    
329:   Stream.Write m_sPageName
330:   Stream.Write m_bPrintPage
331:   Stream.Write m_dPageRotation
332:   Stream.Write m_dPageScale
333:   Stream.Write m_dLastOutputted
334:   Stream.Write m_pPageShape
335:   Stream.Write m_lPageNumber   'Added 2/18/04
  
337:   Stream.Write m_PageItemColl.Count
338:   If m_PageItemColl.Count > 0 Then
339:     For lLoop = 1 To m_PageItemColl.Count
340:       Stream.Write m_PageItemColl.Item(lLoop)
341:     Next lLoop
342:   End If
    
  Exit Sub
ErrHand:
346:   MsgBox "MapPage - IPersistVariant_Save - " & Err.Description
End Sub

Private Sub LabelNeighbors(pDoc As IMxDocument, pFLayer As IFeatureLayer, pTextSym As ISimpleTextSymbol, _
 lIndex As Long, sFrameName As String)
'Routine for loop through the tiles that are touching are selected tile
On Error GoTo ErrHand:
  Dim pElem As IElement, pTextElem As ITextElement, pMap As IMap
  Dim pGraphSel As IGraphicsContainerSelect
  Dim pSpatial As ISpatialFilter, pFeatCursor As IFeatureCursor
  Dim pFeats As IFeature, pActive As IActiveView, sText As String
357:   Set pMap = pDoc.FocusMap
358:   Set pActive = pDoc.ActiveView
  
360:   Set pSpatial = New SpatialFilter
361:   Set pSpatial.Geometry = m_pPageShape
362:   pSpatial.GeometryField = pFLayer.FeatureClass.ShapeFieldName
363:   pSpatial.SpatialRel = esriSpatialRelTouches
364:   Set pFeatCursor = pFLayer.Search(pSpatial, False)
365:   Set pFeats = pFeatCursor.NextFeature
366:   Do While Not pFeats Is Nothing
    'If there is a value for the selected adjacent tile, then get it and label the feature
368:     If Not IsNull(pFeats.Value(lIndex)) Then
369:       sText = pFeats.Value(lIndex)
370:       LabelAdjacent pFeats, pMap, pActive, pTextSym, sText, sFrameName
371:     End If
372:     Set pFeats = pFeatCursor.NextFeature
373:   Loop
374:   Set pGraphSel = pActive
375:   pGraphSel.UnselectAllElements

  Exit Sub
ErrHand:
379:   MsgBox "LabelNeighbors - " & Err.Description
End Sub

Sub LabelAdjacent(pLabelFeat As IFeature, pMap As IMap, pActive As IActiveView, pTextSym As ITextSymbol, _
 sText As String, sFrameName As String)
'Routine for labeling the outside edge of our data frame based on the relative
'position of the tile feature being sent in (pLabelFeat) to the selected tile (pIndexFeat)
'The relative position is determined by finding the midpoint of the common line between
'the selected tile and the tile to be labeled.  The midpoint is then combined with the
'center of the extent of the map to create a line that is extended to the edge of the
'map extent.  The location along the map extent is then extrapolated out to a point on
'the boundary of our map frame.  This location is then labeled with the name of the tile.
On Error GoTo ErrHand:
  Dim pCommonGeom As IGeometry, pTopoOp As ITopologicalOperator, pPolyline2 As IPolyline
  Dim pMidPt As IPoint, pPolyLine As IPolyline, pEnv As IEnvelope, pTmpFrame As IMapFrame
  Dim pCenterPt As IPoint, pMapView As IActiveView, pMulti As IPointCollection
  Dim pGraph As IGraphicsContainer, lLoop As Long, pElem As IElement
  Dim pElemProps As IElementProperties, pTrans2D As ITransform2D
  Dim pPt As IConstructPoint, pNewPt As IPoint, pTextElem As ITextElement
  Dim pMapFrame As IMapFrame, pMapEnv As IEnvelope, pFramePoly As IPointCollection
  Dim pLine As ILine, dDist As Double, iSeg As Integer, pEndPt As IPoint
  Dim pProx As IProximityOperator, dTmpDist As Double, pCurve2 As ICurve
  Dim pOutPt As IPoint, dAlong As Double, dFrom As Double, bSide As Boolean
  Dim pPoints As IPointCollection, pPoints2 As IPointCollection, dAngle As Double
  Dim pIntPoints As IPointCollection, pIntTopo As ITopologicalOperator

405:   Set pTopoOp = m_pPageShape
406:   Set pCommonGeom = pTopoOp.Intersect(pLabelFeat.Shape, esriGeometry1Dimension)
407:   If pCommonGeom.IsEmpty Then
408:     Set pCommonGeom = pTopoOp.Intersect(pLabelFeat.Shape, esriGeometry0Dimension)
409:     Set pMulti = pCommonGeom
410:     Set pMidPt = pMulti.Point(0)
411:   Else
412:     Set pPolyLine = pCommonGeom
413:     Set pMidPt = New esriGeometry.Point
414:     pPolyLine.QueryPoint esriNoExtension, 0.5, True, pMidPt
415:   End If
    
  'Find center point of map frame
418:   Set pCenterPt = New esriGeometry.Point
419:   Set pMapView = pMap
420:   Set pEnv = pMapView.Extent
421:   pCenterPt.X = pEnv.XMin + ((pEnv.XMax - pEnv.XMin) / 2)
422:   pCenterPt.Y = pEnv.YMin + ((pEnv.YMax - pEnv.YMin) / 2)

  'Get the geometry of the map frame
425:   Set pGraph = pActive
426:   pGraph.Reset
427:   Set pElem = pGraph.Next
428:   Do While Not pElem Is Nothing
429:     If TypeOf pElem Is IMapFrame Then
430:       Set pTmpFrame = pElem
431:       If pTmpFrame.Map.Name = sFrameName Then
432:         Set pMapFrame = pElem
433:         Exit Do
434:       End If
435:     End If
436:     Set pElem = pGraph.Next
437:   Loop
  If pMapFrame Is Nothing Then Exit Sub
  
440:   Set pMapEnv = pMapFrame.MapBounds
441:   Set pFramePoly = pElem.Geometry
  
  'Create curves and intersect them
444:   Set pPoints = New Polyline
445:   pPoints.AddPoint pMapEnv.LowerLeft
446:   pPoints.AddPoint pMapEnv.LowerRight
447:   pPoints.AddPoint pMapEnv.UpperRight
448:   pPoints.AddPoint pMapEnv.UpperLeft
449:   pPoints.AddPoint pMapEnv.LowerLeft
  
451:   Set pPoints2 = RotatedAndExtendedLine(pCenterPt, pMidPt)
  'If for some reason nothing is returned, go with a rotation of 0
  If pPoints2 Is Nothing Then Exit Sub
454:   Set pPolyline2 = pPoints2
  If pPolyline2.IsEmpty Then Exit Sub
    
  'Find the intersection point of the line we created and the map extent boundary
458:   Set pIntTopo = pPoints2
459:   Set pIntPoints = pIntTopo.Intersect(pPoints, esriGeometry0Dimension)
  If pIntPoints.PointCount = 0 Then Exit Sub
  
462:   Set pEndPt = pIntPoints.Point(0)
  
  'Extrapolate the point on the extent to a point on the outside of the map frame
  'Figure out which segment we are closest to
466:   Set pProx = pEndPt
467:   dDist = 999999
468:   iSeg = -1
469:   For lLoop = 0 To 3
470:     Set pLine = New esriGeometry.Line
    Select Case lLoop
    Case 0
473:       pLine.PutCoords pMapEnv.LowerLeft, pMapEnv.UpperLeft
    Case 1
475:       pLine.PutCoords pMapEnv.UpperLeft, pMapEnv.UpperRight
    Case 2
477:       pLine.PutCoords pMapEnv.UpperRight, pMapEnv.LowerRight
    Case Else
479:       pLine.PutCoords pMapEnv.LowerRight, pMapEnv.LowerLeft
480:     End Select
    
482:     dTmpDist = pProx.ReturnDistance(pLine)
483:     If dTmpDist < dDist Then
484:       dDist = dTmpDist
485:       iSeg = lLoop
486:       Set pCurve2 = pLine
487:     End If
488:   Next lLoop
489:   Set pOutPt = New esriGeometry.Point
490:   pCurve2.QueryPointAndDistance esriNoExtension, pEndPt, True, pOutPt, dAlong, dFrom, bSide
  
  'We know have the segment and ratio length on that segment, so we can transfer that
  'information to the frame geometry and find the corresponding point there
494:   Set pPt = New esriGeometry.Point
495:   Set pLine = New esriGeometry.Line
  Select Case iSeg
  Case 0
498:     pLine.PutCoords pFramePoly.Point(0), pFramePoly.Point(1)
499:     pTextSym.HorizontalAlignment = esriTHACenter
500:     pTextSym.VerticalAlignment = esriTVABottom
  Case 1
502:     pLine.PutCoords pFramePoly.Point(1), pFramePoly.Point(2)
503:     pTextSym.HorizontalAlignment = esriTHACenter
504:     pTextSym.VerticalAlignment = esriTVABottom
  Case 2
506:     pLine.PutCoords pFramePoly.Point(2), pFramePoly.Point(3)
507:     pTextSym.HorizontalAlignment = esriTHACenter
508:     pTextSym.VerticalAlignment = esriTVABottom
  Case 3
510:     pLine.PutCoords pFramePoly.Point(3), pFramePoly.Point(0)
511:     pTextSym.HorizontalAlignment = esriTHACenter
512:     pTextSym.VerticalAlignment = esriTVATop
513:   End Select
514:   pPt.ConstructAlong pLine, esriNoExtension, dAlong, True
515:   Set pNewPt = pPt
  
  'Now that we have a point along the data frame, we can place the label based on
  'that point and which side of the frame it is on
519:   Set pTextElem = New TextElement
520:   Set pElem = pTextElem
521:   pTextElem.Symbol = pTextSym
522:   pElem.Geometry = pNewPt
523:   Set pElemProps = pElem
524:   pElemProps.Name = "DSMAPBOOK TEXT"
525:   pTextElem.Text = sText
526:   Set pTrans2D = pTextElem
  Select Case iSeg
  Case 0
529:     dAngle = 90 * (3.14159265358979 / 180)
  Case 1
531:     dAngle = 0
  Case 2
533:     dAngle = 270 * (3.14159265358979 / 180)
  Case 3
535:     dAngle = 0
536:   End Select
537:   pTrans2D.Rotate pNewPt, dAngle
538:   pGraph.AddElement pElem, 0
  
  Exit Sub
ErrHand:
542:   MsgBox "LabelAdjacent - " & Err.Description
End Sub

Private Function RotatedAndExtendedLine(pCenterPt As IPoint, pMidPt As IPoint) As IPolyline
On Error GoTo ErrHand:
  Dim pPoints As IPointCollection, pPolyLine As IPolyline, pLine As ILine, pNewPt As IConstructPoint
  Dim dOrigAngle As Double, dNewAngle As Double, dLength As Double, dRadAngle As Double
  Dim pNewPoints As IPointCollection, pNewPoint As IConstructPoint, dA As Double
  
  'Create a line so we can get the current angle and distance
552:   Set pLine = New esriGeometry.Line
553:   pLine.PutCoords pCenterPt, pMidPt
554:   dLength = pLine.Length
  
556:   If m_dPageRotation = 0 Then
    'Create another point at the same angle to make sure our line crosses the extent boundary
558:     Set pNewPt = New esriGeometry.Point
559:     pNewPt.ConstructAngleDistance pMidPt, pLine.Angle, dLength * 100
560:     Set pPoints = New Polyline
561:     pPoints.AddPoint pCenterPt
562:     pPoints.AddPoint pMidPt
563:     pPoints.AddPoint pNewPt
564:     Set RotatedAndExtendedLine = pPoints
    Exit Function
566:   End If
  
  'If the page is rotated, then we have to rotate the labeling of adjacent tiles also
569:   dOrigAngle = pLine.Angle * (180 / 3.14159265358979)
570:   dA = dOrigAngle
571:   If dOrigAngle < 0 Then
572:     dOrigAngle = 360 - Abs(dOrigAngle)
573:   End If
574:   dNewAngle = dOrigAngle + m_dPageRotation
575:   If dNewAngle >= 360 Then
576:     dNewAngle = dNewAngle - 360
577:   End If
578:   dRadAngle = dNewAngle * (3.14159265358979 / 180)
  
  'Make a new esrigeometry.line at the rotated angle we just calculated.  The new esrigeometry.line is made shorter than the original
  'to ensure the line does not extend past the map bounds we need to intersect it with in the next stage
582:   Set pNewPoint = New esriGeometry.Point
583:   Set pNewPoints = New Polyline
584:   pNewPoint.ConstructAngleDistance pCenterPt, dRadAngle, dLength * 100
585:   pNewPoints.AddPoint pCenterPt
586:   pNewPoints.AddPoint pNewPoint
587:   Set RotatedAndExtendedLine = pNewPoints
  
  Exit Function
ErrHand:
591:   MsgBox "RotatedLine - " & Err.Description
End Function

Private Sub RefreshIndicators(pDoc As IMxDocument, pSeriesProps As IDSMapSeriesProps, bRefreshFlag As Boolean)
'Routine for updating any identicator maps there might be
On Error GoTo ErrHand:
  Dim pGridLayer As IFeatureLayer, pGridSel As IFeatureSelection
  Dim lLoop As Long, pActive As IActiveView, pSpatial As ISpatialFilter
  Dim pFeature As IFeature, pCursor As IFeatureCursor, pEnv As IEnvelope
  Dim pQuery As IQueryFilter, lLoop2 As Long, pMap As IMap

  'Check for indicator maps and update those also
603:   For lLoop = 0 To pDoc.Maps.Count - 1
604:     If pDoc.Maps.Item(lLoop).Name = "Global Indicator" Or pDoc.Maps.Item(lLoop).Name = "Local Indicator" Then
605:       Set pMap = pDoc.Maps.Item(lLoop)
      'Find the Index layer
607:       For lLoop2 = 0 To pMap.LayerCount - 1
608:         If pMap.Layer(lLoop2).Name = "Identifier Layer" Then
609:           Set pGridLayer = pMap.Layer(lLoop2)
610:           Exit For
611:         End If
612:       Next lLoop2
613:       If pGridLayer Is Nothing Then
614:         MsgBox "Could not find layer called Identifier Layer, can not redraw " & pMap.Name & " frame!!!"
        Exit Sub
616:       End If
      
'      Set pGridLayer = pDoc.Maps.Item(lLoop).Layer(0)
619:       Set pGridSel = pGridLayer
620:       Set pQuery = New QueryFilter
621:       pQuery.WhereClause = pSeriesProps.IndexFieldName & " = '" & m_sPageName & "'"
622:       pGridSel.Clear
623:       pGridSel.SelectFeatures pQuery, esriSelectionResultNew, True
        
625:       If pMap.Name = "Global Indicator" Then
626:         Set pActive = pDoc.Maps.Item(lLoop)
627:         If bRefreshFlag Then pActive.Refresh
628:       ElseIf pMap.Name = "Local Indicator" Then
629:         Set pSpatial = New SpatialFilter