layout.frm

mo的GPS例子程序

'+++SETUP THE NORTH ARROW+++

'Get north arrow frame
Set ge = tlPage.FindEvent("ARROW")
If Not ge Is Nothing Then
  Set rectFrame = ge.Shape
  Set ge = Nothing

  'calc north arrow dimensions
  printer_frame_originX_pix = ConvFrameInch2PrinterPix(rectFrame.Left, X_AXIS)
  printer_frame_originY_pix = ConvFrameInch2PrinterPix(rectFrame.Top, Y_AXIS) * -1
  printer_frame_width_pix = ConvFrameInch2PrinterPix(rectFrame.Width, X_AXIS)
  printer_frame_height_pix = ConvFrameInch2PrinterPix(rectFrame.Height, Y_AXIS)
  Set rectFrame = Nothing
  screen_frame_originX_pix = ConvTwips2Pix(Screen, frmView.picArrow.Left, X_AXIS)
  screen_frame_originY_pix = ConvTwips2Pix(Screen, frmView.picArrow.Top, Y_AXIS)
  screen_frame_width_pix = ConvTwips2Pix(Screen, frmView.picArrow.Width, X_AXIS)
  screen_frame_height_pix = ConvTwips2Pix(Screen, frmView.picArrow.Height, Y_AXIS)

  Printer.ScaleMode = vbPixels
  Printer.PaintPicture frmView.picArrow.Picture, _
                       printer_frame_originX_pix, _
                       printer_frame_originY_pix, _
                       printer_frame_width_pix, _
                       printer_frame_height_pix
             
End If 'Not rectFrame Is Nothing

'+++DUMP OUTPUT TO THE PRINTER+++
Printer.EndDoc

End Sub

Private Sub cmdResetAspects_Click()

'Find map frame and legend frame.  Adjust Y dimension
'so that X/Y aspect ratio of each fits the same ratio
'as back on frmView.
Call ResetFrameAspects

End Sub

Private Sub mapLayout_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)

'If in COMPOSE mode, toggle the option buttons for
'manipulating frames
If optComposePreview(0) Then
  Dim bFramesExist As Boolean
  Dim i As Integer
  bFramesExist = (tlPage.EventCount > 0)
  For i = 6 To 9
    optMouseAction(i).Enabled = bFramesExist
  Next
  'Label each frame
  Dim ge As MapObjects2.GeoEvent
  For i = 0 To tlPage.EventCount - 1
    Set ge = tlPage.Event(i)
    mapLayout.DrawText ge.Tag, ge.Shape.Center, tsym
  Next
 Else
  Call PreviewElements
End If

End Sub

Private Sub mapLayout_BeforeLayerDraw(ByVal Index As Integer, ByVal hDC As stdole.OLE_HANDLE)

'Calculate offset between upper-left corner of
'the Layout's full extent and the upper-left
'corner of the page sheet.
mc2page_offsetX = Abs(mapLayout.Extent.Left)
mc2page_offsetY = Abs(mapLayout.Extent.Top)

End Sub

Private Sub mapLayout_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

'Mouse coordinate display
Dim pt As MapObjects2.Point
Set pt = mapLayout.ToMapPoint(X, Y)
lblXcoord.Caption = "X:  " & Format(pt.X, "#0.00")
lblYcoord.Caption = "Y:  " & Format(pt.Y * -1, "#0.00")

Select Case iMouseOption
  Case 7   'if MOVING FRAME
    If Button = 1 Then
      Dim ptClickUp As MapObjects2.Point
      Set ptClickUp = mapLayout.ToMapPoint(X, Y)
      geActive.MoveTo ptClickUp.X, ptClickUp.Y
    End If
  Case 8   'if RESIZING FRAME
    'If mouse is up, show proper cursors.
    If Button = 0 Then
      Call SetMouseCursor(pt)
     Else
      'If mouse is down, stretch the active side.
      Call AdjustFrameSide(pt)
    End If
End Select
  
End Sub

Private Sub mapLayout_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Set ptClick = mapLayout.ToMapPoint(X, Y)

