scalebar.frm

GIS地理信息系统开发。大名鼎鼎的MAPX＋VisualBasic6.0软件开发

      Map.Layers.Layer9.LabelProperties.Offset=   2
      Map.Layers.Layer9.LabelProperties.LineType=   0
      Map.Layers.Layer9.LabelProperties.Zoom=   -1  'True
      Map.Layers.Layer9.LabelProperties.ZoomMin=   0
      Map.Layers.Layer9.LabelProperties.ZoomMax=   10000
      Map.Layers.Layer9.LabelProperties.Visible=   -1  'True
      Map.Layers.Layer9.LabelProperties.Position=   0
      Map.Layers.Layer9.LabelProperties.Parellel=   -1  'True
      Map.Layers.Layer9.LabelProperties.PartialSegments=   0   'False
      Map.Layers.Layer9.LabelProperties.Style.TextFontBackColor=   16777215
      Map.Layers.Layer9.LabelProperties.Style.SymbolChar=   0
      BeginProperty Map.Layers.Layer9.LabelProperties.Style.TextFont {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Arial"
         Size            =   9
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      BeginProperty Map.Layers.Layer9.LabelProperties.Style.SymbolFont {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   12
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Map.Layers.Layer9.LabelProperties.Style.LineStyle=   1
      Map.Layers.Layer9.LabelProperties.Style.LineWidth=   1
      Map.NumericCoordSys.ProjectionInfo=   "scaleBar.frx":0000
      Map.DisplayCoordSys.ProjectionInfo=   "scaleBar.frx":0130
      Map.Zoom        =   3272.71025569536
      Map.CenterX     =   -95.6166331741086
      Map.CenterY     =   38.2558614060309
      FeatureEditMode =   1
   End
   Begin VB.Menu fileMenuItem 
      Caption         =   "File"
      Begin VB.Menu exitMenuItem 
         Caption         =   "Exit"
      End
   End
   Begin VB.Menu toolsMenuItem 
      Caption         =   "Tools"
      Begin VB.Menu zoomInToomMenuItem 
         Caption         =   "Zoom In"
      End
      Begin VB.Menu zoomOutToolMenuItem 
         Caption         =   "Zoom Out"
      End
      Begin VB.Menu panToolMenuItem 
         Caption         =   "Pan Tool"
      End
   End
   Begin VB.Menu layerMenuItem 
      Caption         =   "Layers"
      Begin VB.Menu addUDLMenuItem 
         Caption         =   "Add User Draw"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' This sample application and corresponding sample code is provided
' for example purposes only.  It has not undergone rigorous testing
' and as such should not be shipped as part of a final application
' without extensive testing on the part of the organization releasing
' the end-user product.

Public UDLAdded As Boolean

Private Sub addUDLMenuItem_Click()
    ' if the user draw layer is not in map, add it
    ' and change the menu item to say remove layer
    Dim layerinfo As New layerinfo
    If Not UDLAdded Then
        layerinfo.Type = miLayerInfoTypeUserDraw
        layerinfo.AddParameter "Name", "ScaleBar"
        Map1.Layers.Add layerinfo, 1
        UDLAdded = True
        addUDLMenuItem.Caption = "Remove User Draw Layer"
    Else
    ' Remove the layer and change menu item to say add
    ' Layer
        Map1.Layers.Remove "ScaleBar"
        UDLAdded = False
        addUDLMenuItem.Caption = "Add User Draw Layer"
    End If
End Sub

Private Sub exitMenuItem_Click()
    End
End Sub

Private Sub Form_Load()
    ' Set global to false by default, because User draw
    ' layer has not yet been added
    UDLAdded = False
End Sub

Private Sub Map1_DrawUserLayer(ByVal Layer As Object, ByVal hOutputDC As Stdole.OLE_HANDLE, ByVal hAttributeDC As Stdole.OLE_HANDLE, ByVal RectFull As Object, ByVal RectInvalid As Object)
  Dim barWidth As Single, barHeight As Single
    Dim screenX As Single, screenY As Single
    Dim mapX1 As Double, mapY1 As Double
    Dim mapX2 As Double, mapY2 As Double
    Dim totalDistance As Long
    Dim ptArray(2) As POINTAPI
    Dim i As Integer
    Dim StartX As Single, StartY As Single
    Dim hFont As Long
    Dim SavedScaleMode As Integer
    
    'set the x increment to be 1/2 an inch
    barWidth = 0.5
    
    'set the y increment
    barHeight = 0.05
    
    'Set start of scaleBar
    StartX = 0.7
    StartY = 0.7
    
    'Set the mapMode of Device Context
    SetMapMode hOutputDC, MM_HIENGLISH
    'Set the current Pen of the Device Context
    SelectObject hOutputDC, CreatePen(0, 1, BLACK)
    
    Dim x1 As Long, x2 As Long, y1 As Long, y2 As Long
    Dim m_LogBrush As LOGBRUSH
    
    'The conversion factor is needed because one HIENGLISH unit is .001 inch
    x1 = StartX * HIENGLISH_CONVERSION
    y1 = StartY * HIENGLISH_CONVERSION
    barWidth = barWidth * HIENGLISH_CONVERSION
    barHeight = barHeight * HIENGLISH_CONVERSION
    For i = 1 To 2
        'Set start and end locations of first section of scaleBar.
        x2 = barWidth + x1
        y2 = barHeight + y1
        
        'Set Brush Type
        'if loop count is 1 then first section so set brush to red
        If i = 1 Then
            m_LogBrush.lbStyle = BS_SOLID
            m_LogBrush.lbColor = RED
        Else    'Second section, so set brush to white
            m_LogBrush.lbStyle = BS_SOLID
            m_LogBrush.lbColor = WHITE
        End If
        SelectObject hOutputDC, CreateBrushIndirect(m_LogBrush)
        'with mapMode HIENGLISH, positive x is to the right, positive y is up
        Rectangle hOutputDC, x1, -y1, x2, -y2
        
        'Draw Second Section, y stays constant
        If i = 1 Then
            m_LogBrush.lbStyle = BS_SOLID
            m_LogBrush.lbColor = WHITE
        Else
            m_LogBrush.lbStyle = BS_SOLID
            m_LogBrush.lbColor = RED
        End If
        SelectObject hOutputDC, CreateBrushIndirect(m_LogBrush)
        x1 = x2
        x2 = barWidth + x1
        Rectangle hOutputDC, x1, -y1, x2, -y2
    
        'Draw third section
        If i = 1 Then
            m_LogBrush.lbStyle = BS_SOLID
            m_LogBrush.lbColor = RED
        Else
            m_LogBrush.lbStyle = BS_SOLID
            m_LogBrush.lbColor = WHITE
        End If
        SelectObject hOutputDC, CreateBrushIndirect(m_LogBrush)
        x1 = x2
        x2 = barWidth * 2 + x1
        Rectangle hOutputDC, x1, -y1, x2, -y2
        
        x1 = StartX * HIENGLISH_CONVERSION
        y1 = y2
    Next
    
    'Fill array to use for distance later
    SavedScaleMode = Form1.ScaleMode
    Form1.ScaleMode = 5   'inch
    
    'Calculate distance at the center of map.  1 inch in each direction for the x value
    ptArray(0).x = (ScaleWidth * 1000 / 2) - 1000   '1000 HIENGLISH = 1 inch
    ptArray(0).y = -ScaleHeight * 1000 / 2
    ptArray(1).x = (ScaleWidth * 1000 / 2) + 1000   '1000 HIENGLISH = 1 inch
    ptArray(1).y = -ScaleHeight * 1000 / 2
    
    'Call API to get pixel values for first section HIENGLISH screen Coordinates
    'Store these values in map values to be used in Distance Function
    LPtoDP hOutputDC, ptArray(0), 2
    screenX = ptArray(0).x
    screenY = ptArray(0).y
    Map1.ConvertCoord screenX, screenY, mapX1, mapY1, miScreenToMap
    
    screenX = ptArray(1).x
    screenY = ptArray(1).y
    Map1.ConvertCoord screenX, screenY, mapX2, mapY2, miScreenToMap
    
    totalDistance = Map1.Distance(mapX1, mapY1, mapX2, mapY2)
    
    'Set up font, Text color and text Background Color
    hFont = CreatePointFont(100, "Arial", hOutputDC)
    SelectObject hOutputDC, hFont
    SetTextColor hOutputDC, BLACK
    SetBkMode hOutputDC, TRANSPARENT
    
    'Place text on scaleBar
    x1 = StartX * HIENGLISH_CONVERSION
    y1 = (StartY - 0.19) * HIENGLISH_CONVERSION
    
    TextOut hOutputDC, x1, -y1, "0", 1
    
    x1 = (barWidth * 2) + (StartX * HIENGLISH_CONVERSION)
    Dim midPoint As Long
    midPoint = totalDistance / 2
    
    'Value to center mile text on top of partition line
    Dim centerCorrection As Integer
    centerCorrection = 60 * Len(Str$(midPoint))
    
    TextOut hOutputDC, x1 - centerCorrection, -y1, Str$(midPoint), Len(Str$(midPoint))
    
    x1 = (barWidth * 4) + (StartY * HIENGLISH_CONVERSION)
    centerCorrection = 60 * Len(Str$(totalDistance))
    TextOut hOutputDC, x1 - centerCorrection, -y1, Str$(totalDistance), Len(Str$(totalDistance))
    
    'Place MapUnit Description under scalebar
    x1 = (barWidth * 2) + (StartX * HIENGLISH_CONVERSION)
    centerCorrection = 60 * Len("Miles")
    y1 = (StartY + 0.1) * HIENGLISH_CONVERSION
    TextOut hOutputDC, x1 - centerCorrection, -y1, "Miles", Len("Miles")
    ' restore scale mode
    Form1.ScaleMode = SavedScaleMode
End Sub

Private Function CreatePointFont(nPointSize As Integer, sFontName As String, hDC As Stdole.OLE_HANDLE) As Long
' This function returns a handle to a created logical font.  The calling function
' is responsible for destroying the font after using it.

    Dim LogFont As LogFont
    Dim pt As POINTAPI
    Dim ptOrg As POINTAPI
    Dim i As Integer
    Dim b As Byte
    Dim s As String
            
    LogFont.lfHeight = nPointSize
    LogFont.lfWidth = 0
    LogFont.lfEscapement = 0
    LogFont.lfOrientation = 0
    LogFont.lfWeight = 700
    LogFont.lfItalic = 0
    LogFont.lfUnderline = 0
    LogFont.lfStrikeOut = 0
    LogFont.lfCharSet = DEFAULT_CHARSET
    LogFont.lfOutPrecision = 0
    LogFont.lfClipPrecision = 0
    LogFont.lfQuality = 0
    LogFont.lfPitchAndFamily = 0
    ' Copy the string arg to the byte array
    For i = 1 To Len(sFontName)
        If i > LF_FACESIZE Then
            Exit For
        End If
        s = Mid(sFontName, i, 1)
        b = CByte(Asc(s))
        LogFont.lfFaceName(i - 1) = b
    Next
    
    ' convert nPointSize to logical units based on pDC
    pt.y = GetDeviceCaps(hDC, LOGPIXELSY) * LogFont.lfHeight
    pt.y = pt.y / 720    ' 72 points/inch, 10 decipoints/point
    DPtoLP hDC, pt, 1
    ptOrg.x = 0
    ptOrg.y = 0
    DPtoLP hDC, ptOrg, 1
    LogFont.lfHeight = -Abs(pt.y - ptOrg.y)
    
    CreatePointFont = CreateFontIndirect(LogFont)
    
End Function

Private Sub Map1_ToolUsed(ByVal ToolNum As Integer, ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double, ByVal Distance As Double, ByVal Shift As Boolean, ByVal Ctrl As Boolean, EnableDefault As Boolean)
    'The pan tool only partially updates the window. Since we are drawing non-georeferenced objects
    'to the map via the userdraw layer we need to make sure the map completely refreshes. We only need
    'to do this if the pan tool is active and the scalebar user draw layer is loaded.
    If ToolNum = miPanTool Then
        If UDLAdded = True Then
            'redraw entire map
            Map1.Refresh
        End If
    End If
End Sub

Private Sub panToolMenuItem_Click()
    'set pan tool as active tool
    Map1.CurrentTool = miPanTool
End Sub

Private Sub zoomInToomMenuItem_Click()
    'set zoom in tool as active tool
    Map1.CurrentTool = miZoomInTool
End Sub

Private Sub zoomOutToolMenuItem_Click()
    'set zoom out tool as active tool
    Map1.CurrentTool = miZoomOutTool
End Sub