copyfocusmap.frm

使用VB.NET在ArcGIS Engine下面开发的有关地图打印的程序

    pEnv.PutCoords 1, 1, 1, 1
        
    Dim pID As New UID
    pID.Value = "esriCarto.MarkerNorthArrow"
    
    Dim pMapSurround As IMapSurround
      
    Dim pMarkerNorthArrow As IMarkerNorthArrow
    'Set pMarkerNorthArrow = New MarkerNorthArrow

    
    Set pMapSurround = CreateSurround(pID, pEnv, "NorthArrow", PageLayoutControl1.ActiveView.FocusMap, PageLayoutControl1.PageLayout)
          
    'Set pMapSurround = PageLayoutControl1.ActiveView.FocusMap.CreateMapSurround(pID, Nothing)
    'Dim c As Integer
    'c = PageLayoutControl1.ActiveView.FocusMap.MapSurroundCount
         
     
    'Set pMarkerNorthArrow = pMapSurround
    Set pMarkerNorthArrow = pMapSurround
    Dim pCharMarkerSymbol As ICharacterMarkerSymbol
    Set pCharMarkerSymbol = pMarkerNorthArrow.MarkerSymbol
    'pCharMarkerSymbol.CharacterIndex = 205
    pCharMarkerSymbol.CharacterIndex = 210
    pMarkerNorthArrow.MarkerSymbol = pCharMarkerSymbol
    PageLayoutControl1.ActiveView.Refresh
End Sub


Private Function CreateSurround(pID As UID, pEnv As IEnvelope, strName As String, _
                           pMap As IMap, pPageLayout As IPageLayout) As IMapSurround
  
  Dim pGraphicsContainer As IGraphicsContainer
  Dim pActiveView As IActiveView
  Dim pMapSurroundFrame As IMapSurroundFrame
  Dim pMapSurround As IMapSurround
  Dim pMapFrame As IMapFrame
  Dim pElement As IElement
  
  'MapSurrounds are held in a MapSurroundFrame
  'MapSurroundFrames are related to MapFrames
  'MapFrames hold Maps
  Set pGraphicsContainer = pPageLayout
  Set pMapFrame = pGraphicsContainer.FindFrame(pMap)
  Set pMapSurroundFrame = pMapFrame.CreateSurroundFrame(pID, Nothing)
  pMapSurroundFrame.MapSurround.Name = strName

  'Set the geometry of the MapSurroundFrame to give it a location
  'Activate it and add it to the PageLayout's graphics container
  Set pElement = pMapSurroundFrame
  Set pActiveView = pPageLayout
  pElement.Geometry = pEnv
  pElement.Activate pActiveView.ScreenDisplay


  'Allow the legend frame size to be altered after the legend has been
  'added to the GraphicsContainer
  Dim PTrack As ITrackCancel
  Set PTrack = New CancelTracker
  pElement.Draw pActiveView.ScreenDisplay, PTrack

  pGraphicsContainer.AddElement pElement, 0
  'Re-apply the change to the Legend MapSurroundFrame Geometry
  pElement.Geometry = pEnv
  
  Set CreateSurround = pMapSurroundFrame.MapSurround
End Function


Private Sub Command2_Click()
  'PageLayoutControl1.PageLayout.ZoomToWidth ' Dont' work, moves whole thing
  ZoomInCenter
End Sub

'www.gisempire.com/bbs/index.asp
Public Sub ZoomInCenter()
  
  Dim pActiveView As IActiveView
  Dim pDisplayTransform As IDisplayTransformation
  Dim pEnvelope As IEnvelope
  Dim pCenterPoint As IPoint
  Dim pMap As IMap
  
  'Set pActiveView = PageLayoutControl1.ActiveView
  Set pMap = PageLayoutControl1.ActiveView.FocusMap
  Set pActiveView = pMap
  
  'Set pActiveView = PageLayoutControl1.ActiveView.FocusMap
  Set pDisplayTransform = pActiveView.ScreenDisplay.DisplayTransformation
  'pDisplayTransform.Rotation = 20
  
  Set pEnvelope = pDisplayTransform.VisibleBounds
  'In this case, we could have set pEnvelope to IActiveView::Extent
  'Set pEnvelope = pActiveView.Extent
  Set pCenterPoint = New Point
  pCenterPoint.x = ((pEnvelope.XMax - pEnvelope.XMin) / 2) + pEnvelope.XMin
  pCenterPoint.y = ((pEnvelope.YMax - pEnvelope.YMin) / 2) + pEnvelope.YMin
  pEnvelope.Width = pEnvelope.Width / 2
  pEnvelope.Height = pEnvelope.Height / 2
  pEnvelope.CenterAt pCenterPoint
  
  pDisplayTransform.VisibleBounds = pEnvelope
  
  pActiveView.Refresh