Select Case iMouseOption
  Case 0                          'zoom tool
    Call ZoomTool(Button, Shift)
  Case 1                          'pan tool
    Call PanTool
  Case 2                          'add map/scalebar frame
    Call AddFrame
  Case 3                          'add legend frame
    Call AddFrame
  Case 4                          'add title frame
    Call AddFrame
  Case 5                          'add north arrow frame
    Call AddFrame
  Case 6                          'select frame
    Call SelectFrame(ptClick)
  Case 7                          'move frame
    Call SelectFrame(ptClick)
    'See also mapLayout_MouseMove
  Case 8                          'resize frame
    'See mapLayout_MouseMove
  Case 9                          'delete frame
    Call DeleteFrame(ptClick)
End Select
    
End Sub

Private Sub Form_Load()

Call PositionLayoutForm

Call LoadBackgroundPage

Call InitializeSymbols

'Initialize mouse option variable
optMouseAction(0).Value = True  'zoom tool is selected
iMouseOption = 0

'Grab device context handle for Layout page.
mapLayout_hDC = GetDC(mapLayout.hwnd)

End Sub

Private Sub AddFrame()

Dim rectFrame As MapObjects2.Rectangle
Dim iElementOption As Integer
Dim strTagLabel As String

'User draws element frame location and dimension
Set rectFrame = mapLayout.TrackRectangle
If rectFrame Is Nothing Then
  Exit Sub
End If

'Determine which type of frame is to be added.
Select Case iMouseOption
  Case 2
    strTagLabel = "MAP"
  Case 3
    strTagLabel = "LEGEND"
  Case 4
    strTagLabel = "TITLE"
  Case 5
    strTagLabel = "ARROW"
End Select

'Delete any duplicate frames.  The map composition
'can have no more than one frame of any type.
Dim ge As MapObjects2.GeoEvent
Set ge = tlPage.FindEvent(strTagLabel)
If Not ge Is Nothing Then
  tlPage.RemoveEvent ge.Index
End If

'If there is already an active frame, then
'reset its color back to red.
If Not geActive Is Nothing Then
  geActive.SymbolIndex = 0
End If

'Add new frame rectangle to the TrackingLayer.
'Give it the active color.
'Store it in the active frame variable.
Set geActive = tlPage.AddEvent(rectFrame, 1)

'Assign a tag to the frame
geActive.Tag = strTagLabel

''Adjust aspect ratio of frame to match frmView element
'Call ResetFrameAspects

End Sub

Private Sub SelectFrame(ptClick As MapObjects2.Point)

Dim i As Integer
Dim bInside As Boolean

'Assume mouse click is outside all frames.
bInside = False

'Cycle thru all frames
For i = 0 To tlPage.EventCount - 1
  'If clicked-on frame is found...
  If tlPage.Event(i).Shape.IsPointIn(ptClick) Then
    '...note that something was found.
    bInside = True
    'If there was an active frame...
    If Not geActive Is Nothing Then
      '...set its color back to red (unselected).
      geActive.SymbolIndex = 0
    End If
    'Store the clicked-on frame as the active frame
    Set geActive = tlPage.Event(i)
    'Set the color of the new active frame to green (selected).
    geActive.SymbolIndex = 1
    Exit For
  End If
Next

'If no frames were clicked-on...
If Not bInside Then
  '...and there was a current active frame...
  If Not geActive Is Nothing Then
    '...set that active frame's color back to red (unselected)...
    geActive.SymbolIndex = 0
    '...and clear the variable which holds the active frame.
    Set geActive = Nothing
  End If
End If

End Sub

Private Sub ZoomTool(ByVal Button As Integer, ByVal Shift As Integer)

'BASIC ZOOM TOOL
If Shift = 0 Then
  If Button = 1 Then
   'Left click zooms into a box
    Set mapLayout.Extent = mapLayout.TrackRectangle
   Else
    'Right click zooms out by x1.2
     Dim rect As MapObjects2.Rectangle
     Set rect = mapLayout.Extent
     rect.ScaleRectangle (1.2)
     Set mapLayout.Extent = rect
  End If
  optMouseAction(1).Enabled = True
 Else
 'Shift click zooms back to full extent.
  Set mapLayout.Extent = mapLayout.FullExtent
  optMouseAction(1).Enabled = False
