dsmappage.cls

一个不错的插件

  Dim id As New UID
351:   id = "DSMapBookPrj.DSMapPage"
352:   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
362:   sFirstItem = Stream.Read
363:   If UCase(Left(sFirstItem, 18)) = "PAGEPROPERTYCOUNT-" Then
364:     lPropCount = Mid(sFirstItem, 19) - 1
365:     m_sPageName = Stream.Read
366:   Else
367:     lPropCount = 5
368:     m_sPageName = sFirstItem
369:   End If
    
  'Original page properties
372:   m_bPrintPage = Stream.Read
373:   m_dPageRotation = Stream.Read
374:   m_dPageScale = Stream.Read
375:   m_dLastOutputted = Stream.Read
376:   Set m_pPageShape = Stream.Read
  
  'Additional properties added after 2/18/04
379:   If lPropCount > 5 Then    'Checking for page number
380:     m_lPageNumber = Stream.Read
381:   Else
382:     m_lPageNumber = -1
383:   End If
  
  'More original properties.  Writen out below the new properties because they are of variable length
386:   lCount = Stream.Read
387:   If lCount > 0 Then
388:     For lLoop = 1 To lCount
389:       Set pElem = Stream.Read
390:       m_PageItemColl.Add pElem
391:     Next lLoop
392:   End If
    
  Exit Sub
ErrHand:
396:   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
405:   Stream.Write "PAGEPROPERTYCOUNT-7"
    
407:   Stream.Write m_sPageName
408:   Stream.Write m_bPrintPage
409:   Stream.Write m_dPageRotation
410:   Stream.Write m_dPageScale
411:   Stream.Write m_dLastOutputted
412:   Stream.Write m_pPageShape
413:   Stream.Write m_lPageNumber   'Added 2/18/04
  
415:   Stream.Write m_PageItemColl.Count
416:   If m_PageItemColl.Count > 0 Then
417:     For lLoop = 1 To m_PageItemColl.Count
418:       Stream.Write m_PageItemColl.Item(lLoop)
419:     Next lLoop
420:   End If
    
  Exit Sub
ErrHand:
424:   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
435:   Set pMap = pDoc.FocusMap
436:   Set pActive = pDoc.ActiveView
  
438:   Set pSpatial = New SpatialFilter
439:   Set pSpatial.Geometry = m_pPageShape
440:   pSpatial.GeometryField = pFLayer.FeatureClass.ShapeFieldName
441:   pSpatial.SpatialRel = esriSpatialRelTouches
442:   Set pFeatCursor = pFLayer.Search(pSpatial, False)
443:   Set pFeats = pFeatCursor.NextFeature
444:   Do While Not pFeats Is Nothing
    'If there is a value for the selected adjacent tile, then get it and label the feature
446:     If Not IsNull(pFeats.Value(lIndex)) Then
447:       sText = pFeats.Value(lIndex)
448:       LabelAdjacent pFeats, pMap, pActive, pTextSym, sText, sFrameName
449:     End If
450:     Set pFeats = pFeatCursor.NextFeature
451:   Loop
452:   Set pGraphSel = pActive
453:   pGraphSel.UnselectAllElements

  Exit Sub
ErrHand:
457:   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

483:   Set pTopoOp = m_pPageShape
484:   Set pCommonGeom = pTopoOp.Intersect(pLabelFeat.Shape, esriGeometry1Dimension)
485:   If pCommonGeom.IsEmpty Then
486:     Set pCommonGeom = pTopoOp.Intersect(pLabelFeat.Shape, esriGeometry0Dimension)
487:     Set pMulti = pCommonGeom
488:     Set pMidPt = pMulti.Point(0)
489:   Else
490:     Set pPolyLine = pCommonGeom
491:     Set pMidPt = New esriGeometry.Point
492:     pPolyLine.QueryPoint esriNoExtension, 0.5, True, pMidPt
493:   End If
    
  'Find center point of map frame
496:   Set pCenterPt = New esriGeometry.Point
497:   Set pMapView = pMap
498:   Set pEnv = pMapView.Extent
499:   pCenterPt.X = pEnv.XMin + ((pEnv.XMax - pEnv.XMin) / 2)
500:   pCenterPt.Y = pEnv.YMin + ((pEnv.YMax - pEnv.YMin) / 2)

  'Get the geometry of the map frame
503:   Set pGraph = pActive
504:   pGraph.Reset
505:   Set pElem = pGraph.Next
506:   Do While Not pElem Is Nothing
507:     If TypeOf pElem Is IMapFrame Then
508:       Set pTmpFrame = pElem
509:       If pTmpFrame.Map.Name = sFrameName Then
510:         Set pMapFrame = pElem
511:         Exit Do
512:       End If
513:     End If
514:     Set pElem = pGraph.Next
515:   Loop
  If pMapFrame Is Nothing Then Exit Sub
  
518:   Set pMapEnv = pMapFrame.MapBounds
519:   Set pFramePoly = pElem.Geometry
  
  'Create curves and intersect them
522:   Set pPoints = New Polyline
523:   pPoints.AddPoint pMapEnv.LowerLeft
524:   pPoints.AddPoint pMapEnv.LowerRight
525:   pPoints.AddPoint pMapEnv.UpperRight
526:   pPoints.AddPoint pMapEnv.UpperLeft
527:   pPoints.AddPoint pMapEnv.LowerLeft
  
529:   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
532:   Set pPolyline2 = pPoints2
  If pPolyline2.IsEmpty Then Exit Sub
    
  'Find the intersection point of the line we created and the map extent boundary
536:   Set pIntTopo = pPoints2
537:   Set pIntPoints = pIntTopo.Intersect(pPoints, esriGeometry0Dimension)
  If pIntPoints.PointCount = 0 Then Exit Sub
  