End Sub


Private Sub PageLayoutControl1_OnMouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long, ByVal pageX As Double, ByVal pageY As Double)
  
  ' This .ToMapPoint(x, y) will yield a "Map" point which is actually a Page point, in inches
  'Set m_pPoint = PageLayoutControl1.ActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
  ' this will yield a map coordinate point.
  Dim pAV As IActiveView
  Set pAV = PageLayoutControl1.ActiveView.FocusMap
  Set m_pPoint = pAV.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
  
  Dim a As Double
  Dim b As Double
  
  a = m_pPoint.x
  b = m_pPoint.y
  
  m_bIsMouseDown = True
  
End Sub

Private Sub PageLayoutControl1_OnMouseMove(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long, ByVal mapX As Double, ByVal mapY As Double)
    If Not m_bIsMouseDown Then Exit Sub
    If (m_pFeedbackEnv Is Nothing) Then
        Set m_pFeedbackEnv = New NewEnvelopeFeedback
        Set m_pFeedbackEnv.Display = PageLayoutControl1.ActiveView.ScreenDisplay
        m_pFeedbackEnv.Start m_pPoint
    End If
   
    ' This .ToMapPoint(x, y) will yield a "Map" point which is actually a Page point, in inches
    'Set m_pPoint = PageLayoutControl1.ActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
    ' This will yield a map coordinate point.
    Dim pAV As IActiveView
    Set pAV = PageLayoutControl1.ActiveView.FocusMap
    Set m_pPoint = pAV.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
    
    m_pFeedbackEnv.MoveTo m_pPoint
End Sub

Private Sub PageLayoutControl1_OnMouseUp(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long, ByVal mapX As Double, ByVal mapY As Double)
    
    Dim pRubberBandOnPageExtent As IEnvelope
    
    If (m_pFeedbackEnv Is Nothing) Then
        'Just a regular zoom in centered about the clicked point.
        'm_bIsMouseDown = False
        'Dim pPrevClone As IClone, pNewClone As IClone
        'Set pPrevClone = pPageLayoutFullExt
        'Set pNewClone = pPrevClone.Clone
        'Set pRubberBandOnPageExtent = pNewClone
        'pRubberBandOnPageExtent.Expand 0.5, 0.5, True
    Else

        Set pRubberBandOnPageExtent = m_pFeedbackEnv.Stop
        Set m_pFeedbackEnv = Nothing
        m_bIsMouseDown = False
       
   End If

  ' Ensure that the Envelope created by the user is sensible, if
  ' it is set the map extents to be that envelope
  If Not (pRubberBandOnPageExtent Is Nothing) Then
    'Weed out ridiculous zoom requests
    'Check for zero width or height
    Dim dNewWidth As Double, dNewHeight As Double
    dNewWidth = pRubberBandOnPageExtent.Width
    dNewHeight = pRubberBandOnPageExtent.Height
    If ((dNewWidth > 0) And (dNewHeight > 0)) Then
        Dim pFullExt As IEnvelope
      
        'Set pFullExt = PageLayoutControl1.ActiveView.FullExtent
        Dim pActiveView As IActiveView
        Dim pDisplayTransform As IDisplayTransformation
        
        Set pActiveView = PageLayoutControl1.ActiveView.FocusMap
        'Set pActiveView = PageLayoutControl1.ActiveView.FocusMap
        Set pDisplayTransform = pActiveView.ScreenDisplay.DisplayTransformation
  
        Set pFullExt = pDisplayTransform.VisibleBounds
  
      
        Dim dFullWidth As Double, dFullHeight As Double
        dFullWidth = pFullExt.Width
        dFullHeight = pFullExt.Height
        ' apply ZoomIn only within 1 millionth of the full extent
        Dim xzoomLimit As Double
        xzoomLimit = dFullWidth / 1000000
        Dim yzoomLimit As Double
        yzoomLimit = dFullHeight / 1000000
        If ((xzoomLimit < dNewWidth) And (yzoomLimit < dNewHeight)) Then
            
        'PageLayoutControl1.ActiveView.Extent = pExt
        'pDisplayTransform.VisibleBounds = pPageLayoutFullExt
        pDisplayTransform.VisibleBounds = pRubberBandOnPageExtent

        pActiveView.Refresh
      End If
    End If
  End If
  
  'reset rubberband and mousedown state
  Set m_pFeedbackEnv = Nothing