End If

End Sub

Private Sub PanTool()

'Pans the map
mapLayout.Pan

End Sub

Private Sub DeleteFrame(ptClick As MapObjects2.Point)

'Select the frame clicked-on, then delete it from
'the TrackingLayer
Call SelectFrame(ptClick)
tlPage.RemoveEvent geActive.Index

End Sub

Private Sub SetMouseCursor(pt As MapObjects2.Point)

Dim rect As MapObjects2.Rectangle
Dim tol As Single

'Capture the active frame rectangle shape
Set rect = geActive.Shape

'Calculate the page distance which is equal to 2 screen
'pixels at any zoom scale.
tol = mapLayout.ToMapDistance(2 * Screen.TwipsPerPixelX)

'Assume for the moment that the mouse is not over any
'frame edge.
mapLayout.MousePointer = moDefault
strResizeSide = "NONE"

'When within 2 screen pixels of one of the
'four edges of the active frame rectangle,
'change the mouse cursor to moSizeWE or moSizeNS.
If (Abs(pt.X - rect.Left) < tol) And _
   (pt.Y > rect.Bottom) And _
   (pt.Y < rect.Top) Then
  mapLayout.MousePointer = moSizeWE
  strResizeSide = "LEFT"
End If
If (Abs(pt.X - rect.Right) < tol) And _
   (pt.Y > rect.Bottom) And _
   (pt.Y < rect.Top) Then
  mapLayout.MousePointer = moSizeWE
  strResizeSide = "RIGHT"
End If
If (Abs(pt.Y - rect.Bottom) < tol) And _
   (pt.X > rect.Left) And _
   (pt.X < rect.Right) Then
  mapLayout.MousePointer = moSizeNS
  strResizeSide = "BOTTOM"
End If
If (Abs(pt.Y - rect.Top) < tol) And _
   (pt.X > rect.Left) And _
   (pt.X < rect.Right) Then
  mapLayout.MousePointer = moSizeNS
  strResizeSide = "TOP"
End If

End Sub

Private Sub AdjustFrameSide(pt As MapObjects2.Point)

Dim rect As MapObjects2.Rectangle

'If the mouse is not currently over a frame edge, bail out.
If strResizeSide = "NONE" Then
  Exit Sub
End If

'Capture the active frame's rectangle shape.
Set rect = geActive.Shape

'Adjust the appropriate side of the frame.
Select Case strResizeSide
  Case "LEFT"
    rect.Left = pt.X
    Set geActive.Shape = rect
  Case "RIGHT"
    rect.Right = pt.X
    Set geActive.Shape = rect
  Case "BOTTOM"
    rect.Bottom = pt.Y
    Set geActive.Shape = rect
  Case "TOP"
    rect.Top = pt.Y
    Set geActive.Shape = rect
End Select

End Sub

Private Sub optComposePreview_Click(Index As Integer)

'Bring the Layout back to full extent
Set mapLayout.Extent = mapLayout.FullExtent

'Enable MouseAction option buttons in COMPOSE mode, and
'Disable MouseAction option buttons in PREVIEW mode.
Dim i As Integer
For i = 0 To 9
  optMouseAction(i).Enabled = optComposePreview(0).Value
Next
cmdResetAspects.Enabled = optComposePreview(0).Value
mapLayout.Refresh

'If going from COMPOSE mode to PREVIEW mode...
'...make the frames invisible
'...StretchBlt the map composition elements onto the
'...Layout in their proportional sizes and positions.
'If going from PREVIEW mode to COMPOSE mode,
'...wipe out the preview appearance of the page elements.
'...make the frames visible again

Select Case Index
  Case 0         'going from PREVIEW to COMPOSE mode
    mapLayout.TrackingLayer.Visible = True
    mapLayout.Refresh
  Case 1
    mapLayout.TrackingLayer.Visible = False
    mapLayout.Refresh
End Select

End Sub

Private Sub optMouseAction_Click(Index As Integer)

'Which of the option buttons is selected at any time.
iMouseOption = Index

End Sub

Private Sub ResetFrameAspects()