540:   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
544:   Set pProx = pEndPt
545:   dDist = 999999
546:   iSeg = -1
547:   For lLoop = 0 To 3
548:     Set pLine = New esriGeometry.Line
    Select Case lLoop
    Case 0
551:       pLine.PutCoords pMapEnv.LowerLeft, pMapEnv.UpperLeft
    Case 1
553:       pLine.PutCoords pMapEnv.UpperLeft, pMapEnv.UpperRight
    Case 2
555:       pLine.PutCoords pMapEnv.UpperRight, pMapEnv.LowerRight
    Case Else
557:       pLine.PutCoords pMapEnv.LowerRight, pMapEnv.LowerLeft
558:     End Select
    
560:     dTmpDist = pProx.ReturnDistance(pLine)
561:     If dTmpDist < dDist Then
562:       dDist = dTmpDist
563:       iSeg = lLoop
564:       Set pCurve2 = pLine
565:     End If
566:   Next lLoop
567:   Set pOutPt = New esriGeometry.Point
568:   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
572:   Set pPt = New esriGeometry.Point
573:   Set pLine = New esriGeometry.Line
  Select Case iSeg
  Case 0
576:     pLine.PutCoords pFramePoly.Point(0), pFramePoly.Point(1)
577:     pTextSym.HorizontalAlignment = esriTHACenter
578:     pTextSym.VerticalAlignment = esriTVABottom
  Case 1
580:     pLine.PutCoords pFramePoly.Point(1), pFramePoly.Point(2)
581:     pTextSym.HorizontalAlignment = esriTHACenter
582:     pTextSym.VerticalAlignment = esriTVABottom
  Case 2
584:     pLine.PutCoords pFramePoly.Point(2), pFramePoly.Point(3)
585:     pTextSym.HorizontalAlignment = esriTHACenter
586:     pTextSym.VerticalAlignment = esriTVABottom
  Case 3
588:     pLine.PutCoords pFramePoly.Point(3), pFramePoly.Point(0)
589:     pTextSym.HorizontalAlignment = esriTHACenter
590:     pTextSym.VerticalAlignment = esriTVATop
591:   End Select
592:   pPt.ConstructAlong pLine, esriNoExtension, dAlong, True
593:   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
597:   Set pTextElem = New TextElement
598:   Set pElem = pTextElem
599:   pTextElem.Symbol = pTextSym
600:   pElem.Geometry = pNewPt
601:   Set pElemProps = pElem
602:   pElemProps.Name = "DSMAPBOOK TEXT"
603:   pTextElem.Text = sText
604:   Set pTrans2D = pTextElem
  Select Case iSeg
  Case 0
607:     dAngle = 90 * (3.14159265358979 / 180)
  Case 1
609:     dAngle = 0
  Case 2
611:     dAngle = 270 * (3.14159265358979 / 180)
  Case 3
613:     dAngle = 0
614:   End Select
615:   pTrans2D.Rotate pNewPt, dAngle
616:   pGraph.AddElement pElem, 0
  
  Exit Sub
ErrHand:
620:   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
630:   Set pLine = New esriGeometry.Line
631:   pLine.PutCoords pCenterPt, pMidPt
632:   dLength = pLine.Length
  
634:   If m_dPageRotation = 0 Then
    'Create another point at the same angle to make sure our line crosses the extent boundary
636:     Set pNewPt = New esriGeometry.Point
637:     pNewPt.ConstructAngleDistance pMidPt, pLine.Angle, dLength * 100
638:     Set pPoints = New Polyline
639:     pPoints.AddPoint pCenterPt
640:     pPoints.AddPoint pMidPt
641:     pPoints.AddPoint pNewPt
642:     Set RotatedAndExtendedLine = pPoints
    Exit Function
644:   End If
  
  'If the page is rotated, then we have to rotate the labeling of adjacent tiles also
647:   dOrigAngle = pLine.Angle * (180 / 3.14159265358979)
648:   dA = dOrigAngle
649:   If dOrigAngle < 0 Then
650:     dOrigAngle = 360 - Abs(dOrigAngle)
651:   End If
652:   dNewAngle = dOrigAngle + m_dPageRotation
653:   If dNewAngle >= 360 Then
654:     dNewAngle = dNewAngle - 360
655:   End If
656:   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
660:   Set pNewPoint = New esriGeometry.Point
661:   Set pNewPoints = New Polyline
662:   pNewPoint.ConstructAngleDistance pCenterPt, dRadAngle, dLength * 100
663:   pNewPoints.AddPoint pCenterPt
664:   pNewPoints.AddPoint pNewPoint
665:   Set RotatedAndExtendedLine = pNewPoints
  
  Exit Function
ErrHand:
669:   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, pSelEvents As ISelectionEvents

  'Check for indicator maps and update those also
681:   For lLoop = 0 To pDoc.Maps.Count - 1
682:     If pDoc.Maps.Item(lLoop).Name = "Global Indicator" Or pDoc.Maps.Item(lLoop).Name = "Local Indicator" Then
683:       Set pMap = pDoc.Maps.Item(lLoop)
      'Find the Index layer
685:       For lLoop2 = 0 To pMap.LayerCount - 1
686:         If pMap.Layer(lLoop2).Name = "Identifier Layer" Then
687:           Set pGridLayer = pMap.Layer(lLoop2)
688:           Exit For
689:         End If
690:       Next lLoop2
691:       If pGridLayer Is Nothing Then
692:         MsgBox "Could not find layer called Identifier Layer, can not redraw " & pMap.Name & " frame!!!"
        Exit Sub
694:       End If
      
'      Set pGridLayer = pDoc.Maps.Item(lLoop).Layer(0)