End Sub


Private Sub Command3_Click()
    
    Dim a As Double
    Dim b As Double
    Dim c As Double
    Dim d As Double
    Dim e As Double
    Dim f As Double
    Dim g As Double
    Dim h As Double
    Dim i As Double
    Dim j As Double
    Dim k As Double
    Dim l As Double
    Dim m As Double
    Dim n As Double
    Dim o As Double
    Dim p As Double
    
    Dim pPageLayoutFullExt As IEnvelope
    'Visible bounds is adjusted for aspect ratio.  Fitted bounds is the actual visible bounds.
    'Set pPageLayoutFullExt = PageLayoutControl1.ActiveView.ScreenDisplay.DisplayTransformation.VisibleBounds
    Set pPageLayoutFullExt = PageLayoutControl1.ActiveView.ScreenDisplay.DisplayTransformation.FittedBounds
    
    Dim pPrintableBoundsExt As IEnvelope
    Set pPrintableBoundsExt = PageLayoutControl1.PageLayout.Page.PrintableBounds
    'Not the same as Page.Printable Bounds.
    'Set pPrintableBoundsExt = PageLayoutControl1.Printer.Paper.PrintableBounds
    
    Dim pAV As IActiveView
    Dim pMapContrainedBounds As IEnvelope
    Dim pMapVisibleBounds As IEnvelope
    Set pAV = PageLayoutControl1.ActiveView.FocusMap
    Set pMapContrainedBounds = pAV.ScreenDisplay.DisplayTransformation.ConstrainedBounds
    Set pMapVisibleBounds = pAV.ScreenDisplay.DisplayTransformation.VisibleBounds
    
    a = pPageLayoutFullExt.Envelope.XMin
    b = pPageLayoutFullExt.Envelope.XMax
    c = pPageLayoutFullExt.Envelope.YMin
    d = pPageLayoutFullExt.Envelope.YMax
   
    e = pMapVisibleBounds.Envelope.XMin
    f = pMapVisibleBounds.Envelope.XMax
    g = pMapVisibleBounds.Envelope.YMin
    h = pMapVisibleBounds.Envelope.YMax
    
    i = pMapContrainedBounds.Envelope.XMin
    j = pMapContrainedBounds.Envelope.XMax
    k = pMapContrainedBounds.Envelope.YMin
    l = pMapContrainedBounds.Envelope.YMax
    
    m = pPrintableBoundsExt.Envelope.XMin
    n = pPrintableBoundsExt.Envelope.XMax
    o = pPrintableBoundsExt.Envelope.YMin
    p = pPrintableBoundsExt.Envelope.YMax

    'PageLayoutControl1.PageLayout.Page.FormID = esriPageFormCUSTOM
    'PageLayoutControl1.Page.PageToPrinterMapping = esriPageMappingCrop
        
    Dim pFrameElement As IFrameElement
    Dim pMapFrame As IMapFrame
    Set pFrameElement = PageLayoutControl1.ActiveView.GraphicsContainer.FindFrame(PageLayoutControl1.ActiveView.FocusMap)
    If Not (pFrameElement Is Nothing) Then
        
        Dim pElement As IElement
        Set pMapFrame = pFrameElement
        Set pElement = pMapFrame
        'Dim pEnvelope As IEnvelope
        'Set pEnvelope =
        pElement.Geometry = pPageLayoutFullExt
        'pMapFrame.ExtentType = esriExtentBounds
        'pMapFrame.MapBounds = pRubberBandOnPageExtent
    End If
            
    
    PageLayoutControl1.BorderStyle = esriNoBorder
    PageLayoutControl1.ActiveView.FocusMap.SetPageSize 20.5, 11.5
    PageLayoutControl1.Refresh
    

End Sub

Private Sub Command4_Click()
    Dim pFrameElement As IFrameElement
    Dim pElement As IElement
    Dim pMapFrame As IMapFrame
    Set pFrameElement = PageLayoutControl1.ActiveView.GraphicsContainer.FindFrame(PageLayoutControl1.ActiveView.FocusMap)
    If Not (pFrameElement Is Nothing) Then
        
 
        Set pMapFrame = pFrameElement
        Set pElement = pMapFrame
    End If
 Dim pColor As IColor
 Set pColor = New RgbColor
 pColor.RGB = &HFFFFBB 'light blue
 ' create a framedecoration to modify the frame element background
 Dim pFrameDecoration As IFrameDecoration
 Set pFrameDecoration = New SymbolBackground
 With pFrameDecoration
 .Color = pColor
 .CornerRounding = 50
 .HorizontalSpacing = 5
 .VerticalSpacing = 0
 End With
 'pFrameElement.Background = pFrameDecoration
 pFrameElement.Background = Nothing
 
 pColor.RGB = &HF00FBB 'light blue
 Dim pFrameDecoration2 As IFrameDecoration
 Set pFrameDecoration2 = New SymbolBorder
 With pFrameDecoration2
 .Color = pColor
 .CornerRounding = 0
 .HorizontalSpacing = 0
 .VerticalSpacing = 0
 End With
 'pFrameElement.Border = pFrameDecoration2
 pFrameElement.Border = Nothing
 
 
 Dim pGraphicsContainer  As IGraphicsContainer
 Set pGraphicsContainer = PageLayoutControl1.PageLayout
 
 pGraphicsContainer.UpdateElement pElement
  
 PageLayoutControl1.Refresh
End Sub

'www.gisempire.com/bbs/index.asp
Private Sub Command5_Click()
    Dim pPageLayoutFullExt As IEnvelope
    'Visible bounds is adjusted for aspect ratio.  Fitted bounds is the actual visible bounds.
    'Set pPageLayoutFullExt = PageLayoutControl1.ActiveView.ScreenDisplay.DisplayTransformation.VisibleBounds
    Set pPageLayoutFullExt = PageLayoutControl1.ActiveView.ScreenDisplay.DisplayTransformation.FittedBounds
    
    Dim dHeight As Double
    Dim dWidth As Double
    
    dWidth = pPageLayoutFullExt.Envelope.Width
    dHeight = pPageLayoutFullExt.Envelope.Height
    
    PageLayoutControl1.PageLayout.Page.FormID = esriPageFormCUSTOM
    PageLayoutControl1.PageLayout.Page.PutCustomSize dWidth, dHeight
    
    ' Now the paper is the same width and height as the control.
    ' So we can go ahead and resise the visible bonunds to hide that box
    'PageLayoutControl1.PageLayout.Page.IsPrintableAreaVisible = False
    Dim pBorder As IBorder
    Set pBorder = PageLayoutControl1.PageLayout.Page.Border
    
    Dim pColor As IColor
    Set pColor = New RgbColor
    pColor.RGB = &HFFFFFF 'white ' Doesn't work because it shows on map.
    'pColor.NullColor = true ' Doesn't work
    'pColor.Transparency = 0 ' Doesn't work
 
    Dim pFrameDecoration As IFrameDecoration
    Set pFrameDecoration = New SymbolBorder
    With pFrameDecoration
    .Color = pColor
    .CornerRounding = 0
    .HorizontalSpacing = 0
    .VerticalSpacing = 0
    End With
    PageLayoutControl1.PageLayout.Page.Border = pFrameDecoration
    'PageLayoutControl1.PageLayout.Page.Border = Nothing ' Doesn't work
    
      
    'PageLayoutControl1.ActiveView.FullExtent.Envelope.XMax = PageLayoutControl1.ActiveView.FullExtent.Envelope.XMax - 10
    'PageLayoutControl1.ActiveView.Extent.Envelope.XMax = PageLayoutControl1.ActiveView.Extent.Envelope.XMax - 10
    'PageLayoutControl1.ActiveView.FullExtent.Envelope.XMin = PageLayoutControl1.ActiveView.FullExtent.Envelope.XMin + 10
    
    'PageLayoutControl1.ActiveView.ScreenDisplay.DisplayTransformation.FittedBounds.Envelope.XMax = PageLayoutControl1.ActiveView.ScreenDisplay.DisplayTransformation.FittedBounds.Envelope.XMax + 10
    
    
    
End Sub
'www.gisempire.com/bbs/index.asp